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

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