C ORTHO1 SOURCE CHAT 05/01/13 02:06:32 5004 SUBROUTINE ORTHO1 (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI,PRECIS & ,NFOIS,COMBIN,IPX) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) ************************************************************************ * * O R T H O 1 * ----------- * * FONCTION: * --------- * * R-ORTHOGONALISER UN CHPOINT "X" PAR RAPPORT A UNE SUITE DE * CHPOINTS "U(I)", "R" ETANT UNE RIGIDITE DONNEE. * CAS DE FIGURE OU L'ON CONNAIT DEJA LES PRODUITS "R.U(I)". * * MODE D'APPEL: * ------------- * * CALL ORTHO1 (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI,PRECIS * & ,NFOIS,COMBIN,IPX) * * PARAMETRES: (E)=ENTREE (S)=SORTIE * ----------- * * IPX0 ENTIER (E) POINTEUR DU CHPOINT A "R-ORTHOGONALISER". * IPLIS1 ENTIER (E) POINTEUR DU 'LISTCHPO' CONTENANT LES "U(I)" * IPLIS2 ENTIER (E) POINTEUR DU 'LISTREEL' CONTENANT LES * PRODUITS "U(I).R.U(I)". * IPLIS3 ENTIER (E) POINTEUR DU 'LISTCHPO' CONTENANT LES * PRODUITS "R.U(I)". * LLIST ENTIER (E) NOMBRE DE CHPOINTS "U(I)". * IPRIGI ENTIER (E) POINTEUR DE LA 'RIGIDITE' "R". * PRECIS REEL DP (E) PRECISION DEMANDEE POUR LA * R-ORTHOGONALISATION. * = 0 SI L'ON NE VEUT PAS DE TEST DE * PRECISION. * ON NE VERIFIE PAS QUE "PRECIS >= 0". * NFOIS ENTIER (E) NOMBRE DE FOIS QUE L'ON EFFECTUE LA * "R-ORTHOGONALISATION" (POUR PALIER AUX * ERREURS D'ARRONDIS). * COMBIN SUBROUT. (E) SOUS-PROGRAMME DE COMBINAISON LINEAIRE DE * 2 'CHPOINTS'. 5 ARGUMENTS: * - 'CHPOINT' N.1 , * - REEL D.P. N.1 , * - 'CHPOINT' N.2 , * - REEL D.P. N.2 , * - 'CHPOINT' COMBINAISON LINEAIRE. * IPX ENTIER (S) POINTEUR DU CHPOINT "R-ORTHOGONAL" A LA * SUITE DE CHPOINTS. * * LEXIQUE: (ORDRE ALPHABETIQUE) * -------- * * IPRU ENTIER POINTEUR D'UN CHPOINT "R.U(I)". * IPU ENTIER POINTEUR D'UN CHPOINT "U(I)". * IPXX ENTIER POINTEUR DU CHPOINT "X" A UN CERTAIN STADE DE * TRANSFORMATION. * ORTHO LOGIQUE INDIQUE PAR "VRAI" OU "FAUX" SI LA * "R-ORTHOGONALISATION" A ETE EFFECTUEE AVEC * SUCCES. * PREMOD REEL DP PRECISION D'ORTHOGONALISATION, MODULEE EN * FONCTION DE LA TAILLE DU PROBLEME. * UTRUMX REEL DP MAXIMUM DES PRODUITS U(I)T.R.U(I) * UTRU REEL DP PRODUIT U(I)T.R.U(I) ("T" POUR "TRANSPOSE"). * XTRU REEL DP PRODUIT XT.R.U(I) ("T" POUR "TRANSPOSE"). * * REMARQUES: * ---------- * * PRECISION: LA PRECISION DEMANDEE N'EST PAS PRISE TELLE QUELLE. * ELLE EST MODULEE EN FONCTION DE LA TAILLE DU PROBLEME. EN EFFET, * ON NE PEUT PAS DEMANDER AUTANT DE PRECISION POUR UN PROBLEME DE * GRANDE TAILLE, POUR LEQUEL IL Y A D'AVANTAGE D'ERREURS DE * TRONCATURE. * * CE SOUS-PROGRAMME A ETE CREE PAR ANALOGIE AVEC "ORTHO2" ET NE * POURRA ETRE TESTE QUE LORSQUE L'OPERATEUR "YTX" EXISTERA. * * SOUS-PROGRAMMES APPELES: * ------------------------ * * DIMEN3, DTCHPO, ERREUR, EXTRA1, EXTRA4, MAXIM3, NORME2, YTX1. * * AUTEUR, DATE DE CREATION: * ------------------------- * * PASCAL MANIGOT 05 AVRIL 1985 * * LE 26 AOUT 1985 (P. MANIGOT): PRECISION MODULEE EN FONCTION DE LA * TAILLE DU PROBLEME. * * LANGAGE: * -------- * * FORTRAN77 * ************************************************************************ * -INC CCOPTIO -INC SMLMOTS * * LOGICAL ORTHO * PARAMETER (UN = 1.D0) PARAMETER (RLIM=0.1) EXTERNAL COMBIN * * TAILLE DU PROBLEME: CALL DIMEN3 (IPRIGI, NBRINC) IF (IERR .NE. 0) RETURN PREMOD = PRECIS * (DBLE(NBRINC)**2) * CALL MAXIM3 (IPLIS2, IPLACE,UTRUMX) IF (IERR .NE. 0) RETURN UTRUMX = ABS(UTRUMX) * * ON DONNE AU 'CHPOINT' A ORTHOGONALISER LE MEME ORDRE DE GRANDEUR * QUE CELUI DES 'CHPOINTS' DU 'LISTCHPO': IPLMOX=0 IPLMOY=0 CALL NORME2 (IPX0,UTRUMX,IPRIGI, IPX,XTRX,IPLMOX, C IPLMOY,IPRX) IF (IERR .NE. 0) RETURN XTRX1 = XTRX * DO 100 IB100=1,NFOIS * DO 110 IB110=1,LLIST * * -- ORTHOGONALISATION -- * CALL EXTRA4 (IPLIS1,IB110, IPU) IF (IERR .NE. 0) RETURN CALL EXTRA1 (IPLIS2,IB110, UTRU) IF (IERR .NE. 0) RETURN CALL EXTRA4 (IPLIS3,IB110, IPRU) IF (IERR .NE. 0) RETURN IF(IB100.EQ.1) CALL CORRSP(iprigi,IPX,IPRU,IPLMOX,IPLMOY) CALL XTY1 (IPX,IPRU,IPLMOX,IPLMOY, XTRU) IF (IERR .NE. 0) RETURN XXTRU = -1.D0 * XTRU / UTRU * * * * 111 CALL COMBIN (IPX,UN,IPU,XXTRU, IPXX) IF (IERR .NE. 0) RETURN CALL DTCHPO (IPX) IPX=IPXX * * XTRX1=XTRX1-((XTRU*XTRU)/UTRU) 110 CONTINUE RNM=ABS(XTRX1/XTRX) IF(RNM.GE.RLIM) GOTO 1001 NV=LLIST+1 WRITE(IOIMP,1000) NV,RNM 1000 FORMAT(/40X,'OPERATEUR VIBRA OPTION SIMULTANE',/10X, C ' DIFFICULTE D ORTHOGONALISER LE ',I5, C ' IEME VECTEUR NORME APRES ORTHOGONALISATION PAR ', C ' RAPPORT A LA NORME INITIALE ',E12.5) 1001 CONTINUE COEFF=SQRT(1.0E0/RNM) CALL MUCHPO(IPXX,COEFF,IPX,1) CALL DTCHPO(IPXX) * END DO * ORTHO = .TRUE. * GOTO 100 * C 112 IF (PRECIS .NE. 0.D0) THEN * * -- TEST D'ORTHOGONALITE --SUPPRIME FEVR.88 * C DO 120 IB120=1,LLIST * C CALL EXTRA4 (IPLIS3,IB120, IPRU) C IF (IERR .NE. 0) RETURN C CALL XTY1 (IPX,IPRU,IPLMOX,IPLMOY, XTRU) C IF (IERR .NE. 0) RETURN C IF (ABS(XTRU) .GT. PREMOD*UTRUMX) THEN C ORTHO = .FALSE. C --> SORTIE DE BOUCLE N.120 C GOTO 122 C END IF C C 120 CONTINUE C END DO C 122 CONTINUE * C IF (ORTHO) THEN * --> SORTIE DE BOUCLE N.100 C GOTO 102 C END IF C C END IF * 100 CONTINUE * END DO 102 CONTINUE MLMOTS =IPLMOX MLMOT1 =IPLMOY SEGSUP MLMOTS,MLMOT1 * IF (.NOT.ORTHO) THEN INTERR(1) = NFOIS REAERR(1) = PREMOD NUMERR = 218 CALL ERREUR (NUMERR) END IF RETURN END