Télécharger la plaquette Cast3M


fr en

Télécharger prdomi.eso

Retour à la liste

Numérotation des lignes : 

prdomi

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales