1 : C ORTHNG SOURCE CHAT 09/11/25 21:15:18 6548 2 : SUBROUTINE ORTHNG (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI, 3 : & XNOR,IPRX,IPX,IPLMOX,IPLMOY,XPRECI,IOP) 4 : ************************************************************************ 5 : * 6 : * O R T H N G 7 : * ----------- 8 : * 9 : * FONCTION: 10 : * --------- 11 : * 12 : * R-ORTHOGONALISER UN CHPOINT "X" PAR RAPPORT A UNE SUITE DE 13 : * CHPOINTS "U(I)", "R" ETANT UNE RIGIDITE DONNEE. 14 : * CAS DE FIGURE OU L'ON CONNAIT DEJA LES PRODUITS "R.U(I)". 15 : * SPECIFIQUE BOITE VIBRA 16 : * 17 : * FOURNI EN OUTRE UN VECTEUR NORMALISE ET R*X 18 : * MODE D'APPEL: 19 : * ------------- 20 : * 20 : * CALL ORTHNG (IPX0,IPLIS1,IPLIS2,IPLIS3,LLIST,IPRIGI, 21 : * & XNOR,IPRX,IPX,IPLMOX,IPLMOY) 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 : * "R-ORTHOGONALISATION" (POUR PALIER AUX 35 : * ERREURS D'ARRONDIS). 36 : * IPX ENTIER (S) POINTEUR DU CHPOINT "R-ORTHOGONAL" A LA 37 : * SUITE DE CHPOINTS. 38 : * IPRX ENTIER (S) POINTEUR SUR CHPOINT PRODUIT DE RIGI 39 : * PAR LE VECTEUR ORTHOGONALISE 40 : * XNOR REEL (S) NORME DE IPX 41 : * 42 : * IPLMOX ENTIER (E) POINTEUR SUR LISTMOTS (UX,...) 43 : * IPLMOY ENTIER (E) POINTEUR SUR LISTMOTS (FX,... 44 : * 45 : * LEXIQUE: (ORDRE ALPHABETIQUE) 46 : * -------- 47 : * 48 : * IPRU ENTIER POINTEUR D'UN CHPOINT "R.U(I)". 49 : * IPU ENTIER POINTEUR D'UN CHPOINT "U(I)". 50 : * IPXX ENTIER POINTEUR DU CHPOINT "X" A UN CERTAIN STADE DE 51 : * TRANSFORMATION. 52 : * ORTHO LOGIQUE INDIQUE PAR "VRAI" OU "FAUX" SI LA 53 : * "R-ORTHOGONALISATION" A ETE EFFECTUEE AVEC 54 : * SUCCES. 55 : * PREMOD REEL DP PRECISION D'ORTHOGONALISATION, MODULEE EN 56 : * FONCTION DE LA TAILLE DU PROBLEME. 57 : * UTRUMX REEL DP MAXIMUM DES PRODUITS U(I)T.R.U(I) 58 : * UTRU REEL DP PRODUIT U(I)T.R.U(I) ("T" POUR "TRANSPOSE"). 59 : * XTRU REEL DP PRODUIT XT.R.U(I) ("T" POUR "TRANSPOSE"). 60 : * 61 : * 62 : * SOUS-PROGRAMMES APPELES: 63 : * ------------------------ 64 : * 65 : * DIMEN3, DTCHPO, ERREUR, EXTRA1, EXTRA4, MAXIM3, NORME2, YTX1. 66 : * 67 : * AUTEUR, DATE DE CREATION: 68 : * ------------------------- 69 : * 70 : * D. BROCHARD FEVRIER 1988 71 : * 72 : * 73 : * LANGAGE: 74 : * -------- 75 : * 76 : * FORTRAN77 77 : * 78 : ************************************************************************ 79 : * 80 : IMPLICIT INTEGER(I-N) 81 : IMPLICIT REAL*8(A-H,O-Z) 82 : -INC CCOPTIO 83 : -INC SMLMOTS 84 : -INC SMLREEL 85 : -INC SMLCHPO 86 : * 87 : REAL*8 PRECIS 88 : REAL*8 XTRU,UTRU,UTRUMX,XTRX,PREMOD 89 : * 90 : LOGICAL ORTHO 91 : * 92 : PARAMETER (RLIM=0.1) 93 : * 94 : * 94 : CALL MAXIM3 (IPLIS2, IPLACE,UTRUMX) 95 : IF (IERR .NE. 0) RETURN 96 : UTRUMX = ABS(UTRUMX) 97 : MLCHPO=IPLIS1 98 : SEGACT MLCHPO 99 : MLREEL=IPLIS2 100 : SEGACT MLREEL 101 : MLCHP1=IPLIS3 102 : SEGACT MLCHP1 103 : IDET=0 104 : IF((IPLMOX*IPLMOY).EQ.0) THEN 105 : IPRU=MLCHP1.ICHPOI(1) 105 : CALL CORRSP(iprigi,IPX0,IPRU,IPLMOX,IPLMOY) 106 : IDET=1 107 : END IF 108 : * 109 : * ON DONNE AU 'CHPOINT' A ORTHOGONALISER LE MEME ORDRE DE GRANDEUR 110 : * QUE CELUI DES 'CHPOINTS' DU 'LISTCHPO': 110 : C A SUPPR. CALL NORME2 (IPX0,UTRUMX,IPRIGI, IPX,XTRX) 111 : 111 : CALL MUCPRI(IPX0,IPRIGI,IPRX) 112 : IF (IERR .NE. 0) RETURN 112 : CALL XTY1(IPX0,IPRX,IPLMOX,IPLMOY,XTRRX) 113 : * 114 : COEFF = SQRT( ABS(UTRUMX / XTRRX) ) 115 : MULTPL = 1 115 : CALL MUCHPO (IPX0,COEFF, IPX,MULTPL) 115 : CALL MUCHPO (IPRX,COEFF, IPXR,MULTPL) 116 : IF (IERR .NE. 0) RETURN 116 : CALL DTCHPO(IPRX) 117 : IPRX=IPXR 118 : * 119 : XTRX = ABS(UTRUMX/XTRRX) * XTRRX 120 : * 121 : XTRX1 = XTRX 121 : CALL XTY1(IPX,IPX,IPLMOX,IPLMOX,XTX0) 122 : * 123 : if( iop.eq.0) then 124 : ideb=1 125 : ifin=llist 126 : ipas=1 127 : xpreca=-1.d0 128 : elseif(iop.eq.1) then 129 : ideb=1 130 : ifin = llist 131 : ipas = 1 132 : xpreca=xpreci 133 : elseif(iop.eq.2) then 134 : ideb=llist 135 : ifin = 1 136 : ipas = -1 137 : xpreca=xpreci 138 : elseif(iop.eq.3) then 139 : ideb=llist 140 : ifin=max (ideb - 5,1) 141 : ipas = -1 142 : xpreca=-1.d0 143 : else 143 : call erreur(5) 144 : return 145 : endif 146 : 147 : iaa=0 148 : DO 110 IB110=ideb,ifin,ipas 149 : iaa=iaa+1 150 : * 151 : * -- ORTHOGONALISATION -- 152 : * 153 : IPU=ICHPOI(IB110) 154 : UTRU=PROG(IB110) 155 : IPRU=MLCHP1.ICHPOI(IB110) 155 : CALL XTY1 (IPX,IPRU,IPLMOX,IPLMOY, XTRU) 156 : IF (IERR .NE. 0) RETURN 157 : XXTRU = -1.D0 * XTRU / UTRU 158 : 159 : * 160 : * WRITE(IOIMP,*) IB110,XXTRU,XTRU,UTRU 161 : * 162 : if (abs(xxtru).lt.xpreca.and.iaa.ne.1) go to 111 162 : CALL ADCHPO(IPU,IPX,IPXX,XXTRU,1D0) 162 : CALL ADCHPO(IPRU,IPRX,IPXR,XXTRU,1D0) 162 : CALL DTCHPO(IPRX) 162 : CALL DTCHPO (IPX) 163 : IPRX=IPXR 164 : IPX=IPXX 165 : * 166 : * 167 : XTRX1=XTRX1-((XTRU*XTRU)/UTRU) 168 : * 169 : * 170 : 110 CONTINUE 171 : 111 CONTINUE 172 : * write(6,*) ' iprx ipx' , iprx, ipx 173 : * 174 : * 174 : CALL XTY1 (IPX,IPRX,IPLMOX,IPLMOY, XTRX2) 175 : 176 : RNM=ABS(XTRX1/XTRX) 177 : IF(RNM.GE.RLIM) GOTO 1001 178 : NV=LLIST+1 179 : * WRITE(IOIMP,1000) NV,RNM 180 : 1000 FORMAT(/40X,'OPERATEUR VIBRA OPTION SIMULTANE',/10X, 181 : C ' DIFFICULTE D ORTHOGONALISER LE ',I5, 182 : C ' IEME VECTEUR ',/10X,'NORME APRES ORTHOGONALISATION PAR ', 183 : C ' RAPPORT A LA NORME INITIALE ',E12.5) 184 : 1001 CONTINUE 185 : ck COEFF=SQRT(1.0E0/RNM) 186 : coeff = 1.e0/sqrt(abs(xtrx2)) 186 : CALL MUCHPO(IPXX,COEFF,IPX,1) 186 : CALL MUCHPO(IPXR,COEFF,IPRX,1) 186 : CALL DTCHPO(IPXX) 186 : CALL DTCHPO(IPXR) 187 : XNOR=XTRX1*ABS(XTRX/XTRX1) 187 : c CALL XTY1 (IPX,IPRX,IPLMOX,IPLMOY, XTRX3) 188 : c write(6,*) llist,rnm, xtrx2/xtrx,xtrx2,xtrx3,xnor 189 : * 190 : * 191 : * 192 : ORTHO = .TRUE. 193 : * 194 : SEGDES MLCHPO 195 : SEGDES MLCHP1 196 : SEGDES MLREEL 197 : IF(IDET.EQ.1) THEN 198 : MLMOTS =IPLMOX 199 : MLMOT1 =IPLMOY 200 : SEGSUP MLMOTS,MLMOT1 201 : END IF 202 : * 203 : IF (.NOT.ORTHO) THEN 204 : * INTERR(1) = NFOIS VALEUR NON DEFINIS 205 : * REAERR(1) = PREMOD 206 : INTERR(1) = 0 207 : REAERR(1) = 0 207 : CALL ERREUR (218) 208 : END IF 209 : RETURN 210 : END 211 : 212 : 213 : 214 :
© Cast3M 2003 - All rights reserved.
Disclaimer