C PRDOMI SOURCE AF221230 13/08/01 21:15:08 7808 C PRDOMI SOURCE SUBROUTINE PRDOMI(CALDYN,NMIS,NOMETU,LE,MTAB1) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C C======================================================================= C POUR MISS3D : ECRITURE DU FICHIERS DE DONNEES MISS.IN C C Appelle par l'operateur MISE C======================================================================= C -INC SMTABLE -INC CCOPTIO CHARACTER*72 lemot CHARACTER*20 NOMETU LOGICAL CALDYN CHARACTER*105 FICMISS,NFSOL CHARACTER*8 TYPRET CHARACTER*13 TYPFOND LOGICAL LOGI,FISOL,SEISX,SEISY,SEISZ,VSVP,ECH,RECE,SOUR C SEGMENT WCOUP REAL*8 ZCOUP(NCOUP) INTEGER JTYPC(NCOUP) ENDSEGMENT SEGMENT WCOUCH REAL*8 EPC(NCOUCH) INTEGER KMAT(NCOUCH) LOGICAL AVECR(NCOUCH) ENDSEGMENT SEGMENT WSOUR INTEGER COUSOU(NSOUR) ENDSEGMENT C FICMISS=NOMETU(1:LE)//'.mail' C C ecriture debut fichier MISS.IN C WRITE(NMIS,501)NOMETU,FICMISS 501 FORMAT('GENER ',A20,/,'*',/,'DATA',/,'*',/,'TITRE',/, & 'Chainage Castem Miss',/,'*',/,'MAILLAGE ',A25,/,'*') IF(CALDYN)THEN IG=2 WRITE(NMIS,502)IG 502 FORMAT('GROUPE',/,I1,' VOLUme',/,'FIN',/,'FING',/,'*') ENDIF FICMISS=NOMETU(1:LE)//'.chp' WRITE(NMIS,503)FICMISS 503 FORMAT('INTEGRATION TRIANGLE 10 12 RECTANGLE 6 10',/,'*',/, & 'CHAMP',/,'LIRE ',A25,/,'FINC',/,'*',/,'VERIF',/,'*') TYPRET=' ' C C Ecriture plage de Frequence et definitions des domaines C CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FREQ_SOL_MIN',.TRUE.,0, & TYPRET,IP,FMIN,lemot,LOGI,IZ) CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FREQ_SOL_MAX',.TRUE.,0, & TYPRET,IP,FMAX,lemot,LOGI,IZ) CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FREQ_SOL_PAS',.TRUE.,0, & TYPRET,IP,FPAS,lemot,LOGI,IZ) WRITE(NMIS,504)FMIN,FMAX,FPAS 504 FORMAT('FREQ DE ',F5.2,' A ',F5.2,' PAS ',F5.2,/,'*') WRITE(NMIS,505) 505 FORMAT('SDOM 1 GROUP 1',/,'STRA',/,'FINS',/,'*') IF(CALDYN)THEN WRITE(NMIS,506) 506 FORMAT('SDOM 2 GROUP -1 2',/,'KCM',/,'FINS',/,'*') ENDIF WRITE(NMIS,507) 507 FORMAT('FIND',/,'*') C C Definition domaine structure dans le cas d'un calcul ISS C IF(CALDYN)THEN FICMISS=NOMETU(1:LE)//'.imp' WRITE(NMIS,508)FICMISS 508 FORMAT('DOMAINE 2',/,'EXTE',/,'LIRE ',A25,/,'FINE',/,'*') ENDIF C C Definition du sol dans le fichier MISS.IN C WRITE(NMIS,509) 509 FORMAT('DOMAINE 1') C C Si sol dans un fichier au format MISS CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'FICHIER_SOL',.TRUE.,0, & 'MOT',IP,RR,NFSOL,LOGI,IZ) IF(NFSOL(1:5).EQ.'NEANT')THEN FISOL=.FALSE. ELSE FISOL=.TRUE. ENDIF C C calcul nombre de materiaux IF(.NOT.FISOL)THEN CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'CARA_SOL',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTABCS) MTABLE=MTABCS SEGACT MTABLE NMAT=MLOTAB-1 SEGDES MTABLE ENDIF C C type de fondation CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'TYPE_FONDATION',.TRUE.,0, & 'MOT',IP,RR,TYPFOND,LOGI,IZ) CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'SURFACE_LIBRE',.TRUE.,0, & 'FLOTTANT',IP,Z0,lemot,LOGI,IZ) C C Fondations superficielles (source et recepteur � la surface) IF(TYPFOND.EQ.'SUPERFICIELLE')THEN WRITE(NMIS,511)Z0,'SURF' ELSE WRITE(NMIS,511)Z0 ENDIF 511 FORMAT('DOS2M Z0 ',F5.2,1X,A4) C C Definition des materiaux IF(FISOL)THEN WRITE(NMIS,499)NFSOL 499 FORMAT('LIRE ',A80) ELSE WRITE(NMIS,512)NMAT C 512 FORMAT('GENER ugtg',/,'TITRE',/, C & 'Demi espace multi couches',/,'*',/,'MATE ',I3) 512 FORMAT('TITRE',/, & 'Demi espace multi couches',/,'*',/,'MATE ',I3) CALL ACCTAB(MTABCS,'MOT',0,0.0D0,'VSVP',.TRUE.,0, & 'LOGIQUE',IP,RR,lemot,VSVP,IZ) IF (VSVP)THEN WRITE(NMIS,5123) ELSE WRITE(NMIS,5124) ENDIF 5123 FORMAT('RO VS VP BETA') 5124 FORMAT('RO E NU BETA') pmin=0. pmax=0. cpmax=0. csmin=100000000. betam=10. DO 30 IC=1,NMAT CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTABCI) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'RO',.TRUE.,0, & 'FLOTTANT',IP,RO,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'BETA',.TRUE.,0, & 'FLOTTANT',IP,BETA,lemot,LOGI,IZ) IF(betam.GT.BETA)betam=BETA IF(VSVP)THEN CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VS',.TRUE.,0, & 'FLOTTANT',IP,VS,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VP',.TRUE.,0, & 'FLOTTANT',IP,VP,lemot,LOGI,IZ) WRITE(NMIS,5125)RO,VS,VP,BETA cp=VP cs=VS ELSE CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'E',.TRUE.,0, & 'FLOTTANT',IP,ZE,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'NU',.TRUE.,0, & 'FLOTTANT',IP,ZNU,lemot,LOGI,IZ) WRITE(NMIS,5125)RO,ZE,ZNU,BETA lamda=(ZE*ZNU)/((1+ZNU)*(1-2*ZNU)) zmu=ZE/(2*(1+ZNU)) cp=((lamda+2*zmu)/RO)**0.5 cs=(zmu/RO)**0.5 ENDIF IF((cpmax-cp).LT.0.00001)cpmax=cp IF((csmin-cs).GT.0.00001)csmin=cs 5125 FORMAT(4(E12.6,1X)) 30 CONTINUE pmin=1/cpmax pmax=1/csmin C dp=betam*pmin c dp=0.1*betam*pmin C pmax=8*pmax np=1+int(pmax/dp) C C couches et recepteurs IF(TYPFOND.EQ.'SUPERFICIELLE')THEN WRITE(NMIS,513)NMAT 513 FORMAT('*',/,'COUCHES ',I3) C DO 40 IC=1,NMAT-1 DO 40 IC=1,NMAT C CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTABCI) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) IF(IC.EQ.1)THEN IF (EPAI.GT.(0.1E+10)) THEN EPAI=1. WRITE(NMIS,515)EPAI,IC ELSE; WRITE(NMIS,515)EPAI,IC ENDIF; ELSE IF (EPAI.GT.(0.1E+10)) THEN EPAI=1. WRITE(NMIS,514)EPAI,IC ELSE; WRITE(NMIS,514)EPAI,IC ENDIF; ENDIF WRITE(IOIMP,*) ' ' write(6,714) IC 714 FORMAT('********************* Materiaux ',I2, & ' *********************') CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'RO',.TRUE.,0, & 'FLOTTANT',IP,RO,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'BETA',.TRUE.,0, & 'FLOTTANT',IP,BETA,lemot,LOGI,IZ) IF(VSVP)THEN CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VS',.TRUE.,0, & 'FLOTTANT',IP,VS,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VP',.TRUE.,0, & 'FLOTTANT',IP,VP,lemot,LOGI,IZ) WRITE(IOIMP,715)RO,VS,VP,BETA ELSE CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'E',.TRUE.,0, & 'FLOTTANT',IP,ZE,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'NU',.TRUE.,0, & 'FLOTTANT',IP,ZNU,lemot,LOGI,IZ) WRITE(IOIMP,716)RO,ZE,ZNU,BETA ENDIF 715 FORMAT('RO ',F7.2,' VS ',F7.2, & ' VP ',F7.2,' BETA ',F5.3) 716 FORMAT('RO ',F7.2,' E ',E10.3, & ' NU ',F5.3,' BETA ',F5.3) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) IF (IC.EQ.1) THEN ZC0 = Z0; ZC1 = ZC0-EPAI; ELSE ZC0 = ZC1; ZC1 = ZC1-EPAI; ENDIF WRITE(IOIMP,*) ' ' WRITE(IOIMP,717) ZC0 WRITE(IOIMP,718) ZC1 717 FORMAT('Cote Initiale ',F8.3) 718 FORMAT('Cote finale ',F8.3) IF (IC.EQ.1) THEN WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Position recepteurs dans la couche' WRITE(IOIMP,719) Z0 719 FORMAT('z ',F8.3) ELSE WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Position recepteurs dans la couche' WRITE(IOIMP,*) ' Aucun recepteur dans la couche' ENDIF 514 FORMAT(E12.6,' MATE ',I4) 515 FORMAT(E12.6,' MATE ',I4,' RECEP') 40 CONTINUE WRITE(NMIS,516)NMAT 516 FORMAT('SUBS MATE ',I4) 520 FORMAT('SUBS MATE ',I4,' RECEP') WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Definition des couches ', & 'sur fichier MISS.IN' WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Nombre total couches', NMAT WRITE(IOIMP,*) ' ' DO 720 IC=1,NMAT CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTABCI) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) IF (IC.EQ.1) THEN IF (EPAI.GT.(0.1E+10)) THEN EPAI=1. ENDIF WRITE(IOIMP,721) IC,EPAI,IC,IC ELSE IF (EPAI.GT.(0.1E+10)) THEN EPAI=1. ENDIF WRITE(IOIMP,722) IC,EPAI,IC,IC ENDIF 720 CONTINUE 721 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, & ' Recep OUI Sources OUI',' COUCHE ',I3) 722 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, & ' Recep NON Sources NON',' COUCHE ',I3) WRITE(IOIMP,723) NMAT 723 FORMAT('Subs Materiau ',I2, & ' Recep NON Sources NON') C C sources et algo I=1 WRITE(NMIS,517)I 517 FORMAT('SOURCE ',I4,' 3D') WRITE(NMIS,518)I 518 FORMAT('FORCE HORI POSI ',I4) WRITE(NMIS,519) 519 FORMAT('*',/,'ALGO DEPL') ELSEIF(TYPFOND.EQ.'PROFONDE')THEN C Fondations profondes (calculer le nombre de couches, de sources et de recepteurs) CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'RECEPTEURS',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTABRE) MTABLE=MTABRE SEGACT MTABLE NR=MLOTAB SEGDES MTABLE CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'SOURCES',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTABSO) MTABLE=MTABSO SEGACT MTABLE NS=MLOTAB SEGDES MTABLE C c on dimensionne large NCOUCH=NMAT+NR+NS SEGINI WCOUCH NCOUP=NR+NS SEGINI WCOUP NSOUR=NS SEGINI WSOUR ZC0=Z0 JSOUR=0 NEWCOU=0 DO 61 IC=1,NMAT write(6,*) ' ' write(6,700) IC 700 FORMAT('********************* Materiaux ',I2, & ' *********************') NEWCOU=NEWCOU+1 CALL ACCTAB(MTABCS,'ENTIER',IC,0.0D0,' ',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTABCI) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'EPAI',.TRUE.,0, & 'FLOTTANT',IP,EPAI,lemot,LOGI,IZ) ZC1=ZC0-EPAI CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'RO',.TRUE.,0, & 'FLOTTANT',IP,RO,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'BETA',.TRUE.,0, & 'FLOTTANT',IP,BETA,lemot,LOGI,IZ) IF(VSVP)THEN CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VS',.TRUE.,0, & 'FLOTTANT',IP,VS,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'VP',.TRUE.,0, & 'FLOTTANT',IP,VP,lemot,LOGI,IZ) WRITE(IOIMP,704)RO,VS,VP,BETA ELSE CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'E',.TRUE.,0, & 'FLOTTANT',IP,ZE,lemot,LOGI,IZ) CALL ACCTAB(MTABCI,'MOT',0,0.0D0,'NU',.TRUE.,0, & 'FLOTTANT',IP,ZNU,lemot,LOGI,IZ) WRITE(IOIMP,705)RO,ZE,ZNU,BETA ENDIF 704 FORMAT('RO ',F7.2,' VS ',F7.2, & ' VP ',F7.2,' BETA ',F5.3) 705 FORMAT('RO ',F7.2,' E ',E10.3, & ' NU ',F5.3,' BETA ',F5.3) KCOUP=0 RECE=.FALSE. SOUR=.FALSE. WRITE(IOIMP,*) ' ' WRITE(IOIMP,701) ZC0 WRITE(IOIMP,702) ZC1 701 FORMAT('Cote Initiale ',F8.3) 702 FORMAT('Cote finale ',F8.3) DO 62 IR=1,NR CALL ACCTAB(MTABRE,'ENTIER',IR,0.0D0,' ',.TRUE.,0, & 'FLOTTANT',IP,ZR,lemot,LOGI,IZ) IF(ABS(ZR-ZC0).LE.0.001)THEN RECE=.TRUE. ELSEIF((ZR-ZC1).GT.0.001.AND.ZR.LT.ZC0)THEN KCOUP=KCOUP+1 ZCOUP(KCOUP)=ZR JTYPC(KCOUP)=1 ENDIF 62 CONTINUE DO 64 IS=1,NS CALL ACCTAB(MTABSO,'ENTIER',IS,0.0D0,' ',.TRUE.,0, & 'FLOTTANT',IP,ZS,lemot,LOGI,IZ) IF(ABS(ZS-ZC0).LE.0.001)THEN SOUR=.TRUE. ELSEIF((ZS-ZC1).GT.0.001.AND.ZS.LT.ZC0)THEN KCOUP=KCOUP+1 ZCOUP(KCOUP)=ZS JTYPC(KCOUP)=2 ENDIF 64 CONTINUE WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Position recepteurs dans la couche' IF (RECE) THEN WRITE(IOIMP,703) ZC0 ENDIF; DO 601 I1=1,KCOUP; IF (JTYPC(I1).EQ.1) THEN WRITE(IOIMP,703) ZCOUP(I1) ENDIF 601 CONTINUE WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Position sources dans la couche' IF (SOUR) THEN WRITE(IOIMP,703) ZC0 ENDIF; DO 602 I1=1,KCOUP; IF (JTYPC(I1).EQ.2) THEN WRITE(IOIMP,703) ZCOUP(I1) ENDIF 602 CONTINUE 703 FORMAT('z ',F8.3) IF(KCOUP.GE.2)THEN IFIN=KCOUP-1 66 CONTINUE ECH=.FALSE. DO 67 ICOUP=1,IFIN IF(ZCOUP(ICOUP).LT.ZCOUP(ICOUP+1))THEN ZPROV=ZCOUP(ICOUP) JPROV=JTYPC(ICOUP) ZCOUP(ICOUP)=ZCOUP(ICOUP+1) JTYPC(ICOUP)=JTYPC(ICOUP+1) ZCOUP(ICOUP+1)=ZPROV JTYPC(ICOUP+1)=JPROV ECH=.TRUE. ENDIF 67 CONTINUE IF(ECH)THEN IFIN=IFIN-1 IF(IFIN.GE.1)GOTO 66 ENDIF DO 69 ICOUP=1,KCOUP IF(ABS(ZCOUP(ICOUP)-ZCOUP(ICOUP+1)).LT.0.001.AND. & ZCOUP(ICOUP).NE.1.D9)THEN c IF(ABS(ZCOUP(ICOUP)-ZCOUP(ICOUP+1)).LT.0.001)THEN C write(6,*) 'ICOUP=',ICOUP,'ZCOUP(ICOUP) =',ZCOUP(ICOUP), C & 'ZCOUP(ICOUP+1) =',ZCOUP(ICOUP+1) DO 68 I1=ICOUP,KCOUP-1 C write(6,*) 'I1 =', I1,'ZCOUP(I1) =',ZCOUP(I1), C & 'ZCOUP(I1+1) =',ZCOUP(I1+1) ZCOUP(I1)=ZCOUP(I1+1) JTYPC(I1)=JTYPC(I1+1) 68 CONTINUE JTYPC(ICOUP)=12 ZCOUP(KCOUP)=1.D9 KCOUP=KCOUP-1 ENDIF 69 CONTINUE C C Preparation Ecriture EPC(NEWCOU)=ZC0-ZCOUP(1) AVECR(NEWCOU)=.FALSE. IF(RECE)AVECR(NEWCOU)=.TRUE. KMAT(NEWCOU)=IC IF(SOUR)THEN JSOUR=JSOUR+1 COUSOU(JSOUR)=NEWCOU ENDIF DO 70 ICOUP=1,KCOUP-1 NEWCOU=NEWCOU+1 EPC(NEWCOU)=ZCOUP(ICOUP)-ZCOUP(ICOUP+1) AVECR(NEWCOU)=.FALSE. IF(JTYPC(ICOUP).EQ.1.OR.JTYPC(ICOUP).EQ.12) & AVECR(NEWCOU)=.TRUE. KMAT(NEWCOU)=IC IF(JTYPC(ICOUP).EQ.2.OR.JTYPC(ICOUP).EQ.12)THEN JSOUR=JSOUR+1 COUSOU(JSOUR)=NEWCOU ENDIF 70 CONTINUE NEWCOU=NEWCOU+1 EPC(NEWCOU)=ZCOUP(KCOUP)-ZC1 AVECR(NEWCOU)=.FALSE. IF(JTYPC(KCOUP).EQ.1.OR.JTYPC(KCOUP).EQ.12) & AVECR(NEWCOU)=.TRUE. KMAT(NEWCOU)=IC IF(JTYPC(KCOUP).EQ.2.OR.JTYPC(KCOUP).EQ.12)THEN JSOUR=JSOUR+1 COUSOU(JSOUR)=NEWCOU ENDIF ELSEIF(KCOUP.EQ.1)THEN EPC(NEWCOU)=ZC0-ZCOUP(KCOUP) AVECR(NEWCOU)=.FALSE. IF(RECE)AVECR(NEWCOU)=.TRUE. KMAT(NEWCOU)=IC IF(SOUR)THEN JSOUR=JSOUR+1 COUSOU(JSOUR)=NEWCOU ENDIF NEWCOU=NEWCOU+1 EPC(NEWCOU)=ZCOUP(KCOUP)-ZC1 AVECR(NEWCOU)=.FALSE. IF(JTYPC(KCOUP).EQ.1.OR.JTYPC(KCOUP).EQ.12) & AVECR(NEWCOU)=.TRUE. KMAT(NEWCOU)=IC IF(JTYPC(KCOUP).EQ.2.OR.JTYPC(KCOUP).EQ.12)THEN JSOUR=JSOUR+1 COUSOU(JSOUR)=NEWCOU ENDIF ELSE EPC(NEWCOU)=ZC0-ZC1 AVECR(NEWCOU)=.FALSE. IF(RECE)AVECR(NEWCOU)=.TRUE. KMAT(NEWCOU)=IC IF(SOUR)THEN JSOUR=JSOUR+1 COUSOU(JSOUR)=NEWCOU ENDIF ENDIF ZC0=ZC1 61 CONTINUE c WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Definition des couches', & 'sur fichier MISS.IN' WRITE(IOIMP,*) ' ' WRITE(IOIMP,*) 'Nombre total couches', (NEWCOU-1) WRITE(IOIMP,*) ' ' I2 = 1; DO 603 I1=1,NEWCOU-1 IF (I1.EQ.(COUSOU(I2))) THEN IF (AVECR(I1)) THEN WRITE(IOIMP,709) I1,EPC(I1),KMAT(I1),I1 ELSE WRITE(IOIMP,708) I1,EPC(I1),KMAT(I1),I1 ENDIF I2 = I2 + 1 ELSE IF (AVECR(I1)) THEN WRITE(IOIMP,707) I1,EPC(I1),KMAT(I1),I1 ELSE WRITE(IOIMP,706) I1,EPC(I1),KMAT(I1),I1 ENDIF ENDIF 603 CONTINUE IF (AVECR(NEWCOU)) THEN IF (I1.EQ.(COUSOU(I2))) THEN WRITE(IOIMP,713) KMAT(NEWCOU) ELSE WRITE(IOIMP,711) KMAT(NEWCOU) ENDIF ELSE IF (I1.EQ.(COUSOU(I2))) THEN WRITE(IOIMP,712) KMAT(NEWCOU) ELSE WRITE(IOIMP,710) KMAT(NEWCOU) ENDIF ENDIF 706 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, & ' Recep NON Sources NON',' COUCHE ',I3) 707 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, & ' Recep OUI Sources NON',' COUCHE ',I3) 708 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, & ' Recep NON Sources OUI',' COUCHE ',I3) 709 FORMAT('COUCHE ',I3,' Epais ',F8.3,' Materiau ',I2, & ' Recep OUI Sources OUI',' COUCHE ',I3) 710 FORMAT('Subs Materiau ',I2, & ' Recep NON Sources NON') 711 FORMAT('Subs Materiau ',I2, & ' Recep OUI Sources NON') 712 FORMAT('Subs Materiau ',I2, & ' Recep NON Sources OUI') 713 FORMAT('Subs Materiau ',I2, & ' Recep OUI Sources OUI') C C Ecritures couches et sources plus algorithme C WRITE(NMIS,525)NEWCOU-1 525 FORMAT('COUCHES ',I4) DO 72 IC=1,NEWCOU-1 IF(AVECR(IC))THEN WRITE(NMIS,515)EPC(IC),KMAT(IC) ELSE WRITE(NMIS,514)EPC(IC),KMAT(IC) ENDIF 72 CONTINUE IF (AVECR(NEWCOU)) THEN WRITE(NMIS,520)KMAT(NEWCOU) ELSE WRITE(NMIS,516)KMAT(NEWCOU) ENDIF WRITE(NMIS,517)JSOUR C DO 74 IS=1,JSOUR WRITE(NMIS,518)COUSOU(IS) 74 CONTINUE WRITE(NMIS,521) 521 FORMAT('ALGO REGU') SEGDES WCOUP SEGDES WSOUR SEGDES WCOUCH ENDIF C C Echantillonnage spectral C if(np.LT.2048)then np=2048 elseif(np.LT.4096)then np=4096 elseif(np.LT.6144)then np=6144 elseif(np.LT.8192) then np=8192 elseif(np.LT.10240) then np=10240 elseif(np.LT.12288) then np=12288 elseif(np.LT.14336) then np=14336 endif WRITE(NMIS,530)pmax,np 530 FORMAT('SPEC',' ',E12.6,' ',' / ',I5) C C Echantillonnage spatial C CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'ECHANT_NP',.TRUE.,0, & 'ENTIER',NPECH,RR,lemot,LOGI,IZ) CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'ECHANT_DR',.TRUE.,0, & 'FLOTTANT',IP,DRECH,lemot,LOGI,IZ) WRITE(NMIS,535)NPECH,DRECH 535 FORMAT('OFFSET ',I5,' * ',E12.6) WRITE(NMIS,545) 545 FORMAT('DREF 0.0001',/,'FIND',/,'*') c------ modif 20110803_calcul pmin,pmax ENDIF C C chargement sismique C IF(CALDYN)THEN IS=0 CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DIR_CHARGEMENT',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTAB2) CALL ACCTAB(MTAB2,'MOT',0,0.0D0,'DIR_X',.TRUE.,0, & 'LOGIQUE',IP,RR,lemot,SEISX,IZ) IF (SEISX)IS=IS+1 CALL ACCTAB(MTAB2,'MOT',0,0.0D0,'DIR_Y',.TRUE.,0, & 'LOGIQUE',IP,RR,lemot,SEISY,IZ) IF (SEISY)IS=IS+1 CALL ACCTAB(MTAB2,'MOT',0,0.0D0,'DIR_Z',.TRUE.,0, & 'LOGIQUE',IP,RR,lemot,SEISZ,IZ) IF (SEISZ)IS=IS+1 WRITE(NMIS,551)IS 551 FORMAT('INCI ',I1) IF (SEISX) THEN WRITE(NMIS,550)'SV' ENDIF IF (SEISY) THEN WRITE(NMIS,550)'SH' ENDIF IF (SEISZ) THEN WRITE(NMIS,550)'P ' ENDIF 550 FORMAT('DPLANE ',A2,/,'0. 0. 1. /* incidence verticale') C C execution C IF(TYPFOND.EQ.'SUPERFICIELLE')THEN WRITE(NMIS,560) ELSE WRITE(NMIS,562) (10*DRECH),(10*DRECH) ENDIF 560 FORMAT('*',/,'EXEC SPFR',/,'EXEC INCI',/, & 'EXEC UGTG CHAMP UD0 IMPEDANCE FORCE',/, & 'EXEC GLOBAL',/,'********',/,'FIN',/) 562 FORMAT('*',/,'EXEC SPFR',/,'EXEC INCI',/, & 'EXEC UGTG CHAMP UD0 IMPEDANCE FORCE RFIC ',F5.3,' ',F5.3,/, & 'EXEC GLOBAL',/,'********',/,'FIN',/) ELSE IF(TYPFOND.EQ.'SUPERFICIELLE')THEN WRITE(NMIS,561) ELSE CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'RFIC',.TRUE.,0, & 'TABLE',IP,RR,lemot,LOGI,MTAB3) CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'A',.TRUE.,0, & 'FLOTTANT',IP,DARFIC,lemot,LOGI,IZ) CALL ACCTAB(MTAB3,'MOT',0,0.0D0,'H',.TRUE.,0, & 'FLOTTANT',IP,DHRFIC,lemot,LOGI,IZ) WRITE(NMIS,563) (DARFIC),(DHRFIC) ENDIF 561 FORMAT('*',/,'EXEC SPFR',/, & 'EXEC UGTG IMPEDANCE',/, & '**',/,'FIN',/) 563 FORMAT('*',/,'EXEC SPFR',/, & 'EXEC UGTG IMPEDANCE RFIC ',F5.3,' ',F5.3,/, & '**',/,'FIN',/) ENDIF RETURN END