1 : C CRSOL1 SOURCE BP208322 09/03/20 21:15:07 6331 2 : ************************************************************************ 3 : * 4 : * CRSOL1 5 : * ----------- 6 : * 7 : * FONCTION: 8 : * --------- 9 : * 10 : * -- CONSTRUCTION D'UN OBJET SOLUTION, A PARTIR DE LA LISTE 11 : * DES FREQUENCES PROPRES ET DE CELLE DES MODES PROPRES. 12 : * LES LISTES SONT SUPPOSES TRIEES, LES FREQUENCES SHIFTEES, 13 : * ET LES MODES ORTHONORMALISES. -- 14 : * 15 : * MODE D'APPEL: 16 : * ------------- 17 : * 17 : * CALL CRSOL1 (FREQ,IPLVAR,IPLVAI,IPLVER, IPLVEI, NBMOD, IPKW2M, IPMASS, 18 : * & MTAB3, ICOMP, I) 19 : * 20 : * PARAMETRES: (E)=ENTREE (S)=SORTIE 21 : * ----------- 22 : * 23 : * IPLVAR ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT 24 : * LA SUITE DES FREQUENCES PROPRES REELLES. 25 : * IPLVAI ENTIER (E) POINTEUR DE L'OBJET 'LISTREEL' CONTENANT 26 : * LA SUITE DES FREQUENCES IMAGINAIRES 27 : * IPLVER ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT 28 : * LA SUITE DES MODES PROPRES REELS. 29 : * IPLVEI ENTIER (E) POINTEUR DE L'OBJET 'LISTCHPO' CONTENANT 30 : * LA SUITE DES MODES PROPRES IMAGINAIRES. 31 : * NBMOD ENTIER (E) NOMBRE DE MODES A INSERER DANS LA SOLUTION 32 : * ON A: NBMOD .LE. DIMENSION( IPLVAL ) 33 : * 34 : * IPKW2M, IPMASS (E) MATRICES DE RIGIDITE (DECALEE) ET DE MASSE 35 : * 35 : * FREQ REEL (E) FREQUENCE UTILISEE POUR LE DECALLAGE 36 : * 37 : * MTAB3 ENTIER (S) POINTEUR SUR LA SOLUTION CREEE. 38 : * 39 : * 40 : * AUTEUR, DATE DE CREATION: 41 : * ------------------------- 42 : * 43 : * C. LE BIDEAU 09 / 2001 ( FORTRAN + ESOPE ) 44 : * MODIF Benoit Prabel Mars 2009 45 : * 46 : *************************************************** 47 : * SUBROUTINE CRSOL1 (FREQ,IPLVAR,IPLVAI,IPLVER, IPLVEI, 48 : * & NBMOD,IPKW2M,IPMASS,MTAB3,ICOMP, I) 49 : SUBROUTINE CRSOL1 (W2,IPLVAR,IPLVAI,IPLVER,NBMOD,NBMOD2, 50 : & IPKW2M,IPMASS,MTAB3,I,INF0) 51 : 52 : IMPLICIT INTEGER(I-N) 53 : IMPLICIT REAL*8 (A-H,O-Z) 54 : 55 : -INC CCOPTIO 56 : -INC SMLCHPO 57 : -INC SMLREEL 58 : -INC SMLMOTS 59 : -INC SMTABLE 60 : -INC CCREEL 61 : 62 : ****** 63 : * -- CONSTANTES -- 64 : *** 65 : PARAMETER (LPROPR = 10) 66 : PARAMETER (DEUXPI = (2.D0*XPI)) 67 : 68 : ****** 69 : * -- ARGUMENTS -- 70 : *** 71 : POINTEUR IPLVER.MLCHPO,IPLVAR.MLREEL,IPLVAI.MLREEL 72 : INTEGER NBMOD, IPKW2M, IPMASS 73 : 74 : ****** 75 : * -- VARIABLES LOCALES -- 76 : *** 77 : POINTEUR IPLMOX.MLMOTS, IPLMOY.MLMOTS 78 : INTEGER IPMODE, IPSOL1 79 : REAL*8 W2, PROPRE(LPROPR),PROPR2(LPROPR),XRVP, XIVP 80 : 81 : 82 : ***** ACTIVATIONS **************************************************** 83 : SEGACT ,IPLVER, IPLVAR, IPLVAI 84 : 85 : *-----initialisation 86 : NBNEG = 1 87 : NBPOS = 0 88 : 89 : 90 : ***** BOUCLE SUR LES MODES A ECRIRE ********************************** 91 : JVEC = 0 92 : * DO 100 IB100 = 1, NBMOD 93 : DO 100 IB100 = 1, NBMOD2 94 : 95 : JVEC = JVEC + 1 96 : 97 : *------ frequence propre 98 : XRVP = IPLVAR.PROG(JVEC) 99 : XIVP = IPLVAI.PROG(JVEC) 100 : PROPRE(1) = XRVP 101 : PROPRE(6) = XIVP 102 : 103 : *------ numero du mode (indicé selon lambda) 104 : * NUMOD2 = JVEC - NNBMOD 105 : XLAMBR = (DEUXPI**2) * ((XRVP**2) - (XIVP**2)) 106 : * WRITE(6,*) 'CRSOL1: mode',JVEC 107 : * WRITE(6,*) ' w=',XRVP,'+i',XIVP,'L=',XLAMBR,'W2=',W2 108 : if(XLAMBR .lt. W2) then 109 : NBNEG = NBNEG - 1 110 : NUMOD2 = NBNEG 111 : else 112 : NBPOS = NBPOS + 1 113 : NUMOD2 = NBPOS 114 : endif 115 : * write(6,*) 'NBNEG,NBPOS,NUMOD2=',NBNEG,NBPOS,NUMOD2 116 : 117 : *------ partie reelle du vecteur propre 118 : IPRX = IPLVER.ICHPOI(JVEC) 119 : 120 : *------ debut masse généralisée + eventuelle recup des mots utiles 120 : CALL MUCPRI ( IPRX, IPMASS, IPBXR ) 121 : IF (IB100 .EQ. 1) THEN 121 : CALL CORRSP(IPMASS, IPRX, IPBXR, IPLMOX, IPLMOY) 122 : END IF 122 : CALL XTY1(IPRX, IPBXR, IPLMOX, IPLMOY, XRBXR) 123 : IF (IERR .NE. 0 ) RETURN 124 : 125 : 126 : *------ Cas d'un mode Réel 127 : IF((XRVP .eq. 0.) .or. (XIVP .eq. 0.)) then 128 : * valeur propre w réelle pure ou imaginaire pure (car lambda réel pur) 129 : * vecteur propre reel = IPRX 130 : IPIX = 0 131 : * masse complexe généralisée 132 : PROPRE(2) = XRBXR 133 : PROPRE(7) = 0.D0 134 : C INTRODUCTION DES COEF. PI OU 2PI EVENTUELS + calcul DEPGEN 134 : * CALL MASGEN(XRVP,PROPRE) 134 : CALL DEPGEN(IPMASS, IPRX, PROPRE, IPBXR, IPLMOX,IPLMOY) 135 : 136 : * Ecriture dans MTAB3 du I^eme mode 136 : CALL CREBAS (PROPRE, IPRX, IPIX, IPKW2M, INF0, 137 : & NUMOD2, MTAB3, I) 138 : I = I+1 139 : 140 : 141 : *------ Cas d'un mode Complexe 142 : ELSE 143 : IPIX = IPLVER.ICHPOI(JVEC + 1) 144 : * valeur et vecteur propre complexe',IPIX 145 : * fin du calcul de la masse complexe généralisée 145 : CALL XTY1(IPIX, IPBXR, IPLMOX, IPLMOY, XIBXR) 145 : CALL MUCPRI(IPIX, IPMASS, IPBXI) 145 : CALL XTY1(IPRX, IPBXI, IPLMOX, IPLMOY, XRBXI) 145 : CALL XTY1(IPIX, IPBXI, IPLMOX, IPLMOY, XIBXI) 146 : PROPRE(2) = XRBXR - XIBXI 147 : PROPRE(7) = XIBXR + XRBXI 148 : * write(*,*)'masse gene complexe=',(PROPRE(2)),(PROPRE(7)) 149 : C INTRODUCTION DES COEF. PI OU 2PI EVENTUELS + calcul DEPGEN 149 : CALL DEPGEN(IPMASS, IPRX, PROPRE, IPBXR, IPLMOX,IPLMOY) 149 : CALL DEPGE2(IPMASS, IPRX,IPIX, PROPRE, IPBXR, IPLMOX,IPLMOY) 150 : * write(*,*)'* on decale JVEC...' 151 : JVEC = JVEC + 1 152 : if(XLAMBR .lt. W2) then 153 : NBNEG = NBNEG - 1 154 : else 155 : NBPOS = NBPOS + 1 156 : endif 157 : 158 : * Ecriture dans MTAB3 du I^eme mode 158 : CALL CREBAS (PROPRE, IPRX, IPIX, IPKW2M, INF0, 159 : & NUMOD2, MTAB3, I) 160 : I = I+1 161 : 162 : * Ecriture dans MTAB3 du I+1^eme mode (=conjugué du 1er) 163 : PROPR2(1) = IPLVAR.PROG(JVEC) 164 : PROPR2(6) = IPLVAI.PROG(JVEC) 165 : PROPR2(2) = -1.*PROPRE(2) 166 : PROPR2(7) = -1.*PROPRE(7) 166 : call MUCHPO(IPIX,-1.,IPIXCONJ,1) 166 : CALL CREBAS (PROPR2, IPRX, IPIXCONJ, IPKW2M, INF0, 167 : & NUMOD2, MTAB3, I) 168 : I = I+1 169 : 170 : 171 : ENDIF 172 : *-------fin de la distinction Mode reel/complexe 173 : 174 : 174 : CALL DTCHPO ( IPBXR ) 175 : if((XRVP .ne. 0.) .and. (XIVP .ne. 0.)) 175 : & CALL DTCHPO ( IPBXI ) 176 : 177 : 178 : IF ( IERR .NE. 0 ) RETURN 179 : 180 : if(JVEC .ge. NBMOD2) goto 900 181 : 182 : 100 CONTINUE 183 : 184 : 900 CONTINUE 185 : 186 : SEGDES ,IPLVER, IPLVAR, IPLVAI 187 : 188 : RETURN 189 : END 190 : 191 : 192 : 193 : 194 :
© Cast3M 2003 - All rights reserved.
Disclaimer