Télécharger excha1.eso

Retour à la liste

Numérotation des lignes :

  1. C EXCHA1 SOURCE CB215821 18/09/13 21:15:36 9917
  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. C 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. C SEGDES MEVOL1
  117. C SEGDES MNUAGE
  118. C SEGDES MELVAL
  119. C 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. C SEGDES MEVOL1
  127. C SEGDES MNUAGE
  128. C SEGDES MELVAL
  129. C SEGDES MCHAML
  130. GOTO 9000
  131. ENDIF
  132. KEVOL1=MEVOL1.IEVOLL(1)
  133. C 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. C SEGDES KEVOL1
  142. C SEGDES MNUAGE
  143. C SEGDES MELVAL
  144. C SEGDES MCHAML
  145. GOTO 9000
  146. ENDIF
  147. NOMVXT=KEVOL1.NOMEVX(1:8)
  148. C 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. C SEGDES MNUAGE
  183. C SEGDES MELVAL
  184. C SEGDES MCHAML
  185. GOTO 9000
  186. ENDIF
  187. C SEGDES MNUAGE
  188. 4 CONTINUE
  189. 3 CONTINUE
  190. C 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. C 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. C SEGDES KEVOLL
  253. C SEGDES MELVAL
  254. C SEGDES MCHAML
  255. GOTO 9000
  256. END IF
  257. C SEGDES KEVOLL
  258. 14 CONTINUE
  259. 13 CONTINUE
  260. C 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. C SEGDES,MELVAL
  297. C 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. C SEGDES,MLMOT2
  332. C 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. C SEGDES,MELVAL
  375. C 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 a 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. C SEGDES,MLMOT2
  423. 631 CONTINUE
  424. if (NBESC.NE.0) SEGDES,IPILOC
  425. SEGDES,MTAB1
  426. C 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. C SEGDES MCHAML
  449. GOTO 9000
  450. END IF
  451.  
  452. 2 CONTINUE
  453. C 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. C SEGDES MCHELM
  470.  
  471. RETURN
  472. END
  473.  
  474.  
  475.  
  476.  
  477.  
  478.  
  479.  

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