Télécharger reduaf.eso

Retour à la liste

Numérotation des lignes :

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

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