1 : C ELPDY2 SOURCE CHAT 05/01/12 23:37:27 5004 2 : SUBROUTINE ELPDY2 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-B,D-H,O-Z) 5 : IMPLICIT COMPLEX*16(C) 6 : ************************************************************************ 7 : * 8 : * 9 : * 10 : * ELFE PLAQUE LAPLACE ........... 11 : * ---- ------ ------- 12 : * 13 : * 14 : ************************************************************************ 15 : -INC CCREEL 16 : -INC SMELEME 17 : -INC SMCHPOI 18 : -INC SMTABLE 19 : -INC SMLREEL 20 : * 21 : * 22 : POINTEUR MLRE10.MLREEL 23 : SEGMENT SBORD 24 : REAL*8 XBORD(15,NS) 25 : INTEGER IBORD (2 ,NS) 26 : ENDSEGMENT 27 : SEGMENT SCOIN 28 : REAL*8 XCOIN(14,NCOIN) 29 : INTEGER ICOIN(4 ,NCOIN) 30 : ENDSEGMENT 31 : SEGMENT SPOST 32 : REAL*8 PP0(2,NP0) 33 : COMPLEX*16 CRP (NP0) 34 : COMPLEX*16 CPOST(NS4) 35 : ENDSEGMENT 36 : SEGMENT SMAT 37 : COMPLEX*16 CMA1(NS4,NS4) 38 : COMPLEX*16 CSM (NS4) 39 : COMPLEX*16 CSOM2 (NS) 40 : COMPLEX*16 CRE (NS4) 41 : ENDSEGMENT 42 : SEGMENT SMAT2 43 : COMPLEX*16 CMA2(NS4,NS4) 44 : COMPLEX*16 CSM2(NS4) 45 : ENDSEGMENT 46 : SEGMENT SMAI 47 : INTEGER IAUX(NS4) 48 : INTEGER IPIVO(NS4) 49 : INTEGER JPIVO(NS4) 50 : ENDSEGMENT 51 : * 52 : * 53 : * 54 : CHARACTER * (1) cAR0 55 : CHARACTER * 1 cAr1 56 : CHARACTER * 40 CHA1 57 : CHARACTER * 40 CHA2 58 : CHARACTER * 40 CHA3 59 : LOGICAL LOG0 60 : LOGICAL LOG1 61 : DIMENSION PF0(2) 62 : * 63 : * 64 : *--1. LECTURE 65 : * 66 : * ( on fixe ntrap ntrap2,iresou,isingu,iregu au lieu de les lire) 67 : * ( on garde les branchements car les choix de methode ne 68 : * sont pas definitifs) 68 : CALL LIROBJ('MAILLAGE',IPT1 ,1,IRET) 69 : IF (IRET.EQ.0) RETURN 70 : 70 : CALL LIRREE(XE1,1,IRET) 71 : IF (IRET.EQ.0) RETURN 71 : CALL LIRREE(XH1,1,IRET) 72 : IF (IRET.EQ.0) RETURN 72 : CALL LIRREE(XNU1,1,IRET) 73 : IF (IRET.EQ.0) RETURN 73 : CALL LIRREE(XRO1,1,IRET) 74 : IF (IRET.EQ.0) RETURN 74 : CALL LIROBJ('LISTREEL',MLRE10,1,IRET) 75 : IF (IRET.EQ.0) RETURN 76 : NTRap=5 77 : NTRap2=5 78 : *- COINS 78 : CALL LIROBJ('MAILLAGE',IPT2 ,0,IRET1) 79 : IF ( IRET1 .EQ. 1) THEN 80 : SEGACT IPT2 81 : NBELEM = IPT2.NUM(/2) 82 : NCOIN = NBELEM 83 : NC1 = Ncoin 84 : else 85 : NCOIN = 0 86 : NC1 = 0 87 : IPT2 = 0 88 : ENDIF 89 : 90 : *- C.L. 91 : 91 : CALL LIROBJ('MCHAML',MCHELM ,1,IRET) 92 : IF (IRET.EQ.0) RETURN 93 : 94 : *- FORCE PONCTUELLE 95 : 95 : CALL LIROBJ('POINT',IPF0,1,IRET) 96 : IF (IRET.EQ.0) RETURN 97 : XF0 = 1.D0 98 : *- POSTRAITEMENT 99 : 99 : CALL LIROBJ('POINT',IPP0,0,IRET1) 99 : CALL LIROBJ('MAILLAGE',IPT3,0,IRET2) 100 : IF ( IRET1 .EQ. 1) THEN 101 : NP0 = 1 102 : ENDIF 103 : IF ( IRET2 .EQ. 1) THEN 104 : SEGACT IPT3 105 : NP0 = IPT3.NUM(/2) 106 : ENDIF 107 : 108 : 109 : 110 : *- PARAMETRE LAPLACE 111 : 111 : CALL LIRREE(S0,1,IRET) 112 : IF (IRET.EQ.0) RETURN 112 : CALL LIROBJ('LISTREEL',MLREE1,1,IRET) 113 : IF (IRET.EQ.0) RETURN 114 : 115 : 116 : *- PARAMETREs methodes 117 : 118 : iresou=1 119 : isingu=1 120 : iregu=2 121 : 122 : * 123 : *--2. DIMENSIONNEMENT 124 : * 125 : SEGACT IPT1 126 : NBELEM = IPT1.NUM(/2) 127 : NS = NBELEM 128 : NS4= 4 * NBELEM 129 : SEGINI SBORD 130 : SEGINI SCOIN 131 : SEGINI SMAT 132 : SEGINI SMAT2 133 : SEGINI SMAI 134 : SEGINI SPOST 135 : SEGACT MLREE1 136 : JG = MLREE1.PROG(/1) 137 : SEGACT MLRE10 138 : SEGINI SPOST 139 : IF (NP0 .EQ.1) THEN 140 : SEGINI MLREE2 141 : SEGINI MLREE3 142 : ENDIF 143 : 144 : M=0 145 : SEGINI MTABLE 146 : iENT0 =0 147 : REE0 =0d0 148 : CAR0 =' ' 149 : CAR1 = ' ' 150 : LOG0 =.TRUE. 151 : LOG1 =.TRUE. 152 : IPoin0=0 153 : 154 : 155 : 156 : * 157 : *--3. CARACTERISTIQUES GEOMETRIQUES 158 : * 159 : CI = (0.D0,1.D0) 160 : XD = XE1* (XH1**3) / (12 * (1 - XNU1**2)) 161 : XNU = XNU1 162 : 162 : CALL ELPGEO (SBORD,SCOIN,SPOST,IPT1,IPT2,IPF0,PF0,IPP0,IPT3) 163 : * 164 : *--4. REMPLISSAGE DES TERMES C.L. 165 : * 165 : CALL ELPDM2 (SBORD,SMAT,MCHELM) 166 : * 167 : *--5. on commence par un calcul statique bidon indispensable 168 : ISTAT = 1 168 : CALL ELPDM1 (XBORD,IBORD,NS 169 : & ,XCOIN,ICOIN,NCOIN,NC1 170 : & ,CMA1,CSM,CSOM2,NS4 171 : & ,XD,XNU,NTRAP,NTRAP2,PF0,XF0,CB,ISTAT 172 : & ,isingu,iregu) 173 : DO 100 K1= 1,NS4 174 : DO 200 K2= 1,NS4 175 : CMA2(K1,K2) = CMA1(K1,K2) 176 : 200 CONTINUE 177 : CSM2(K1)= CSM(K1) 178 : CRE (K1)= 0D0 179 : 100 CONTINUE 180 : * 181 : IF ( Iresou .EQ. 0 ) THEN 181 : CALL ELPDRE (CMA2,CSM2 , CRE , IAUX , NS4 ) 182 : ELSE 182 : CALL ELPDR1 (CMA2,CSM2 , CRE , NS4 ,IPIVO,JPIVO, IAUX ) 183 : ENDIF 184 : * 185 : *--5. BOUCLE SUR LES FREQUENCES DEMANDEES PAR L' UTILISATEUR 186 : * 187 : DO 1000 I = 1,JG 188 : xcam = mlre10.prog(i) 189 : CS1 = S0 + CI*MLREE1.PROG(I) 190 : CB =( (-1*(xcam*cs1 + XRO1*XH1*CS1*CS1)) 191 : & /XD )**.25D0 192 : IF (MLREE1.PROG(I) .LT . 1E-10) THEN 193 : ISTAT = 1 194 : ELSE 195 : ISTAT = 0 196 : ENDIF 196 : CALL ELPDM1 (XBORD,IBORD,NS 197 : & ,XCOIN,ICOIN,NCOIN,NC1 198 : & ,CMA1,CSM,CSOM2,NS4 199 : & ,XD,XNU,NTRAP,NTRAP2,PF0,XF0,CB,ISTAT 200 : & ,isingu,iregu) 201 : DO 1100 K1= 1,NS4 202 : DO 1200 K2= 1,NS4 203 : CMA2(K1,K2) = CMA1(K1,K2) 204 : 1200 CONTINUE 205 : CSM2(K1)= CSM(K1) 206 : CRE (K1)= 0D0 207 : 1100 CONTINUE 208 : * 209 : IF ( Iresou .EQ. 0 ) THEN 209 : CALL ELPDRE (CMA2,CSM2 , CRE , IAUX , NS4 ) 210 : ELSE 211 : IF ( I .EQ. 1 ) THEN 211 : CALL ELPDR1 (CMA2,CSM2 , CRE , NS4 ,IPIVO,JPIVO, IAUX ) 212 : ELSE 212 : CALL ELPDR2 (CMA2,CSM2 , CRE , NS4 ,IPIVO,JPIVO, IAUX ) 213 : ENDIF 214 : ENDIF 215 : C 216 : c post-traitement 217 : c 217 : CALL ELPD99 (XBORD,IBORD,NS 218 : & ,XCOIN,ICOIN,NCOIN,NC1 219 : & ,CRE,CPOST,CRP,NS4 220 : & ,XD,XNU,NTRAP,PF0,XF0,PP0,NP0,CB,ISTAT) 221 : 222 : IF ( NP0 .EQ. 1) THEN 223 : CCP = CRP(1) 224 : XX = ABS (CCP) 225 : XR = CCP 226 : XI = -1*CI*(CCP - XR) 227 : XT = ATAN2(XI,XR)*180.D0/XPI 228 : MLREE2.PROG(I) = XX 229 : MLREE3.PROG(I) = XT 230 : ELSE 231 : N = NP0 232 : NC= 2 233 : NSOUPO = 1 234 : SEGINI MPOVAL 235 : SEGINI MSOUPO 236 : IPOVAL = MPOVAL 237 : IGEOC = IPT3 238 : NOCOMP(1) = 'MODU' 239 : NOCOMP(2) = 'PHAS' 240 : NOHARM(1) = 0 241 : NOHARM(2) = 0 242 : NAT=1 243 : SEGINI MCHPOI 244 : MTYPOI = ' CREE PAR ELFE ' 245 : MOCHDE = ' ELFE ' 246 : IPCHP (1) = MSOUPO 247 : * MODU et PHAS sont des chpo diffus 248 : JATTRI(1) = 1 249 : IFOPOI = 0 250 : DO 1110 IP =1,NP0 251 : 252 : CCP = CRP(IP) 253 : XX = ABS (CCP) 254 : XR = CCP 255 : XI = -1*CI*(CCP - XR) 256 : XT = ATAN2(XI,XR)*180.D0/XPI 257 : VPOCHA (IP,1) = XX 258 : VPOCHA (IP,2) = XT 259 : 1110 CONTINUE 259 : CALL ECCTAB(MTABLE,'ENTIER ',I ,REE0,CAR0,LOG0,Ipoin0, 260 : & 'CHPOINT ',iENT0,REE1,CAR1,LOG1,MCHPOI) 261 : ENDIF 262 : 263 : 264 : 1000 CONTINUE 265 : * 266 : IF ( NP0 .EQ. 1) THEN 266 : CALL ECCTAB(MTABLE,'ENTIER ',1 ,REE0,CAR0,LOG0,IPOIN0, 267 : & 'LISTREEL',ient0,ree1,car1,log1,mlree2) 267 : CALL ECCTAB(MTABLE,'ENTIER ',2 ,REE0,CAR0,LOG0,IPOIN0, 268 : & 'LISTREEL',ient0,ree1,car1,log1,mlree3) 269 : ENDIF 269 : CALL ECROBJ('TABLE',MTABLE) 270 : * 271 : SEGDES MTABLE 272 : SEGDES MLREE1 273 : 274 : * 275 : SEGSUP SBORD 276 : SEGSUP SCOIN 277 : SEGSUP SMAT 278 : SEGSUP SMAT2 279 : SEGSUP SMAI 280 : SEGSUP SPOST 281 : * 282 : RETURN 283 : END 284 : 285 : 286 : 287 : 288 : 289 :
© Cast3M 2003 - All rights reserved.
Disclaimer