1 : C PRDOMI SOURCE AF221230 13/08/01 21:15:08 7808 2 : C PRDOMI SOURCE 3 : SUBROUTINE PRDOMI(CALDYN,NMIS,NOMETU,LE,MTAB1) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : C 7 : C======================================================================= 8 : C POUR MISS3D : ECRITURE DU FICHIERS DE DONNEES MISS.IN 9 : C 10 : C Appelle par l'operateur MISE 11 : C======================================================================= 12 : C 13 : -INC SMTABLE 14 : -INC CCOPTIO 15 : CHARACTER*72 lemot 16 : CHARACTER*20 NOMETU 17 : LOGICAL CALDYN 18 : CHARACTER*105 FICMISS,NFSOL 19 : CHARACTER*8 TYPRET 20 : CHARACTER*13 TYPFOND 21 : LOGICAL LOGI,FISOL,SEISX,SEISY,SEISZ,VSVP,ECH,RECE,SOUR 22 : C 23 : SEGMENT WCOUP 24 : REAL*8 ZCOUP(NCOUP) 25 : INTEGER JTYPC(NCOUP) 26 : ENDSEGMENT 27 : SEGMENT WCOUCH 28 : REAL*8 EPC(NCOUCH) 29 : INTEGER KMAT(NCOUCH) 30 : LOGICAL AVECR(NCOUCH) 31 : ENDSEGMENT 32 : SEGMENT WSOUR 33 : INTEGER COUSOU(NSOUR) 34 : ENDSEGMENT 35 : C 36 : FICMISS=NOMETU(1:LE)//'.mail' 37 : C 38 : C ecriture debut fichier MISS.IN 39 : C 40 : WRITE(NMIS,501)NOMETU,FICMISS 41 : 501 FORMAT('GENER ',A20,/,'*',/,'DATA',/,'*',/,'TITRE',/, 42 : & 'Chainage Castem Miss',/,'*',/,'MAILLAGE ',A25,/,'*') 43 : IF(CALDYN)THEN 44 : IG=2 45 : WRITE(NMIS,502)IG 46 : 502 FORMAT('GROUPE',/,I1,' VOLUme',/,'FIN',/,'FING',/,'*') 47 : ENDIF 48 : FICMISS=NOMETU(1:LE)//'.chp' 49 : WRITE(NMIS,503)FICMISS 50 : 503 FORMAT('INTEGRATION TRIANGLE 10 12 RECTANGLE 6 10',/,'*',/, 51 : & 'CHAMP',/,'LIRE ',A25,/,'FINC',/,'*',/,'VERIF',/,'*') 52 : TYPRET=' ' 53 : C 54 : C Ecriture plage de Frequence et definitions des domaines 55 : C 55 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FREQ_SOL_MIN',.TRUE.,0, 56 : & TYPRET,IP,FMIN,lemot,LOGI,IZ) 56 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FREQ_SOL_MAX',.TRUE.,0, 57 : & TYPRET,IP,FMAX,lemot,LOGI,IZ) 57 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FREQ_SOL_PAS',.TRUE.,0, 58 : & TYPRET,IP,FPAS,lemot,LOGI,IZ) 59 : WRITE(NMIS,504)FMIN,FMAX,FPAS 60 : 504 FORMAT('FREQ DE ',F5.2,' A ',F5.2,' PAS ',F5.2,/,'*') 61 : WRITE(NMIS,505) 62 : 505 FORMAT('SDOM 1 GROUP 1',/,'STRA',/,'FINS',/,'*') 63 : IF(CALDYN)THEN 64 : WRITE(NMIS,506) 65 : 506 FORMAT('SDOM 2 GROUP -1 2',/,'KCM',/,'FINS',/,'*') 66 : ENDIF 67 : WRITE(NMIS,507) 68 : 507 FORMAT('FIND',/,'*') 69 : C 70 : C Definition domaine structure dans le cas d'un calcul ISS 71 : C 72 : IF(CALDYN)THEN 73 : FICMISS=NOMETU(1:LE)//'.imp' 74 : WRITE(NMIS,508)FICMISS 75 : 508 FORMAT('DOMAINE 2',/,'EXTE',/,'LIRE ',A25,/,'FINE',/,'*') 76 : ENDIF 77 : C 78 : C Definition du sol dans le fichier MISS.IN 79 : C 80 : WRITE(NMIS,509) 81 : 509 FORMAT('DOMAINE 1') 82 : C 83 : C Si sol dans un fichier au format MISS 83 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FICHIER_SOL',.TRUE.,0, 84 : & 'MOT',IP,RR,NFSOL,LOGI,IZ) 85 : IF(NFSOL(1:5).EQ.'NEANT')THEN 86 : FISOL=.FALSE. 87 : ELSE 88 : FISOL=.TRUE. 89 : ENDIF 90 : C 91 : C calcul nombre de materiaux 92 : IF(.NOT.FISOL)THEN 92 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'CARA_SOL',.TRUE.,0, 93 : & 'TABLE',IP,RR,lemot,LOGI,MTABCS) 94 : MTABLE=MTABCS 95 : SEGACT MTABLE 96 : NMAT=MLOTAB-1 97 : SEGDES MTABLE 98 : ENDIF 99 : C 100 : C type de fondation 100 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'TYPE_FONDATION',.TRUE.,0, 101 : & 'MOT',IP,RR,TYPFOND,LOGI,IZ) 102 : 102 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'SURFACE_LIBRE',.TRUE.,0, 103 : & 'FLOTTANT',IP,Z0,lemot,LOGI,IZ) 104 : C 105 : C Fondations superficielles (source et recepteur � la surface) 106 : IF(TYPFOND.EQ.'SUPERFICIELLE')THEN 107 : WRITE(NMIS,511)Z0,'SURF' 108 : ELSE 109 : WRITE(NMIS,511)Z0 110 : ENDIF 111 : 511 FORMAT('DOS2M Z0 ',F5.2,1X,A4) 112 : C 113 : C Definition des materiaux 114 : IF(FISOL)THEN 115 : WRITE(NMIS,499)NFSOL 116 : 499 FORMAT('LIRE ',A80) 117 : ELSE 118 : WRITE(NMIS,512)NMAT 119 : C 512 FORMAT('GENER ugtg',/,'TITRE',/, 120 : C & 'Demi espace multi couches',/,'*',/,'MATE ',I3) 121 : 512 FORMAT('TITRE',/, 122 : & 'Demi espace multi couches',/,'*',/,'MATE ',I3) 123 : 123 : CALL ACCTAB(MTABCS,'MOT',0,0.0D0,'VSVP',.TRUE.,0, 124 : & 'LOGIQUE',IP,RR,lemot,VSVP,IZ) 125 : IF (VSVP)THEN 126 : WRITE(NMIS,5123) 127 : ELSE 128 : WRITE(NMIS,5124) 129 : ENDIF 130 : 5123 FORMAT('RO VS VP BETA') 131 : 5124 FORMAT('RO E NU BETA') 132 : pmin=0. 133 : pmax=0. 134 : cpmax=0. 135 : csmin=100000000. 136 : betam=10. 137 : DO 30 IC=1,NMAT 137 : CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, 138 : & 'TABLE',IP,RR,lemot,LOGI,MTABCI) 138 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'RO',.TRUE.,0, 139 : & 'FLOTTANT',IP,RO,lemot,LOGI,IZ) 139 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'BETA',.TRUE.,0, 140 : & 'FLOTTANT',IP,BETA,lemot,LOGI,IZ) 141 : IF(betam.GT.BETA)betam=BETA 142 : IF(VSVP)THEN 142 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VS',.TRUE.,0, 143 : & 'FLOTTANT',IP,VS,lemot,LOGI,IZ) 143 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VP',.TRUE.,0, 144 : & 'FLOTTANT',IP,VP,lemot,LOGI,IZ) 145 : WRITE(NMIS,5125)RO,VS,VP,BETA 146 : cp=VP 147 : cs=VS 148 : ELSE 148 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'E',.TRUE.,0, 149 : & 'FLOTTANT',IP,ZE,lemot,LOGI,IZ) 149 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'NU',.TRUE.,0, 150 : & 'FLOTTANT',IP,ZNU,lemot,LOGI,IZ) 151 : WRITE(NMIS,5125)RO,ZE,ZNU,BETA 152 : lamda=(ZE*ZNU)/((1+ZNU)*(1-2*ZNU)) 153 : zmu=ZE/(2*(1+ZNU)) 154 : cp=((lamda+2*zmu)/RO)**0.5 155 : cs=(zmu/RO)**0.5 156 : ENDIF 157 : IF((cpmax-cp).LT.0.00001)cpmax=cp 158 : 159 : IF((csmin-cs).GT.0.00001)csmin=cs 160 : 5125 FORMAT(4(E12.6,1X)) 161 : 30 CONTINUE 162 : pmin=1/cpmax 163 : pmax=1/csmin 164 : C 165 : dp=betam*pmin 166 : c dp=0.1*betam*pmin 167 : C 168 : pmax=8*pmax 169 : np=1+int(pmax/dp) 170 : C 171 : C couches et recepteurs 172 : IF(TYPFOND.EQ.'SUPERFICIELLE')THEN 173 : WRITE(NMIS,513)NMAT 174 : 513 FORMAT('*',/,'COUCHES ',I3) 175 : C DO 40 IC=1,NMAT-1 176 : DO 40 IC=1,NMAT 177 : C 177 : CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, 178 : & 'TABLE',IP,RR,lemot,LOGI,MTABCI) 178 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, 179 : & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) 180 : IF(IC.EQ.1)THEN 181 : IF (EPAI.GT.(0.1E+10)) THEN 182 : EPAI=1. 183 : WRITE(NMIS,515)EPAI,IC 184 : ELSE; 185 : WRITE(NMIS,515)EPAI,IC 186 : ENDIF; 187 : ELSE 188 : IF (EPAI.GT.(0.1E+10)) THEN 189 : EPAI=1. 190 : WRITE(NMIS,514)EPAI,IC 191 : ELSE; 192 : WRITE(NMIS,514)EPAI,IC 193 : ENDIF; 194 : ENDIF 195 : WRITE(IOIMP,*) ' ' 196 : write(6,714) IC 197 : 714 FORMAT('********************* Materiaux ',I2, 198 : & ' *********************') 198 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'RO',.TRUE.,0, 199 : & 'FLOTTANT',IP,RO,lemot,LOGI,IZ) 199 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'BETA',.TRUE.,0, 200 : & 'FLOTTANT',IP,BETA,lemot,LOGI,IZ) 201 : IF(VSVP)THEN 201 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VS',.TRUE.,0, 202 : & 'FLOTTANT',IP,VS,lemot,LOGI,IZ) 202 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VP',.TRUE.,0, 203 : & 'FLOTTANT',IP,VP,lemot,LOGI,IZ) 204 : WRITE(IOIMP,715)RO,VS,VP,BETA 205 : ELSE 205 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'E',.TRUE.,0, 206 : & 'FLOTTANT',IP,ZE,lemot,LOGI,IZ) 206 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'NU',.TRUE.,0, 207 : & 'FLOTTANT',IP,ZNU,lemot,LOGI,IZ) 208 : WRITE(IOIMP,716)RO,ZE,ZNU,BETA 209 : ENDIF 210 : 715 FORMAT('RO ',F7.2,' VS ',F7.2, 211 : & ' VP ',F7.2,' BETA ',F5.3) 212 : 716 FORMAT('RO ',F7.2,' E ',E10.3, 213 : & ' NU ',F5.3,' BETA ',F5.3) 213 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, 214 : & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) 215 : IF (IC.EQ.1) THEN 216 : ZC0 = Z0; 217 : ZC1 = ZC0-EPAI; 218 : ELSE 219 : ZC0 = ZC1; 220 : ZC1 = ZC1-EPAI; 221 : ENDIF 222 : WRITE(IOIMP,*) ' ' 223 : WRITE(IOIMP,717) ZC0 224 : WRITE(IOIMP,718) ZC1 225 : 717 FORMAT('Cote Initiale ',F8.3) 226 : 718 FORMAT('Cote finale ',F8.3) 227 : IF (IC.EQ.1) THEN 228 : WRITE(IOIMP,*) ' ' 229 : WRITE(IOIMP,*) 'Position recepteurs dans la couche' 230 : WRITE(IOIMP,719) Z0 231 : 719 FORMAT('z ',F8.3) 232 : ELSE 233 : WRITE(IOIMP,*) ' ' 234 : WRITE(IOIMP,*) 'Position recepteurs dans la couche' 235 : WRITE(IOIMP,*) ' Aucun recepteur dans la couche' 236 : ENDIF 237 : 514 FORMAT(E12.6,' MATE ',I4) 238 : 515 FORMAT(E12.6,' MATE ',I4,' RECEP') 239 : 40 CONTINUE 240 : WRITE(NMIS,516)NMAT 241 : 516 FORMAT('SUBS MATE ',I4) 242 : 520 FORMAT('SUBS MATE ',I4,' RECEP') 243 : WRITE(IOIMP,*) ' ' 244 : WRITE(IOIMP,*) 'Definition des couches ', 245 : & 'sur fichier MISS.IN' 246 : WRITE(IOIMP,*) ' ' 247 : WRITE(IOIMP,*) 'Nombre total couches', NMAT 248 : WRITE(IOIMP,*) ' ' 249 : DO 720 IC=1,NMAT 249 : CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, 250 : & 'TABLE',IP,RR,lemot,LOGI,MTABCI) 250 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, 251 : & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) 252 : IF (IC.EQ.1) THEN 253 : IF (EPAI.GT.(0.1E+10)) THEN 254 : EPAI=1. 255 : ENDIF 256 : WRITE(IOIMP,721) IC,EPAI,IC,IC 257 : ELSE 258 : IF (EPAI.GT.(0.1E+10)) THEN 259 : EPAI=1. 260 : ENDIF 261 : WRITE(IOIMP,722) IC,EPAI,IC,IC 262 : ENDIF 263 : 720 CONTINUE 264 : 721 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, 265 : & ' Recep OUI Sources OUI',' COUCHE ',I3) 266 : 722 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, 267 : & ' Recep NON Sources NON',' COUCHE ',I3) 268 : WRITE(IOIMP,723) NMAT 269 : 723 FORMAT('Subs Materiau ',I2, 270 : & ' Recep NON Sources NON') 271 : C 272 : C sources et algo 273 : I=1 274 : WRITE(NMIS,517)I 275 : 517 FORMAT('SOURCE ',I4,' 3D') 276 : WRITE(NMIS,518)I 277 : 518 FORMAT('FORCE HORI POSI ',I4) 278 : WRITE(NMIS,519) 279 : 519 FORMAT('*',/,'ALGO DEPL') 280 : ELSEIF(TYPFOND.EQ.'PROFONDE')THEN 281 : C Fondations profondes (calculer le nombre de couches, de sources et de recepteurs) 281 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'RECEPTEURS',.TRUE.,0, 282 : & 'TABLE',IP,RR,lemot,LOGI,MTABRE) 283 : MTABLE=MTABRE 284 : SEGACT MTABLE 285 : NR=MLOTAB 286 : SEGDES MTABLE 286 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'SOURCES',.TRUE.,0, 287 : & 'TABLE',IP,RR,lemot,LOGI,MTABSO) 288 : MTABLE=MTABSO 289 : SEGACT MTABLE 290 : NS=MLOTAB 291 : SEGDES MTABLE 292 : C 293 : c on dimensionne large 294 : NCOUCH=NMAT+NR+NS 295 : SEGINI WCOUCH 296 : NCOUP=NR+NS 297 : SEGINI WCOUP 298 : NSOUR=NS 299 : SEGINI WSOUR 300 : 301 : ZC0=Z0 302 : JSOUR=0 303 : NEWCOU=0 304 : DO 61 IC=1,NMAT 305 : write(6,*) ' ' 306 : write(6,700) IC 307 : 700 FORMAT('********************* Materiaux ',I2, 308 : & ' *********************') 309 : NEWCOU=NEWCOU+1 309 : CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, 310 : & 'TABLE',IP,RR,lemot,LOGI,MTABCI) 310 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, 311 : & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) 312 : ZC1=ZC0-EPAI 312 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'RO',.TRUE.,0, 313 : & 'FLOTTANT',IP,RO,lemot,LOGI,IZ) 313 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'BETA',.TRUE.,0, 314 : & 'FLOTTANT',IP,BETA,lemot,LOGI,IZ) 315 : IF(VSVP)THEN 315 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VS',.TRUE.,0, 316 : & 'FLOTTANT',IP,VS,lemot,LOGI,IZ) 316 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VP',.TRUE.,0, 317 : & 'FLOTTANT',IP,VP,lemot,LOGI,IZ) 318 : WRITE(IOIMP,704)RO,VS,VP,BETA 319 : ELSE 319 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'E',.TRUE.,0, 320 : & 'FLOTTANT',IP,ZE,lemot,LOGI,IZ) 320 : CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'NU',.TRUE.,0, 321 : & 'FLOTTANT',IP,ZNU,lemot,LOGI,IZ) 322 : WRITE(IOIMP,705)RO,ZE,ZNU,BETA 323 : ENDIF 324 : 704 FORMAT('RO ',F7.2,' VS ',F7.2, 325 : & ' VP ',F7.2,' BETA ',F5.3) 326 : 705 FORMAT('RO ',F7.2,' E ',E10.3, 327 : & ' NU ',F5.3,' BETA ',F5.3) 328 : KCOUP=0 329 : RECE=.FALSE. 330 : SOUR=.FALSE. 331 : WRITE(IOIMP,*) ' ' 332 : WRITE(IOIMP,701) ZC0 333 : WRITE(IOIMP,702) ZC1 334 : 701 FORMAT('Cote Initiale ',F8.3) 335 : 702 FORMAT('Cote finale ',F8.3) 336 : DO 62 IR=1,NR 336 : CALL ACCTAB(MTABRE,'ENTIER',IR,0.0D0,' ',.TRUE.,0, 337 : & 'FLOTTANT',IP,ZR,lemot,LOGI,IZ) 338 : IF(ABS(ZR-ZC0).LE.0.001)THEN 339 : RECE=.TRUE. 340 : ELSEIF((ZR-ZC1).GT.0.001.AND.ZR.LT.ZC0)THEN 341 : KCOUP=KCOUP+1 342 : ZCOUP(KCOUP)=ZR 343 : JTYPC(KCOUP)=1 344 : ENDIF 345 : 62 CONTINUE 346 : DO 64 IS=1,NS 346 : CALL ACCTAB(MTABSO,'ENTIER',IS,0.0D0,' ',.TRUE.,0, 347 : & 'FLOTTANT',IP,ZS,lemot,LOGI,IZ) 348 : IF(ABS(ZS-ZC0).LE.0.001)THEN 349 : SOUR=.TRUE. 350 : ELSEIF((ZS-ZC1).GT.0.001.AND.ZS.LT.ZC0)THEN 351 : KCOUP=KCOUP+1 352 : ZCOUP(KCOUP)=ZS 353 : JTYPC(KCOUP)=2 354 : ENDIF 355 : 64 CONTINUE 356 : WRITE(IOIMP,*) ' ' 357 : WRITE(IOIMP,*) 'Position recepteurs dans la couche' 358 : IF (RECE) THEN 359 : WRITE(IOIMP,703) ZC0 360 : ENDIF; 361 : DO 601 I1=1,KCOUP; 362 : IF (JTYPC(I1).EQ.1) THEN 363 : WRITE(IOIMP,703) ZCOUP(I1) 364 : ENDIF 365 : 601 CONTINUE 366 : WRITE(IOIMP,*) ' ' 367 : WRITE(IOIMP,*) 'Position sources dans la couche' 368 : IF (SOUR) THEN 369 : WRITE(IOIMP,703) ZC0 370 : ENDIF; 371 : DO 602 I1=1,KCOUP; 372 : IF (JTYPC(I1).EQ.2) THEN 373 : WRITE(IOIMP,703) ZCOUP(I1) 374 : ENDIF 375 : 602 CONTINUE 376 : 703 FORMAT('z ',F8.3) 377 : IF(KCOUP.GE.2)THEN 378 : IFIN=KCOUP-1 379 : 66 CONTINUE 380 : ECH=.FALSE. 381 : DO 67 ICOUP=1,IFIN 382 : IF(ZCOUP(ICOUP).LT.ZCOUP(ICOUP+1))THEN 383 : ZPROV=ZCOUP(ICOUP) 384 : JPROV=JTYPC(ICOUP) 385 : ZCOUP(ICOUP)=ZCOUP(ICOUP+1) 386 : JTYPC(ICOUP)=JTYPC(ICOUP+1) 387 : ZCOUP(ICOUP+1)=ZPROV 388 : JTYPC(ICOUP+1)=JPROV 389 : ECH=.TRUE. 390 : ENDIF 391 : 67 CONTINUE 392 : IF(ECH)THEN 393 : IFIN=IFIN-1 394 : IF(IFIN.GE.1)GOTO 66 395 : ENDIF 396 : DO 69 ICOUP=1,KCOUP 397 : IF(ABS(ZCOUP(ICOUP)-ZCOUP(ICOUP+1)).LT.0.001.AND. 398 : & ZCOUP(ICOUP).NE.1.D9)THEN 399 : c IF(ABS(ZCOUP(ICOUP)-ZCOUP(ICOUP+1)).LT.0.001)THEN 400 : C write(6,*) 'ICOUP=',ICOUP,'ZCOUP(ICOUP) =',ZCOUP(ICOUP), 401 : C & 'ZCOUP(ICOUP+1) =',ZCOUP(ICOUP+1) 402 : DO 68 I1=ICOUP,KCOUP-1 403 : C write(6,*) 'I1 =', I1,'ZCOUP(I1) =',ZCOUP(I1), 404 : C & 'ZCOUP(I1+1) =',ZCOUP(I1+1) 405 : ZCOUP(I1)=ZCOUP(I1+1) 406 : JTYPC(I1)=JTYPC(I1+1) 407 : 68 CONTINUE 408 : JTYPC(ICOUP)=12 409 : ZCOUP(KCOUP)=1.D9 410 : KCOUP=KCOUP-1 411 : ENDIF 412 : 69 CONTINUE 413 : C 414 : C Preparation Ecriture 415 : EPC(NEWCOU)=ZC0-ZCOUP(1) 416 : AVECR(NEWCOU)=.FALSE. 417 : IF(RECE)AVECR(NEWCOU)=.TRUE. 418 : KMAT(NEWCOU)=IC 419 : IF(SOUR)THEN 420 : JSOUR=JSOUR+1 421 : COUSOU(JSOUR)=NEWCOU 422 : ENDIF 423 : DO 70 ICOUP=1,KCOUP-1 424 : NEWCOU=NEWCOU+1 425 : EPC(NEWCOU)=ZCOUP(ICOUP)-ZCOUP(ICOUP+1) 426 : AVECR(NEWCOU)=.FALSE. 427 : IF(JTYPC(ICOUP).EQ.1.OR.JTYPC(ICOUP).EQ.12) 428 : & AVECR(NEWCOU)=.TRUE. 429 : KMAT(NEWCOU)=IC 430 : IF(JTYPC(ICOUP).EQ.2.OR.JTYPC(ICOUP).EQ.12)THEN 431 : JSOUR=JSOUR+1 432 : COUSOU(JSOUR)=NEWCOU 433 : ENDIF 434 : 70 CONTINUE 435 : NEWCOU=NEWCOU+1 436 : EPC(NEWCOU)=ZCOUP(KCOUP)-ZC1 437 : AVECR(NEWCOU)=.FALSE. 438 : IF(JTYPC(KCOUP).EQ.1.OR.JTYPC(KCOUP).EQ.12) 439 : & AVECR(NEWCOU)=.TRUE. 440 : KMAT(NEWCOU)=IC 441 : IF(JTYPC(KCOUP).EQ.2.OR.JTYPC(KCOUP).EQ.12)THEN 442 : JSOUR=JSOUR+1 443 : COUSOU(JSOUR)=NEWCOU 444 : ENDIF 445 : ELSEIF(KCOUP.EQ.1)THEN 446 : EPC(NEWCOU)=ZC0-ZCOUP(KCOUP) 447 : AVECR(NEWCOU)=.FALSE. 448 : IF(RECE)AVECR(NEWCOU)=.TRUE. 449 : KMAT(NEWCOU)=IC 450 : IF(SOUR)THEN 451 : JSOUR=JSOUR+1 452 : COUSOU(JSOUR)=NEWCOU 453 : ENDIF 454 : NEWCOU=NEWCOU+1 455 : EPC(NEWCOU)=ZCOUP(KCOUP)-ZC1 456 : AVECR(NEWCOU)=.FALSE. 457 : IF(JTYPC(KCOUP).EQ.1.OR.JTYPC(KCOUP).EQ.12) 458 : & AVECR(NEWCOU)=.TRUE. 459 : KMAT(NEWCOU)=IC 460 : IF(JTYPC(KCOUP).EQ.2.OR.JTYPC(KCOUP).EQ.12)THEN 461 : JSOUR=JSOUR+1 462 : COUSOU(JSOUR)=NEWCOU 463 : ENDIF 464 : ELSE 465 : EPC(NEWCOU)=ZC0-ZC1 466 : AVECR(NEWCOU)=.FALSE. 467 : IF(RECE)AVECR(NEWCOU)=.TRUE. 468 : KMAT(NEWCOU)=IC 469 : IF(SOUR)THEN 470 : JSOUR=JSOUR+1 471 : COUSOU(JSOUR)=NEWCOU 472 : ENDIF 473 : ENDIF 474 : ZC0=ZC1 475 : 61 CONTINUE 476 : c 477 : WRITE(IOIMP,*) ' ' 478 : WRITE(IOIMP,*) 'Definition des couches', 479 : & 'sur fichier MISS.IN' 480 : WRITE(IOIMP,*) ' ' 481 : WRITE(IOIMP,*) 'Nombre total couches', (NEWCOU-1) 482 : WRITE(IOIMP,*) ' ' 483 : I2 = 1; 484 : DO 603 I1=1,NEWCOU-1 485 : IF (I1.EQ.(COUSOU(I2))) THEN 486 : IF (AVECR(I1)) THEN 487 : WRITE(IOIMP,709) I1,EPC(I1),KMAT(I1),I1 488 : ELSE 489 : WRITE(IOIMP,708) I1,EPC(I1),KMAT(I1),I1 490 : ENDIF 491 : I2 = I2 + 1 492 : ELSE 493 : IF (AVECR(I1)) THEN 494 : WRITE(IOIMP,707) I1,EPC(I1),KMAT(I1),I1 495 : ELSE 496 : WRITE(IOIMP,706) I1,EPC(I1),KMAT(I1),I1 497 : ENDIF 498 : ENDIF 499 : 603 CONTINUE 500 : IF (AVECR(NEWCOU)) THEN 501 : IF (I1.EQ.(COUSOU(I2))) THEN 502 : WRITE(IOIMP,713) KMAT(NEWCOU) 503 : ELSE 504 : WRITE(IOIMP,711) KMAT(NEWCOU) 505 : ENDIF 506 : ELSE 507 : IF (I1.EQ.(COUSOU(I2))) THEN 508 : WRITE(IOIMP,712) KMAT(NEWCOU) 509 : ELSE 510 : WRITE(IOIMP,710) KMAT(NEWCOU) 511 : ENDIF 512 : ENDIF 513 : 706 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, 514 : & ' Recep NON Sources NON',' COUCHE ',I3) 515 : 707 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, 516 : & ' Recep OUI Sources NON',' COUCHE ',I3) 517 : 708 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, 518 : & ' Recep NON Sources OUI',' COUCHE ',I3) 519 : 709 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, 520 : & ' Recep OUI Sources OUI',' COUCHE ',I3) 521 : 710 FORMAT('Subs Materiau ',I2, 522 : & ' Recep NON Sources NON') 523 : 711 FORMAT('Subs Materiau ',I2, 524 : & ' Recep OUI Sources NON') 525 : 712 FORMAT('Subs Materiau ',I2, 526 : & ' Recep NON Sources OUI') 527 : 713 FORMAT('Subs Materiau ',I2, 528 : & ' Recep OUI Sources OUI') 529 : C 530 : C Ecritures couches et sources plus algorithme 531 : C 532 : WRITE(NMIS,525)NEWCOU-1 533 : 525 FORMAT('COUCHES ',I4) 534 : DO 72 IC=1,NEWCOU-1 535 : IF(AVECR(IC))THEN 536 : WRITE(NMIS,515)EPC(IC),KMAT(IC) 537 : ELSE 538 : WRITE(NMIS,514)EPC(IC),KMAT(IC) 539 : ENDIF 540 : 72 CONTINUE 541 : IF (AVECR(NEWCOU)) THEN 542 : WRITE(NMIS,520)KMAT(NEWCOU) 543 : ELSE 544 : WRITE(NMIS,516)KMAT(NEWCOU) 545 : ENDIF 546 : WRITE(NMIS,517)JSOUR 547 : C 548 : DO 74 IS=1,JSOUR 549 : WRITE(NMIS,518)COUSOU(IS) 550 : 74 CONTINUE 551 : WRITE(NMIS,521) 552 : 521 FORMAT('ALGO REGU') 553 : 554 : SEGDES WCOUP 555 : SEGDES WSOUR 556 : SEGDES WCOUCH 557 : ENDIF 558 : C 559 : C Echantillonnage spectral 560 : C 561 : if(np.LT.2048)then 562 : np=2048 563 : elseif(np.LT.4096)then 564 : np=4096 565 : elseif(np.LT.6144)then 566 : np=6144 567 : elseif(np.LT.8192) then 568 : np=8192 569 : elseif(np.LT.10240) then 570 : np=10240 571 : elseif(np.LT.12288) then 572 : np=12288 573 : elseif(np.LT.14336) then 574 : np=14336 575 : endif 576 : WRITE(NMIS,530)pmax,np 577 : 530 FORMAT('SPEC',' ',E12.6,' ',' / ',I5) 578 : C 579 : C Echantillonnage spatial 580 : C 580 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'ECHANT_NP',.TRUE.,0, 581 : & 'ENTIER',NPECH,RR,lemot,LOGI,IZ) 581 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'ECHANT_DR',.TRUE.,0, 582 : & 'FLOTTANT',IP,DRECH,lemot,LOGI,IZ) 583 : 584 : WRITE(NMIS,535)NPECH,DRECH 585 : 535 FORMAT('OFFSET ',I5,' * ',E12.6) 586 : WRITE(NMIS,545) 587 : 545 FORMAT('DREF 0.0001',/,'FIND',/,'*') 588 : c------ modif 20110803_calcul pmin,pmax 589 : ENDIF 590 : C 591 : C chargement sismique 592 : C 593 : IF(CALDYN)THEN 594 : IS=0 594 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DIR_CHARGEMENT',.TRUE.,0, 595 : & 'TABLE',IP,RR,lemot,LOGI,MTAB2) 595 : CALL ACCTAB(MTAB2,'MOT',0,0.0D0,'DIR_X',.TRUE.,0, 596 : & 'LOGIQUE',IP,RR,lemot,SEISX,IZ) 597 : IF (SEISX)IS=IS+1 597 : CALL ACCTAB(MTAB2,'MOT',0,0.0D0,'DIR_Y',.TRUE.,0, 598 : & 'LOGIQUE',IP,RR,lemot,SEISY,IZ) 599 : IF (SEISY)IS=IS+1 599 : CALL ACCTAB(MTAB2,'MOT',0,0.0D0,'DIR_Z',.TRUE.,0, 600 : & 'LOGIQUE',IP,RR,lemot,SEISZ,IZ) 601 : IF (SEISZ)IS=IS+1 602 : WRITE(NMIS,551)IS 603 : 551 FORMAT('INCI ',I1) 604 : IF (SEISX) THEN 605 : WRITE(NMIS,550)'SV' 606 : ENDIF 607 : IF (SEISY) THEN 608 : WRITE(NMIS,550)'SH' 609 : ENDIF 610 : IF (SEISZ) THEN 611 : WRITE(NMIS,550)'P ' 612 : ENDIF 613 : 550 FORMAT('DPLANE ',A2,/,'0. 0. 1. /* incidence verticale') 614 : C 615 : C execution 616 : C 617 : IF(TYPFOND.EQ.'SUPERFICIELLE')THEN 618 : WRITE(NMIS,560) 619 : ELSE 620 : WRITE(NMIS,562) (10*DRECH),(10*DRECH) 621 : ENDIF 622 : 560 FORMAT('*',/,'EXEC SPFR',/,'EXEC INCI',/, 623 : & 'EXEC UGTG CHAMP UD0 IMPEDANCE FORCE',/, 624 : & 'EXEC GLOBAL',/,'********',/,'FIN',/) 625 : 562 FORMAT('*',/,'EXEC SPFR',/,'EXEC INCI',/, 626 : & 'EXEC UGTG CHAMP UD0 IMPEDANCE FORCE RFIC ',F5.3,' ',F5.3,/, 627 : & 'EXEC GLOBAL',/,'********',/,'FIN',/) 628 : ELSE 629 : IF(TYPFOND.EQ.'SUPERFICIELLE')THEN 630 : WRITE(NMIS,561) 631 : ELSE 631 : CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'RFIC',.TRUE.,0, 632 : & 'TABLE',IP,RR,lemot,LOGI,MTAB3) 632 : CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'A',.TRUE.,0, 633 : & 'FLOTTANT',IP,DARFIC,lemot,LOGI,IZ) 633 : CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'H',.TRUE.,0, 634 : & 'FLOTTANT',IP,DHRFIC,lemot,LOGI,IZ) 635 : WRITE(NMIS,563) (DARFIC),(DHRFIC) 636 : ENDIF 637 : 561 FORMAT('*',/,'EXEC SPFR',/, 638 : & 'EXEC UGTG IMPEDANCE',/, 639 : & '**',/,'FIN',/) 640 : 563 FORMAT('*',/,'EXEC SPFR',/, 641 : & 'EXEC UGTG IMPEDANCE RFIC ',F5.3,' ',F5.3,/, 642 : & '**',/,'FIN',/) 643 : ENDIF 644 : RETURN 645 : END 646 :
© Cast3M 2003 - All rights reserved.
Disclaimer