Télécharger reduaf.eso

Retour à la liste

Numérotation des lignes :

  1. C REDUAF SOURCE CB215821 17/10/18 21:15:08 9592
  2.  
  3. C Reduction du champ par element jchelm sur le modele mmodtm
  4. C Le resultat est le champ par element mchel2 pour iret = 1 (KERRE=0),
  5. C sinon en cas d'erreur mchel2 = 0 pour iret = 0 (KERRE = num. erreur)
  6. C En sortie le champ mchel2 est un champ entierement actif.
  7.  
  8. SUBROUTINE REDUAF (jchelm,mmodtm,mchel2,istri,iret,KERRE)
  9.  
  10. IMPLICIT REAL*8(A-H,O-Z)
  11. IMPLICIT INTEGER (I-N)
  12.  
  13. -INC CCOPTIO
  14.  
  15. -INC SMCHAML
  16. -INC SMMODEL
  17.  
  18. -INC SMCOORD
  19. -INC SMELEME
  20. -INC SMLENTI
  21. -INC CCPRECO
  22.  
  23. EXTERNAL LONG
  24.  
  25. segment izone(NZ,NSMOD)
  26. segment ismel(NZ,NSMOD)
  27.  
  28. segment icpr(nbpts)
  29. segment inde(jg)
  30.  
  31. CHARACTER*(NCONCH) conloc
  32. CHARACTER*(8) nomloc
  33. CHARACTER*(16) typloc
  34. CHARACTER*(50) typ1
  35.  
  36.  
  37. LOGICAL BDARCY
  38.  
  39. CG if (iimpi.eq.7203) then
  40. CG write(ioimp,*) 'Entree dans reduaf',mmodtm,jchelm
  41. CG call zpchel(jchelm,1)
  42. CG endif
  43.  
  44. iret = 1
  45. KERRE = 0
  46. mchel2 = 0
  47. BDARCY = .FALSE.
  48.  
  49. C -----------------------------------
  50. C Activation de tous les sous-modeles
  51. C -----------------------------------
  52. mmodel = mmodtm
  53.  
  54. SEGACT,mmodel
  55. melpv=0
  56. NSMOD = mmodel.kmodel(/1)
  57. DO is = 1, NSMOD
  58. imodel = mmodel.kmodel(is)
  59. SEGACT,imodel
  60. C Verification si on a un modele de DARCY actuellement incompatible
  61. C Car il se servent du MAILLAGE dans la TABLE DOMAINE et pas celui
  62. C contenu dans le MMODEL
  63. IDARC=0
  64. CALL PLACE(imodel.FORMOD,imodel.FORMOD(/2),IDARC,'DARCY')
  65. IF (IDARC .NE. 0) BDARCY = .TRUE.
  66. ENDDO
  67.  
  68. IF (BDARCY) THEN
  69. mchel2=jchelm
  70. C SEGACT complet de mchel2
  71. mchelm=mchel2
  72. segact,mchelm
  73. do j=1,ichaml(/1)
  74. mchaml=ichaml(j)
  75. segact,mchaml
  76. do k=1,ielval(/1)
  77. melval=ielval(k)
  78. if (melval.ne.melpv) then
  79. segact,melval
  80. melpv=melval
  81. endif
  82. enddo
  83. enddo
  84. RETURN
  85. ENDIF
  86.  
  87.  
  88. C ---------------------------------------------------------------------
  89. C Verification que le MCHAML n'est pas deja dans le CCPRECO
  90. C ---------------------------------------------------------------------
  91. ith = 0
  92. CALL ooonth(ith)
  93. ith1 = ith + 1
  94.  
  95. ITAILL = NBPRRE(ith1)
  96. DO 201 IPREC1 = 1, ITAILL
  97. IF (PRECMO(IPREC1,ith1) .NE. mmodtm) GOTO 201
  98. IF ((PRECM1(IPREC1,ith1) .EQ. jchelm) .OR.
  99. & (PRECM2(IPREC1,ith1) .EQ. jchelm)) THEN
  100. mchel2 = PRECM2(IPREC1,ith1)
  101. C IF ((PRECM1(IPREC1,ith1) .EQ. jchelm)) THEN
  102. C PRINT *,'REDUAF',ith,'DEJA en MEMOIRE 1',IPREC1
  103. C ELSE
  104. C PRINT *,'REDUAF',ith,'DEJA en MEMOIRE 2',IPREC1
  105. C ENDIF
  106. C IF (IPREC1 .EQ. NPREDU) THEN
  107. C PRINT *,' CCPRECO trop petit :',IPREC1
  108. C CALL ERREUR(5)
  109. C ENDIF
  110. C CALL TRBAC
  111. C Mise a jour du preconditionnement dans CCPRECO : Deplacement en position 1
  112. IF (IPREC1 .EQ. 1) RETURN
  113. DO IPREC2 = IPREC1,2,-1
  114. PRECMO(IPREC2,ith1) = PRECMO(IPREC2 - 1,ith1)
  115. PRECM1(IPREC2,ith1) = PRECM1(IPREC2 - 1,ith1)
  116. PRECM2(IPREC2,ith1) = PRECM2(IPREC2 - 1,ith1)
  117. ENDDO
  118. PRECMO(1,ith1) = mmodtm
  119. PRECM1(1,ith1) = jchelm
  120. PRECM2(1,ith1) = mchel2
  121.  
  122. C SEGACT complet de mchel2
  123. mchelm=mchel2
  124. C PRINT *,mchelm
  125. segact,mchelm
  126. do j=1,ichaml(/1)
  127. mchaml=ichaml(j)
  128. segact,mchaml
  129. do k=1,ielval(/1)
  130. melval=ielval(k)
  131. if (melval.ne.melpv) then
  132. segact,melval
  133. melpv=melval
  134. endif
  135. enddo
  136. enddo
  137. RETURN
  138. ENDIF
  139. 201 CONTINUE
  140.  
  141. C 1 CONTINUE
  142.  
  143. C Mise a jour du preconditionnement dans CCPRECO
  144. C Glissement des valeurs vers le bas
  145. ITAILL = MIN(ITAILL + 1, NPREDU)
  146. NBPRRE(ith1) = ITAILL
  147. C PRINT *,'REDUAF : On a sauve ', ITH, ITAILL,' TRIPLETS'
  148. DO IPRECO = ITAILL,2,-1
  149. PRECMO(IPRECO,ith1) = PRECMO(IPRECO - 1,ith1)
  150. PRECM1(IPRECO,ith1) = PRECM1(IPRECO - 1,ith1)
  151. PRECM2(IPRECO,ith1) = PRECM2(IPRECO - 1,ith1)
  152. ENDDO
  153. PRECMO(1,ith1) = mmodtm
  154. PRECM1(1,ith1) = jchelm
  155.  
  156. mchelm = jchelm
  157. SEGACT,mchelm
  158. NZ = mchelm.imache(/1)
  159. L1 = mchelm.titche(/1)
  160. N3 = mchelm.infche(/2)
  161.  
  162. C -----------------------------------------
  163. C Cas tres particulier de MCHELM resultat :
  164. C -----------------------------------------
  165. IF (NZ.EQ.0) THEN
  166. CG if (iimpi.eq.7203) write(ioimp,*) 'CAS PARTICULIER NZ = 0'
  167. SEGINI,mchel2=mchelm
  168. C* SEGDES,mchelm
  169. C// SEGDES,mchel2
  170.  
  171. C Mise a jour du preconditionnement dans CCPRECO (Nouveau champ mchel2)
  172. PRECM2(1,ith1) = mchel2
  173. C PRINT *,'REDUAF',ith,mmodtm,jchelm,'PAS en MEMOIRE',mchel2
  174. RETURN
  175. ENDIF
  176.  
  177. C Cas formulation melange: on ajoute les modeles de phases en les activant
  178. nvim = 0
  179. IF (istri.NE.1) THEN
  180. DO is = 1, NSMOD
  181. imodel = kmodel(is)
  182. if (formod(1).EQ.'MELANGE') nvim = nvim + ivamod(/1)
  183. ENDDO
  184. IF (nvim.ne.0) THEN
  185. n1 = NSMOD + nvim
  186. SEGINI,mmode1
  187. nc = 0
  188. DO is = 1, NSMOD
  189. nc = nc + 1
  190. imodel = kmodel(is)
  191. mmode1.kmodel(nc) = imodel
  192. IF (formod(1).EQ.'MELANGE') then
  193. DO j = 1, ivamod(/1)
  194. IF (tymode(j).NE.'IMODEL') THEN
  195. KERRE = 21
  196. ELSE
  197. imode1 = ivamod(j)
  198. SEGACT,imode1
  199. nc = nc + 1
  200. mmode1.kmodel(nc) = imode1
  201. ENDIF
  202. ENDDO
  203. ENDIF
  204. ENDDO
  205. NSMOD = nc
  206. mmodel = mmode1
  207. IF (KERRE.NE.0) GOTO 9010
  208. ENDIF
  209. ENDIF
  210.  
  211. C Quelques initialisations :
  212. SEGINI,izone,ismel
  213. C mlent2 contient le nombre d'elements du maillage de chaque sous-modele.
  214. jg = NSMOD
  215. SEGINI,mlent2
  216. C mlent3 contient les intersections entre les maillages determinees :
  217. C mlent3.lect(i3) avec ismel(iz,is) = i3 correspond a l'intersection
  218. C entre le maillage du sous-modele is et la sous-zone iz du champ si
  219. C la valeur de i3 n'est pas nulle !
  220. jg = NSMOD * NZ
  221. SEGINI,mlent3
  222. NL3 = 0
  223. ISOZM = 0
  224.  
  225. C? SEGACT,mcoord
  226. nbpts = mcoord.xcoor(/1) / (idim+1) + 1
  227. np1 = nbpts - 1
  228. icpr = 0
  229. inde = 0
  230. C
  231. C Regroupement des zones directement appariees avec un sous-modele
  232. C Recherche des zones pouvant intersecter le maillage d'un sous-modele
  233. DO 100 is = 1, NSMOD
  234. imodel = mmodel.kmodel(is)
  235. IF (imodel.nefmod.EQ.22) GOTO 100
  236. IF (imodel.nefmod.EQ.259) GOTO 100
  237. meleme = imodel.imamod
  238. SEGACT,meleme
  239. itypm = meleme.itypel
  240. mlent2.lect(is) = meleme.num(/2)
  241. C On parcourt tous les NZ chamelem elementaires.
  242. DO 101 iz = 1, NZ
  243. conloc = mchelm.conche(iz)
  244. IF (conloc.NE.' ' .AND. conloc.NE.imodel.conmod) GOTO 101
  245. ixx = 0
  246. ipt1 = mchelm.imache(iz)
  247. C Correspondance maillage sous-zone et sous-modele
  248. IF (ipt1.EQ.meleme) THEN
  249. ixx = 1
  250. C Pas de correspondance directe, recherche intersection potentielle
  251. ELSE
  252. SEGACT,ipt1
  253. IF (ipt1.itypel.NE.itypm) GOTO 102
  254. C Verification dans le PRECONDITIONNEMENT si deja evaluee
  255. DO III=1,NTRIPL
  256. IF (PMAMOD(III,ith1) .EQ. meleme) THEN
  257. IF (PMACHA(III,ith1) .EQ. ipt1) THEN
  258. mlenti=PMLENT(III,ith1)
  259. C PRINT *,'REDUAF_PRECONDITION',ith,meleme,ipt1,mlenti
  260.  
  261. IF(mlenti .EQ. 0) THEN
  262. ixx = 0
  263. ismel(iz,is) = 0
  264.  
  265. ELSE
  266. NL3 = NL3 + 1
  267. mlent3.lect(NL3) = mlenti
  268. ixx = -1
  269. ismel(iz,is) = NL3
  270. ENDIF
  271. GOTO 102
  272. ENDIF
  273. ENDIF
  274. ENDDO
  275.  
  276. C PRINT *,'REDUAF_INTERSECTION',ith,meleme,ipt1
  277.  
  278. C On va regarder si on n a pas deja evalue l'intersection :
  279. C (meme sous-modele is et sous-zone precedente ia<iz)
  280. DO ia = 1, iz-1
  281. IF (ipt1.EQ.mchelm.imache(ia)) THEN
  282. IF (ismel(ia,is).GT.0) THEN
  283. ixx = -2
  284. ismel(iz,is) = ismel(ia,is)
  285. GOTO 102
  286. ENDIF
  287. ENDIF
  288. ENDDO
  289. C (meme sous-zone iz et sous-modele ia<is)
  290. DO 103 ia = 1, is-1
  291. imode2 = mmodel.kmodel(ia)
  292. IF (imode2.nefmod.EQ.22) GOTO 103
  293. IF (imode2.nefmod.EQ.259) GOTO 103
  294. ipt2 = imode2.imamod
  295. IF (ipt2.EQ.meleme) THEN
  296. IF (ismel(iz,ia).GT.0) THEN
  297. ixx = -3
  298. ismel(iz,is) = ismel(iz,ia)
  299. GOTO 102
  300. ENDIF
  301. ENDIF
  302. 103 CONTINUE
  303.  
  304.  
  305. C Détermination de l'intersection de ipt1 et meleme :
  306. C Creation d'un tableau (LISTENTI) de correspondance des
  307. C elements de IPT1 qui sont dans MELEME
  308. nbno1 = ipt1.num(/1)
  309. nbel1 = ipt1.num(/2)
  310. IF (icpr.EQ.0) THEN
  311. SEGINI,icpr
  312. ELSE
  313. DO j = 1, nbpts
  314. icpr(j) = 0
  315. ENDDO
  316. ENDIF
  317. DO j = 1, nbel1
  318. DO m = 1, nbno1
  319. ib = ipt1.num(m,j)
  320. icpr(ib) = icpr(ib) + 1
  321. ENDDO
  322. ENDDO
  323. iprec = icpr(1)
  324. DO j = 2, np1
  325. iprec = iprec + icpr(j)
  326. icpr(j) = iprec
  327. ENDDO
  328. jg = icpr(np1)
  329. icpr(nbpts) = jg
  330. IF (inde.EQ.0) THEN
  331. SEGINI,inde
  332. ELSE
  333. IF (jg.GT.inde(/1)) THEN
  334. SEGADJ,inde
  335. ENDIF
  336. DO j = 1, jg
  337. inde(j) = 0
  338. ENDDO
  339. ENDIF
  340. DO j = 1, nbel1
  341. DO m = 1, nbno1
  342. ib = ipt1.num(m,j)
  343. ia = icpr(ib)
  344. inde(ia) = j
  345. icpr(ib) = ia - 1
  346. ENDDO
  347. ENDDO
  348.  
  349.  
  350. C Fin du travail preparatoire pour le maillage ipt1
  351. ipt2 = imodel.imamod
  352. nbno2 = ipt2.num(/1)
  353. nbel2 = ipt2.num(/2)
  354. c* ipt2 = imodel.imamod = meleme
  355. c* nbno2 = ipt2.num(/1) = nbno1
  356. c* nbel2 = ipt2.num(/2) = mlent2.lect(is)
  357.  
  358.  
  359. C on fabrique le mlenti de correspondance
  360. C on dimensionne au nombre d elements de ipt2 = sous-modele is
  361. jg = nbel2
  362. SEGINI,mlenti
  363. ibon = 0
  364. DO 110 iel2 = 1, nbel2
  365. ia = ipt2.num(1,iel2)
  366. ideb = icpr(ia)+1
  367. ifin = icpr(ia+1)
  368. IF (ifin.LT.ideb) GOTO 110
  369. DO 111 ib = ideb, ifin
  370. iel1 = inde(ib)
  371. DO j = 1, nbno1
  372. IF (ipt2.num(j,iel2).NE.ipt1.num(j,iel1)) GOTO 111
  373. ENDDO
  374. ibon = ibon + 1
  375. mlenti.lect(iel2) = iel1
  376. GOTO 110
  377. 111 CONTINUE
  378. 110 CONTINUE
  379.  
  380. IF (ibon .EQ. 0) THEN
  381. C Intersection VIDE entre MELEME et IPT1
  382. ixx = 0
  383. ismel(iz,is) = 0
  384. SEGSUP,mlenti
  385.  
  386. ELSE
  387. C Intersection NON VIDE entre MELEME et IPT1
  388. IF (ibon.GT.nbel1) THEN
  389. C Si on a plus d'elements dans l'intersection que dans ipt1 !
  390. write(ioimp,*) 'REDUAF : Etiquette 11x intersection ?'
  391. ENDIF
  392. NL3 = NL3 + 1
  393. mlent3.lect(NL3) = mlenti
  394. C Retrait du *MOD
  395. SEGACT,mlenti
  396. ixx = -1
  397. ismel(iz,is) = NL3
  398. ENDIF
  399.  
  400.  
  401. C Ajout dans le PRECONDITIONNEMENT : Ajout a la suite
  402. IPLACE=MOD(NINTSA(ith1),NTRIPL)+1
  403. C PRINT *,'REDUAF_AJOUT',ith,IPLACE,meleme,ipt1,mlenti
  404. PMAMOD(IPLACE,ith1) = meleme
  405. PMACHA(IPLACE,ith1) = ipt1
  406. PMLENT(IPLACE,ith1) = mlenti
  407. NINTSA(ith1) = IPLACE
  408. IF(ith .eq. 1) CALL OOOSUR(mlenti)
  409. ENDIF
  410. CG write(*,*) ' -',iz,is,ixx,ismel(iz,is)
  411.  
  412.  
  413. 102 CONTINUE
  414.  
  415. C Sous-zone du mchelm a traiter
  416. IF (ixx .NE. 0) THEN
  417. DO 105 ia = 1, iz-1
  418. ib = izone(ia,is)
  419. IF (ib.EQ.0) GOTO 105
  420. IF (conche(ia).NE.conloc) GOTO 105
  421. DO k = 1, N3
  422. IF (k.NE.4) THEN
  423. IF (infche(ia,k).NE.infche(iz,k)) GOTO 105
  424. ENDIF
  425. ENDDO
  426. izone(iz,is) = ib
  427. GOTO 106
  428. 105 CONTINUE
  429. ISOZM = ISOZM + 1
  430. izone(iz,is) = ISOZM
  431. 106 CONTINUE
  432. ENDIF
  433. CG write(*,*) ' -',iz,is,ixx,izone(iz,is)
  434. 101 CONTINUE
  435. C* SEGDES,meleme
  436. 100 CONTINUE
  437.  
  438. IF (icpr.NE.0) SEGSUP,icpr
  439. IF (inde.NE.0) SEGSUP,inde
  440.  
  441.  
  442.  
  443.  
  444. C ---------------------------------
  445. C Construction du MCHELM resultat :
  446. C ---------------------------------
  447. C Grace au traitement ci-dessus (boucle 105), ISOZM correspond a N1 :
  448. N1 = ISOZM
  449. L1 = mchelm.titche(/1)
  450. N3 = mchelm.infche(/2)
  451. SEGINI,mchel2
  452. mchel2.titche = mchelm.titche
  453. mchel2.ifoche = mchelm.ifoche
  454.  
  455. C Pour chaque sous-modele "is", on regroupe les sous-zones du mchelm "iz"
  456. C associees (izone(iz,is) > 0) :
  457. DO 200 is = 1, NSMOD
  458. imodel = kmodel(is)
  459. IF (imodel.nefmod.EQ.22) GOTO 200
  460. IF (imodel.nefmod.EQ.259) GOTO 200
  461. ipt2 = imodel.imamod
  462. nbel2 = mlent2.lect(is)
  463.  
  464. DO 210 iz = 1, NZ
  465. in1 = izone(iz,is)
  466. IF (in1.LE.0) GOTO 210
  467. mchaml = mchelm.ichaml(iz)
  468.  
  469. SEGACT,mchaml
  470. n21 = mchaml.ielval(/1)
  471.  
  472. C Cas particulier du mchaml sans composante (on ne fait rien) :
  473. IF (n21.EQ.0) GOTO 210
  474.  
  475. IF (mchel2.imache(in1).EQ.0) THEN
  476. CG write(ioimp,*) ' Cas 1 :',mchel2.imache(in1)
  477. mchel2.conche(in1) = mchelm.conche(iz)
  478. mchel2.imache(in1) = ipt2
  479. DO k = 1, N3
  480. mchel2.infche(in1,k) = mchelm.infche(iz,k)
  481. ENDDO
  482. n22 = 0
  483. n2 = n22 + n21
  484. SEGINI,mcham2
  485. mchel2.ichaml(in1) = mcham2
  486. ELSE
  487. CG write(ioimp,*) ' Cas 2 :',mchel2.imache(in1)
  488. mcham2 = mchel2.ichaml(in1)
  489. n22 = mcham2.ielval(/1)
  490. n2 = n22 + n21
  491. SEGADJ,mcham2
  492. ENDIF
  493.  
  494. mlenti = ismel(iz,is)
  495. IF (mlenti.GT.0) mlenti = mlent3.lect(mlenti)
  496. CG write(ioimp,*) ' :',iz,is,mlenti,n22,n21,n2
  497. DO i = 1, n21
  498. nomloc = mchaml.nomche(i)
  499. iplac = 0
  500. IF (n22.NE.0) THEN
  501. CALL PLACE(mcham2.nomche(1),n22,iplac,nomloc)
  502. ENDIF
  503. typloc = mchaml.typche(i)
  504. melval = mchaml.ielval(i)
  505. if (melval.ne.melpv) then
  506. segact,melval
  507. melpv=melval
  508. endif
  509. nbpi1 = MAX(melval.velche(/1),melval.ielche(/1))
  510. nbel1 = MAX(melval.velche(/2),melval.ielche(/2))
  511. IF (nbel1.GT.1) nbel1 = nbel2
  512.  
  513. IF (iplac.EQ.0) THEN
  514. iplac = n22 + i
  515. mcham2.nomche(iplac) = nomloc
  516. mcham2.typche(iplac) = typloc
  517. IF (typloc.EQ.'REAL*8 ') THEN
  518. n1ptel = nbpi1
  519. n1el = nbel2
  520. n2ptel = 0
  521. n2el = 0
  522. ELSE
  523. n1ptel = 0
  524. n1el = 0
  525. n2ptel = nbpi1
  526. n2el = nbel2
  527. ENDIF
  528. SEGINI,melva2
  529. mcham2.ielval(iplac) = melva2
  530.  
  531. ELSE
  532. C incompatibilite du type de composante entre champs
  533. IF (mcham2.typche(iplac).NE.typloc) THEN
  534. KERRE = 917
  535. MOTERR(1:4) = nomloc
  536. MOTERR(5:21) = typloc
  537. MOTERR(22:38) = mcham2.typche(iplac)
  538. GOTO 9000
  539. ENDIF
  540. melva2 = mcham2.ielval(iplac)
  541. SEGACT,melva2*MOD
  542. ENDIF
  543.  
  544. C On ajoute melval a melva2 en tenant compte de l'intersection entre
  545. C les maillages (mlenti = 0 si maillage identique, >0 sinon)
  546. C "Extension" de melva2 si besoin par rapport a melval (appel a MELEXT)
  547. C sera effectuee en prealable de l'addition des valeurs dans MELADD.
  548. CALL MELADD(melva2,melval,typloc,mlenti,KERRE)
  549. C* SEGDES,melval
  550. IF (KERRE.NE.0) GOTO 9000
  551. ENDDO
  552. C
  553. 210 CONTINUE
  554. 200 CONTINUE
  555.  
  556. C Compactage du champ resultat :
  557. C ------------------------------
  558. n1max = n1
  559. n1 = 0
  560. melp2=0
  561. DO 310 i = 1, n1max
  562. mcham2 = mchel2.ichaml(i)
  563. IF (mcham2.EQ.0) GOTO 310
  564. C on compacte les composantes (s'il y en a bien sur !)
  565. n22 = mcham2.ielval(/1)
  566. IF (n22.EQ.0) GOTO 312
  567. n2 = 0
  568. DO 311 j = 1, n22
  569. melva2 = mcham2.ielval(j)
  570. IF (melva2.EQ.0) GOTO 311
  571. if (melva2.ne.melp2) then
  572. CALL COMRED(melva2)
  573. melp2=melva2
  574. endif
  575. n2 = n2 + 1
  576. mcham2.nomche(n2) = mcham2.nomche(j)
  577. mcham2.typche(n2) = mcham2.typche(j)
  578. mcham2.ielval(n2) = melva2
  579. C// segdes,melva2
  580. 311 CONTINUE
  581. IF (n2.EQ.0) GOTO 310
  582. IF (n2.NE.n22) SEGADJ,mcham2
  583. 312 CONTINUE
  584. C// segdes,mcham2
  585. n1 = n1 + 1
  586. mchel2.conche(n1) = mchel2.conche(i)
  587. mchel2.imache(n1) = mchel2.imache(i)
  588. mchel2.ichaml(n1) = mcham2
  589.  
  590. DO j = 1, N3
  591. mchel2.infche(n1,j) = mchel2.infche(i,j)
  592. ENDDO
  593. 310 CONTINUE
  594. IF (n1.NE.n1max) SEGADJ,mchel2
  595.  
  596.  
  597. C Definition du type du MCHAML
  598. C typ1 contient le nom du type identifie
  599. C ltyp1 la longueur de la chaine de caractere
  600. C
  601. CALL TYPCHL(mchel2,mmodtm,typ1,ltyp1)
  602. IF (IERR.NE.0) RETURN
  603. C Cas particuliers des modeles de modele (melange)
  604. IF (ltyp1.EQ.-2) THEN
  605. ltyp1 = LONG(mchelm.titche)
  606. IF (ltyp1.eq.0) THEN
  607. ltyp1 = 1
  608. typ1 = ' '
  609. ELSE
  610. typ1 = mchelm.titche(1:ltyp1)
  611. ENDIF
  612. ENDIF
  613. c write(6,*) 'Dans reduaf: ltyp1,typ1 =',ltyp1,typ1(1:ltyp1)
  614.  
  615. N1=mchel2.IMACHE(/1)
  616. N3=mchel2.INFCHE(/2)
  617. L1=ltyp1
  618. SEGADJ, mchel2
  619. mchel2.titche=typ1(1:ltyp1)
  620. C// segdes,mchel2
  621.  
  622. C On sort un champ vide s'il n'y a pas de zone commune :
  623. c* IF (n1.EQ.0) THEN
  624. c**G if (iimpi.eq.7203) write(ioimp,*) 'N1 = 0 apres traitement'
  625. c* KERRE = 21
  626. c* ENDIF
  627.  
  628. 9000 CONTINUE
  629. C Destruction des segments de travail devenus inutiles :
  630. SEGSUP,izone,ismel,mlent3,mlent2
  631.  
  632. 9010 CONTINUE
  633. C Desactivation des entrees : modele et chamelem
  634. C CB215821 : On laisse ouvert le MMODEL et les IMODEL en sortie
  635. C DO i = 1, NSMOD
  636. C imodel = kmodel(i)
  637. C SEGDES,imodel
  638. C ENDDO
  639. IF (nvim.NE.0) SEGSUP,mmodel
  640. C mmodel = mmodtm
  641. C SEGDES,mmodel
  642.  
  643. C* SEGDES,mchelm
  644.  
  645. IF (KERRE.NE.0) THEN
  646. iret = 0
  647. mchel2 = 0
  648. ENDIF
  649.  
  650. CG if (iimpi.eq.7203) then
  651. CG write(ioimp,*) 'Sortie de reduaf',mchel2,kerre
  652. CG if (kerre.eq.0) call zpchel(mchel2,1)
  653. CG endif
  654.  
  655. C Mise a jour du preconditionnement dans CCPRECO (Nouveau champ mchel2)
  656. PRECM2(1,ith1) = mchel2
  657.  
  658. C PRINT *,'REDUAF',ith,mmodtm,jchelm,'PAS en MEMOIRE',mchel2
  659. RETURN
  660. END
  661.  
  662.  
  663.  

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