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