1 : C ORTHO2 SOURCE CHAT 05/01/13 02:06:35 5004 2 : SUBROUTINE ORTHO2 (IPX0,IPLIS1,IPLIS2,LLIST,IPRIGI,PRECIS,NFOIS 3 : & ,COMBIN,IPX) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : ************************************************************************ 7 : * 8 : * O R T H O 2 9 : * ----------- 10 : * 11 : * FONCTION: 12 : * --------- 13 : * 14 : * R-ORTHOGONALISER UN CHPOINT "X" PAR RAPPORT A UNE SUITE DE 15 : * CHPOINTS "U(I)", "R" ETANT UNE RIGIDITE DONNEE. 16 : * CAS DE FIGURE OU L'ON NE CONNAIT PAS LES PRODUITS "R.U(I)". 17 : * 18 : * MODE D'APPEL: 19 : * ------------- 20 : * 20 : * CALL ORTHO2 (IPX0,IPLIS1,IPLIS2,LLIST,IPRIGI,PRECIS,NFOIS 21 : * & ,COMBIN,IPX) 22 : * 23 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 24 : * ----------- 25 : * 26 : * IPX0 ENTIER (E) POINTEUR DU CHPOINT A "R-ORTHOGONALISER". 27 : * IPLIS1 ENTIER (E) POINTEUR DU 'LISTCHPO' CONTENANT LES "U(I)" 28 : * IPLIS2 ENTIER (E) POINTEUR DU 'LISTREEL' CONTENANT LES 29 : * PRODUITS "U(I).R.U(I)". 30 : * LLIST ENTIER (E) NOMBRE DE CHPOINTS "U(I)". 31 : * IPRIGI ENTIER (E) POINTEUR DE LA 'RIGIDITE' "R". 32 : * PRECIS REEL DP (E) PRECISION DEMANDEE POUR LA 33 : * R-ORTHOGONALISATION. 34 : * = 0 SI L'ON NE VEUT PAS DE TEST DE 35 : * PRECISION. 36 : * ON NE VERIFIE PAS QUE "PRECIS >= 0". 37 : * NFOIS ENTIER (E) NOMBRE DE FOIS QUE L'ON EFFECTUE LA 38 : * "R-ORTHOGONALISATION" (POUR PALIER AUX 39 : * ERREURS D'ARRONDIS). 40 : * COMBIN SUBROUT. (E) SOUS-PROGRAMME DE COMBINAISON LINEAIRE DE 41 : * 2 'CHPOINTS'. 5 ARGUMENTS: 42 : * - 'CHPOINT' N.1 , 43 : * - REEL D.P. N.1 , 44 : * - 'CHPOINT' N.2 , 45 : * - REEL D.P. N.2 , 46 : * - 'CHPOINT' COMBINAISON LINEAIRE. 47 : * IPX ENTIER (S) POINTEUR DU CHPOINT "R-ORTHOGONAL" A LA 48 : * SUITE DE CHPOINTS. 49 : * 50 : * LEXIQUE: (ORDRE ALPHABETIQUE) 51 : * -------- 52 : * 53 : * IPU ENTIER POINTEUR D'UN CHPOINT "U(I)". 54 : * IPXX ENTIER POINTEUR DU CHPOINT "X" A UN CERTAIN STADE DE 55 : * TRANSFORMATION. 56 : * ORTHO LOGIQUE INDIQUE PAR "VRAI" OU "FAUX" SI LA 57 : * "R-ORTHOGONALISATION" A ETE EFFECTUEE AVEC 58 : * SUCCES. 59 : * PREMOD REEL DP PRECISION D'ORTHOGONALISATION, MODULEE EN 60 : * FONCTION DE LA TAILLE DU PROBLEME. 61 : * UTRUMX REEL DP MAXIMUM DES PRODUITS U(I)T.R.U(I) 62 : * UTRU REEL DP PRODUIT U(I)T.R.U(I) ("T" POUR "TRANSPOSE"). 63 : * XTRU REEL DP PRODUIT XT.R.U(I) ("T" POUR "TRANSPOSE"). 64 : * 65 : * REMARQUES: 66 : * ---------- 67 : * 68 : * PRECISION: LA PRECISION DEMANDEE N'EST PAS PRISE TELLE QUELLE. 69 : * ELLE EST MODULEE EN FONCTION DE LA TAILLE DU PROBLEME. EN EFFET, 70 : * ON NE PEUT PAS DEMANDER AUTANT DE PRECISION POUR UN PROBLEME DE 71 : * GRANDE TAILLE, POUR LEQUEL IL Y A D'AVANTAGE D'ERREURS DE 72 : * TRONCATURE. 73 : * 74 : * SOUS-PROGRAMMES APPELES: 75 : * ------------------------ 76 : * 77 : * DIMEN3, DTCHPO, ERREUR, EXTRA1, EXTRA4, MAXIM3, NORME2, YTMX. 78 : * 79 : * AUTEUR, DATE DE CREATION: 80 : * ------------------------- 81 : * 82 : * PASCAL MANIGOT 05 AVRIL 1985 83 : * 84 : * LE 26 AOUT 1985 (P. MANIGOT): PRECISION MODULEE EN FONCTION DE LA 85 : * TAILLE DU PROBLEME. 86 : * 87 : * LANGAGE: 88 : * -------- 89 : * 90 : * FORTRAN77 91 : * 92 : ************************************************************************ 93 : * 94 : -INC CCOPTIO 95 : * 96 : * 97 : LOGICAL ORTHO 98 : * 99 : PARAMETER (UN = 1.D0) 100 : PARAMETER (RLIM=0.1) 101 : EXTERNAL COMBIN 102 : * 103 : IPLMOX=0 104 : IPLMOY=0 105 : * TAILLE DU PROBLEME: 105 : CALL DIMEN3 (IPRIGI, NBRINC) 106 : IF (IERR .NE. 0) RETURN 107 : PREMOD = PRECIS * (DBLE(NBRINC)**2) 108 : * 108 : CALL MAXIM3 (IPLIS2, IPLACE,UTRUMX) 109 : IF (IERR .NE. 0) RETURN 110 : UTRUMX = ABS(UTRUMX) 111 : * 112 : * ON DONNE AU 'CHPOINT' A ORTHOGONALISER LE MEME ORDRE DE GRANDEUR 113 : * QUE CELUI DES 'CHPOINTS' DU 'LISTCHPO': 113 : CALL NORME2 (IPX0,UTRUMX,IPRIGI, IPX,XTRX,IPLMOX, 114 : C IPLMOY,IPRX) 115 : IF (IERR .NE. 0) RETURN 116 : XTRX1=XTRX 117 : * 118 : DO 100 IB100=1,NFOIS 119 : * 120 : DO 110 IB110=1,LLIST 121 : * 122 : * -- ORTHOGONALISATION -- 123 : * 123 : CALL EXTRA4 (IPLIS1,IB110, IPU) 124 : IF (IERR .NE. 0) RETURN 124 : CALL EXTRA1 (IPLIS2,IB110, UTRU) 125 : IF (IERR .NE. 0) RETURN 125 : CALL YTMX (IPX,IPU,IPRIGI, XTRU) 126 : IF (IERR .NE. 0) RETURN 127 : XXTRU = -1.D0 * XTRU / UTRU 127 : CALL COMBIN (IPX,UN,IPU,XXTRU, IPXX) 128 : IF (IERR .NE. 0) RETURN 128 : CALL DTCHPO (IPX) 129 : * 129 : C CALL NORME2 (IPXX,UTRUMX,IPRIGI, IPX,XTRX, 130 : C C IPLMOX,IPLMOY,IPRX) 131 : C IF (IERR .NE. 0) RETURN 131 : C CALL DTCHPO (IPXX) 132 : IPX=IPXX 133 : XTRX1=XTRX1-((XTRU*XTRU)/UTRU) 134 : * 135 : 110 CONTINUE 136 : RNM=ABS(XTRX1/XTRX) 137 : IF(RNM.GE.RLIM) GOTO 1001 138 : NV=LLIST+1 139 : WRITE(IOIMP,1000) NV,RNM 140 : 1000 FORMAT(/40X,'OPERATEUR VIBRA OPTION SIMULTANE',/10X, 141 : C ' DIFFICULTE D ORTHOGONALISER LE ',I5, 142 : C ' IEME VECTEUR NORME APRES ORTHOGONALISATION PAR ', 143 : C ' RAPPORT A LA NORME INITIALE ',E12.5) 144 : 1001 CONTINUE 145 : COEFF=SQRT(1.0E0/RNM) 145 : CALL MUCHPO(IPXX,COEFF,IPX,1) 145 : CALL DTCHPO(IPXX) 146 : XNOR=XTRX1*ABS(XTRX/XTRX1) 147 : * END DO 148 : * 149 : ORTHO = .TRUE. 150 : * 151 : IF (PRECIS .NE. 0.D0) THEN 152 : * 153 : * -- TEST D'ORTHOGONALITE -- 154 : * 155 : DO 120 IB120=1,LLIST 156 : * 156 : CALL EXTRA4 (IPLIS1,IB120, IPU) 157 : IF (IERR .NE. 0) RETURN 157 : CALL YTMX (IPX,IPU,IPRIGI, XTRU) 158 : IF (IERR .NE. 0) RETURN 159 : IF (ABS(XTRU) .GT. PREMOD*UTRUMX) THEN 160 : ORTHO = .FALSE. 161 : * --> SORTIE DE BOUCLE N.120 162 : GOTO 122 163 : END IF 164 : * 165 : 120 CONTINUE 166 : * END DO 167 : 122 CONTINUE 168 : * 169 : IF (ORTHO) THEN 170 : * --> SORTIE DE BOUCLE N.100 171 : GOTO 102 172 : END IF 173 : * 174 : END IF 175 : * 176 : 100 CONTINUE 177 : * END DO 178 : 102 CONTINUE 179 : * 180 : IF (.NOT.ORTHO) THEN 181 : INTERR(1) = NFOIS 182 : REAERR(1) = PREMOD 183 : NUMERR = 218 183 : CALL ERREUR (NUMERR) 184 : END IF 185 : * 186 : END 187 : 188 :
© Cast3M 2003 - All rights reserved.
Disclaimer