Télécharger excha1.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCHA1 SOURCE LJ1 14/11/13 21:15:29 8248
  2. SUBROUTINE EXCHA1(ICHAM,ILISR,CMOT)
  3.  
  4. ************************************************************************
  5. *
  6. * EXTRACTION DES VARIABLES DONT DEPENDENT LES PARAMETRES DU
  7. * MATERIAU.
  8. *
  9. * ICHAM (E) INTEGER POINTEUR SUR LE MCHAML
  10. * ILISR (S) INTEGER POINTEUR SUR UN OBJET DE TYPE SMLMOTS
  11. * CONTENANT LES NOMS DES VARIABLES
  12. * CMOT (E)
  13. *
  14. ************************************************************************
  15.  
  16. IMPLICIT INTEGER(I-N)
  17. IMPLICIT REAL*8(A-H,O-Z)
  18.  
  19. -INC CCOPTIO
  20. -INC CCNOYAU
  21. -INC CCASSIS
  22.  
  23. -INC SMCHAML
  24. -INC SMLMOTS
  25. -INC SMNUAGE
  26. -INC SMEVOLL
  27. -INC SMTABLE
  28. c cccccc
  29. PARAMETER ( NNOMCH=25 )
  30. c cccccc
  31. CHARACTER*(*) CMOT
  32. CHARACTER*8 NOMCHT,NOMVXT,NOMVYT,LNOMCH(NNOMCH)
  33. CHARACTER*4 MOTSIM
  34. DATA MOTSIM / 'SIMU' /
  35. DATA LNOMCH / 'TRAC ','EVOL ','COMP ','FLXY ',
  36. & 'FLXZ ','CISY ','CISZ ','JDA ',
  37. & 'EM0 ','EM1 ','EM2 ','EM3 ',
  38. & 'EM4 ','EM5 ','EM6 ','EM7 ',
  39. & 'EM8 ','MONP ','MONN ','MONO ',
  40. & 'COEV ','TREV ','TRAS ','TRAT ',
  41. $ 'PULO '/
  42. ICAS = 1
  43. IF (CMOT.EQ.'COVA') ICAS = 2
  44.  
  45. *------------- activation de la liste de MOTS ------------------------
  46.  
  47. JGM = 20
  48. JGN = 8
  49. SEGINI MLMOT1
  50. ITE1 = 0
  51.  
  52. MCHELM = ICHAM
  53. SEGACT MCHELM
  54. NSOUS = ICHAML(/1)
  55.  
  56. *------------------ boucle sur les sous chamelem ---------------------
  57.  
  58. DO 1 I1=1,NSOUS
  59. MCHAML = ICHAML(I1)
  60. SEGACT MCHAML
  61. NCOMP = NOMCHE(/2)
  62.  
  63. *-------------------- boucle sur les composantes ---------------------
  64.  
  65. DO 2 I2=1,NCOMP
  66. IF (TYPCHE(I2).EQ.'REAL*8 ') THEN
  67. GOTO 2
  68. ELSE IF (TYPCHE(I2).EQ.'POINTEURPOINT ') THEN
  69. GOTO 2
  70. ELSE IF (TYPCHE(I2).EQ.'POINTEURMAILLAGE') THEN
  71. GOTO 2
  72. ELSE IF (TYPCHE(I2).EQ.'POINTEURMCHAML ') THEN
  73. GOTO 2
  74. ELSE IF (TYPCHE(I2).EQ.'POINTEURCHPOINT ') THEN
  75. GOTO 2
  76. ELSE IF (TYPCHE(I2).EQ.'POINTEURMMODEL ') THEN
  77. GOTO 2
  78. ELSE IF (TYPCHE(I2).EQ.'POINTEURLISTREEL') THEN
  79. GOTO 2
  80.  
  81. ELSE IF (TYPCHE(I2).EQ.'POINTEURNUAGE ') THEN
  82. NOMCHT = NOMCHE(I2)
  83. IF (ICAS.EQ.1) THEN
  84. CALL PLACE(LNOMCH,NNOMCH,iplac,NOMCHT)
  85. MELVAL = IELVAL(I2)
  86. SEGACT MELVAL
  87. NOE = IELCHE(/1)
  88. NEL = IELCHE(/2)
  89. DO 3 I3=1,NEL
  90. DO 4 I4=1,NOE
  91. MNUAGE = IELCHE(I4,I3)
  92. SEGACT MNUAGE
  93. NVAR = NUANOM(/2)
  94. IPOSI = 0
  95. DO 5 I5 = 1,NVAR
  96. IF (NUANOM(I5).EQ.NOMCHT) IPOSI = I5
  97. 5 CONTINUE
  98. IF (IPOSI.NE.0) THEN
  99. DO 6 I6 = 1,NVAR
  100. IF (I6.EQ.IPOSI) THEN
  101. IF (iplac.EQ.0) THEN
  102. IF (NUATYP(I6).EQ.'EVOLUTIO') THEN
  103. NUAVIN=NUAPOI(I6)
  104. SEGACT NUAVIN
  105. MEVOL1=NUAINT(1)
  106. SEGDES NUAVIN
  107. SEGACT MEVOL1
  108. N1=MEVOL1.IEVOLL(/1)
  109. C
  110. C ON TESTE L'OBJET EVOLUTION
  111. C
  112. IF(N1.NE.1) THEN
  113. MOTERR(1:8)='EVOLUTIO'
  114. INTERR(1)=MEVOL1
  115. CALL ERREUR(110)
  116. SEGDES MEVOL1
  117. SEGDES MNUAGE
  118. SEGDES MELVAL
  119. SEGDES MCHAML
  120. GOTO 9000
  121. ENDIF
  122. IF(MEVOL1.ITYEVO.NE.'REEL') THEN
  123. MOTERR(1:8)='EVOLUTIO'
  124. MOTERR(9:16)='REEL '
  125. CALL ERREUR(79)
  126. SEGDES MEVOL1
  127. SEGDES MNUAGE
  128. SEGDES MELVAL
  129. SEGDES MCHAML
  130. GOTO 9000
  131. ENDIF
  132. KEVOL1=MEVOL1.IEVOLL(1)
  133. SEGDES MEVOL1
  134. SEGACT KEVOL1
  135. IF(KEVOL1.TYPX.NE.'LISTREEL'.OR.
  136. & KEVOL1.TYPY.NE.'LISTREEL')THEN
  137. MOTERR(1:8)='EVOLUTIO'
  138. MOTERR(9:16)='LISTREEL'
  139. INTERR(1)=MEVOL1
  140. CALL ERREUR(630)
  141. SEGDES KEVOL1
  142. SEGDES MNUAGE
  143. SEGDES MELVAL
  144. SEGDES MCHAML
  145. GOTO 9000
  146. ENDIF
  147. NOMVXT=KEVOL1.NOMEVX(1:8)
  148. SEGDES KEVOL1
  149. DO 7 IU=1,ITE1
  150. IF (MLMOT1.MOTS(IU).EQ.NOMVXT) GOTO 8
  151. 7 CONTINUE
  152. ITE1 = ITE1 + 1
  153. IF (ITE1.GT.JGM) THEN
  154. JGM = JGM + 20
  155. SEGADJ MLMOT1
  156. ENDIF
  157. MLMOT1.MOTS(ITE1) = NOMVXT
  158. 8 CONTINUE
  159. ENDIF
  160. ENDIF
  161. ELSE
  162. NOMVXT = NUANOM(I6)
  163. DO 9 IU=1,ITE1
  164. IF (MLMOT1.MOTS(IU).EQ.NOMVXT) GOTO 10
  165. 9 CONTINUE
  166. ITE1 = ITE1 + 1
  167. IF (ITE1.GT.JGM) THEN
  168. JGM = JGM + 20
  169. SEGADJ MLMOT1
  170. ENDIF
  171. MLMOT1.MOTS(ITE1) = NOMVXT
  172. 10 CONTINUE
  173. ENDIF
  174. 6 CONTINUE
  175. ELSE IF (nvar.gt.2) THEN
  176. goto 1
  177. ELSE
  178. *--------- un parametre du mchaml ne correspond a aucun -----------
  179. *------------------- nom de composante du NUAGE ---------------------
  180. MOTERR(1:8) = NOMCHT
  181. CALL ERREUR(677)
  182. SEGDES MNUAGE
  183. SEGDES MELVAL
  184. SEGDES MCHAML
  185. GOTO 9000
  186. ENDIF
  187. SEGDES MNUAGE
  188. 4 CONTINUE
  189. 3 CONTINUE
  190. SEGDES MELVAL
  191. ELSE IF (ICAS.EQ.2) THEN
  192. DO 11 IU=1,ITE1
  193. IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 12
  194. 11 CONTINUE
  195. ITE1 = ITE1+1
  196. IF (ITE1.GT.JGM) THEN
  197. JGM= JGM+20
  198. SEGADJ MLMOT1
  199. ENDIF
  200. MLMOT1.MOTS(ITE1) = NOMCHT
  201. 12 CONTINUE
  202. ENDIF
  203.  
  204. ELSE IF (TYPCHE(I2).EQ.'POINTEUREVOLUTIO') THEN
  205. NOMCHT = NOMCHE(I2)
  206. CALL PLACE(LNOMCH,NNOMCH,iplac,NOMCHT)
  207. IF (iplac.NE.0) GOTO 2
  208. IF (ICAS.EQ.1) THEN
  209. MELVAL = IELVAL(I2)
  210. SEGACT MELVAL
  211. NOE = IELCHE(/1)
  212. NEL = IELCHE(/2)
  213. DO 13 I13=1,NEL
  214. DO 14 I14=1,NOE
  215. MEVOLL = IELCHE(I14,I13)
  216. SEGACT MEVOLL
  217. KEVOLL = IEVOLL(1)
  218. SEGDES MEVOLL
  219. SEGACT KEVOLL
  220. NOMVYT=NOMEVY(1:8)
  221. IF (NOMCHT.EQ.NOMVYT) THEN
  222. NOMVXT=NOMEVX(1:8)
  223. DO 15 IU=1,ITE1
  224. IF (MLMOT1.MOTS(IU).EQ.NOMVXT) GOTO 16
  225. 15 CONTINUE
  226. ITE1 = ITE1 + 1
  227. IF (ITE1.GT.JGM) THEN
  228. JGM = JGM + 20
  229. SEGADJ MLMOT1
  230. ENDIF
  231. MLMOT1.MOTS(ITE1) = NOMVXT
  232. 16 CONTINUE
  233. ELSE IF (NOMCHT.EQ.'MOCO'.
  234. & AND.NOMVYT(1:4).EQ.'RAID') THEN
  235. *calcul frequentiel
  236. DO 151 IU=1,ITE1
  237. IF (MLMOT1.MOTS(IU).EQ.'TEMP') GOTO 161
  238. 151 CONTINUE
  239. ITE1 = ITE1 + 1
  240. IF (ITE1.GT.JGM) THEN
  241. JGM = JGM + 20
  242. SEGADJ MLMOT1
  243. ENDIF
  244. MLMOT1.MOTS(ITE1) = 'TEMP'
  245. 161 CONTINUE
  246.  
  247. ELSE
  248. * Le nom de la composante ne correspond pas a l'ordonnee de l'EVOLUTION
  249. MOTERR(1:8) = NOMCHT
  250. MOTERR(9:20) = NOMEVY
  251. CALL ERREUR(678)
  252. SEGDES KEVOLL
  253. SEGDES MELVAL
  254. SEGDES MCHAML
  255. GOTO 9000
  256. END IF
  257. SEGDES KEVOLL
  258. 14 CONTINUE
  259. 13 CONTINUE
  260. SEGDES MELVAL
  261. ELSE IF (ICAS.EQ.2) THEN
  262. DO 17 IU=1,ITE1
  263. IF( MLMOT1.MOTS(IU) . EQ.NOMCHT) GO TO 18
  264. 17 CONTINUE
  265. ITE1 = ITE1+1
  266. IF (ITE1.GT.JGM) THEN
  267. JGM = JGM + 20
  268. SEGADJ MLMOT1
  269. ENDIF
  270. MLMOT1.MOTS(ITE1) = NOMCHT
  271. 18 CONTINUE
  272. ENDIF
  273. C
  274. ELSE IF (TYPCHE(I2).EQ.'POINTEURLISTMOTS') THEN
  275. C
  276. IF (ICAS.EQ.1) THEN
  277. C
  278. MELVAL=IELVAL(I2)
  279. SEGACT,MELVAL
  280. N2PTEL=IELCHE(/1)
  281. N2EL=IELCHE(/2)
  282. C
  283. C Le LISTMOTS donne les noms des variables dont depend
  284. C la composante, dans l'optique d'une evaluation de la
  285. C composante par une fonction externe.
  286. C HYPOTHESE de CHAMP UNIFORME : la composante depend
  287. C des memes variables en tout point d'integration de
  288. C tout element de la sous-zone.
  289. C Cette hypothese est necessaire car la composante ne
  290. C peut etre associee qu'a une seule fonction externe.
  291. C EN CONFORMITE AVEC VARINU.eso
  292. C
  293. IF (N2PTEL.NE.1.AND.N2EL.NE.1) THEN
  294. MOTERR(1:8)=NOMCHE(I2)
  295. CALL ERREUR(953)
  296. SEGDES,MELVAL
  297. SEGDES,MCHAML
  298. GOTO 9000
  299. ENDIF
  300. MLMOT2=IELCHE(1,1)
  301. SEGACT,MLMOT2
  302. JESIMU=0
  303. IF(MLMOT2.MOTS(1)(1:4).EQ.MOTSIM) THEN
  304. JESIMU=1
  305. ENDIF
  306. NPARA=MLMOT2.MOTS(/2)-JESIMU
  307. IF (ITE1.EQ.0) THEN
  308. ITE1=NPARA
  309. IF (ITE1.GT.JGM) THEN
  310. JGM=NPARA
  311. SEGADJ,MLMOT1
  312. ENDIF
  313. DO 19 IP=1,NPARA
  314. JP=IP+JESIMU
  315. MLMOT1.MOTS(IP)=MLMOT2.MOTS(JP)
  316. 19 CONTINUE
  317. ELSE
  318. DO 20 IP=1,NPARA
  319. NOMCHT = MLMOT2.MOTS(IP+JESIMU)
  320. DO 21 IU=1,ITE1
  321. IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 20
  322. 21 CONTINUE
  323. ITE1=ITE1+1
  324. IF (ITE1.GT.JGM) THEN
  325. JGM=JGM+20
  326. SEGADJ,MLMOT1
  327. ENDIF
  328. MLMOT1.MOTS(ITE1)=NOMCHT
  329. 20 CONTINUE
  330. ENDIF
  331. SEGDES,MLMOT2
  332. SEGDES,MELVAL
  333. C
  334. ELSE IF (ICAS.EQ.2) THEN
  335. C
  336. NOMCHT = NOMCHE(I2)
  337. DO 22 IU=1,ITE1
  338. IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 23
  339. 22 CONTINUE
  340. ITE1=ITE1+1
  341. IF (ITE1.GT.JGM) THEN
  342. JGM=JGM+20
  343. SEGADJ,MLMOT1
  344. ENDIF
  345. MLMOT1.MOTS(ITE1)=NOMCHT
  346. 23 CONTINUE
  347. C
  348. ENDIF
  349. C
  350. *-------- Cas d'une table
  351. ELSE IF (TYPCHE(I2).EQ.'POINTEURTABLE') THEN
  352. C
  353. IF (ICAS.EQ.1) THEN
  354. C
  355. MELVAL=IELVAL(I2)
  356. SEGACT,MELVAL
  357. N2PTEL=IELCHE(/1)
  358. N2EL=IELCHE(/2)
  359. C
  360. C La Table contient un LISTMOTS qui donne les
  361. C noms des variables dont depend
  362. C la composante, dans l'optique d'une evaluation de la
  363. C composante par une fonction externe.
  364. C HYPOTHESE de CHAMP UNIFORME : la composante depend
  365. C des memes variables en tout point d'integration de
  366. C tout element de la sous-zone.
  367. C Cette hypothese est necessaire car la composante ne
  368. C peut etre associee qu'a une seule fonction externe.
  369. C EN CONFORMITE AVEC VARINU.eso
  370. C
  371. IF (N2PTEL.NE.1.AND.N2EL.NE.1) THEN
  372. MOTERR(1:8)=NOMCHE(I2)
  373. CALL ERREUR(953)
  374. SEGDES,MELVAL
  375. SEGDES,MCHAML
  376. GOTO 9000
  377. ENDIF
  378. MTAB1=IELCHE(1,1)
  379. SEGACT,MTAB1
  380. if (NBESC.NE.0) SEGACT IPILOC
  381. C Recherche de la liste de mots à ouvrir
  382. ivar = 0
  383. DO 630 IN=1,MTAB1.MLOTAB
  384. if (mtab1.mtabti(in).ne.'MOT') goto 630
  385. IP=MTAB1.MTABII(IN)
  386. IDEBCH=IPCHAR(IP)
  387. IFINCH=IPCHAR(IP+1)-1
  388. IF (ICHARA(IDEBCH:IFINCH).EQ.'VARIABLES') IVAR=IN
  389. 630 CONTINUE
  390. if (ivar.eq.0) GOTO 631
  391. MLMOT2=MTAB1.MTABIV(IVAR)
  392. SEGACT,MLMOT2
  393. JESIMU=0
  394. IF(MLMOT2.MOTS(1)(1:4).EQ.MOTSIM) THEN
  395. JESIMU=1
  396. ENDIF
  397. NPARA=MLMOT2.MOTS(/2)-JESIMU
  398. IF (ITE1.EQ.0) THEN
  399. ITE1=NPARA
  400. IF (NPARA.GT.JGM) THEN
  401. JGM=NPARA
  402. SEGADJ,MLMOT1
  403. ENDIF
  404. DO 29 IP=1,NPARA
  405. JP=IP+JESIMU
  406. MLMOT1.MOTS(IP)=MLMOT2.MOTS(JP)
  407. 29 CONTINUE
  408. ELSE
  409. DO 30 IP=1,NPARA
  410. NOMCHT = MLMOT2.MOTS(IP+JESIMU)
  411. DO 31 IU=1,ITE1
  412. IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GOTO 30
  413. 31 CONTINUE
  414. ITE1=ITE1+1
  415. IF (ITE1.GT.JGM) THEN
  416. JGM=JGM+20
  417. SEGADJ,MLMOT1
  418. ENDIF
  419. MLMOT1.MOTS(ITE1)=NOMCHT
  420. 30 CONTINUE
  421. ENDIF
  422. SEGDES,MLMOT2
  423. 631 CONTINUE
  424. if (NBESC.NE.0) SEGDES IPILOC
  425. SEGDES,MTAB1
  426. SEGDES,MELVAL
  427. C
  428. ELSE IF (ICAS.EQ.2) THEN
  429. C
  430. NOMCHT =NOMCHE(I2)
  431. DO 32 IU=1,ITE1
  432. IF (MLMOT1.MOTS(IU).EQ.NOMCHT) GO TO 33
  433. 32 CONTINUE
  434. ITE1=ITE1+1
  435. IF (ITE1.GT.JGM) THEN
  436. JGM=JGM+20
  437. SEGADJ,MLMOT1
  438. ENDIF
  439. MLMOT1.MOTS(ITE1)=NOMCHT
  440. 33 CONTINUE
  441. C
  442. ENDIF
  443. C
  444. *-------- le type de la composante du mchaml est incorrect ----------
  445. ELSE
  446. MOTERR(1:8) = NOMCHE(I2)
  447. CALL ERREUR(679)
  448. SEGDES MCHAML
  449. GOTO 9000
  450. END IF
  451.  
  452. 2 CONTINUE
  453. SEGDES MCHAML
  454. 1 CONTINUE
  455.  
  456. IF (ITE1.NE.JGM) THEN
  457. JGM = ITE1
  458. SEGADJ MLMOT1
  459. ENDIF
  460.  
  461. 9000 CONTINUE
  462. IF (IERR.NE.0) THEN
  463. SEGSUP,MLMOT1
  464. ILISR = 0
  465. ELSE
  466. SEGDES,MLMOT1
  467. ILISR = MLMOT1
  468. ENDIF
  469. SEGDES MCHELM
  470.  
  471. RETURN
  472. END
  473.  
  474.  
  475.  
  476.  
  477.  

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