Télécharger prdomi.eso

Retour à la liste

Numérotation des lignes :

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

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