Télécharger invaca.eso

Retour à la liste

Numérotation des lignes :

  1. C INVACA SOURCE GG250959 17/09/20 21:15:40 9554
  2.  
  3. SUBROUTINE INVACA(IPMODL,IPCHE1,IPCHE2,IPCHE3,IPCHE4,IPCHE5,
  4. & IMIL,IRET)
  5.  
  6. *---------------------------------------------------------------------
  7. *
  8. * CALCUL DES 3 INVARIANTS D'UN TENSEUR D'ORDRE 2
  9. * (APPELE PAR INVARI)
  10. *
  11. * ENTREES:
  12. * --------
  13. *
  14. * IPMODL POINTEUR SUR UN MMODEL
  15. * IPCHE1 POINTEUR SUR UN CHAMELEM DE CONTRAINTES OU DEFORMATIONS
  16. * (TYPE MCHAML)
  17. * IPCHE5 POINTEUR SUR UN CHAMELEM DE CARACTERISTIQUES
  18. * (TYPE MCHAML)
  19. * IMIL INDICATEUR OU ON CALCULE LES CONTRAINTES POUR
  20. * LES COQUES
  21. *
  22. * SORTIES :
  23. * ---------
  24. *
  25. * IPCHE2 POINTEUR SUR UN CHAMELEM STRESSES ( I1)
  26. * IPCHE3 POINTEUR SUR UN CHAMELEM STRESSES ( I2 )
  27. * IPCHE4 POINTEUR SUR UN CHAMELEM STRESSES ( I3 )
  28. * IRET =1 OU 0 SUIVANT SUCCES OU PAS
  29. *
  30. * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 12/90
  31. *
  32. *---------------------------------------------------------------------
  33. *
  34. IMPLICIT INTEGER(I-N)
  35. IMPLICIT REAL*8(A-H,O-Z)
  36.  
  37. -INC CCOPTIO
  38. -INC CCHAMP
  39.  
  40. -INC SMCHAML
  41. -INC SMMODEL
  42.  
  43. SEGMENT NOTYPE
  44. CHARACTER*16 TYPE(NBTYPE)
  45. ENDSEGMENT
  46. *
  47. SEGMENT MPTVAL
  48. INTEGER IPOS(NS) ,NSOF(NS)
  49. INTEGER IVAL(NCOSOU)
  50. CHARACTER*16 TYVAL(NCOSOU)
  51. ENDSEGMENT
  52. *
  53. PARAMETER ( NINF=3 )
  54. INTEGER INFOS(NINF)
  55. CHARACTER*(NCONCH) CONM
  56. LOGICAL lsupno
  57. *
  58. DIMENSION SIG(9)
  59.  
  60. *------ Fin des déclarations ------------------------------------
  61.  
  62. IRET = 0
  63. IPCHE2 = 0
  64. IPCHE3 = 0
  65. IPCHE4 = 0
  66. *
  67. * Reduction des MCHAMLs sur le MODELE
  68. *
  69. kerre = 0
  70. *
  71. CALL REDUAF(IPCHE1,IPMODL,ipch,0,ir,kerre)
  72. IF (ir.NE.1) CALL ERREUR(kerre)
  73. IF (IERR.NE.0) RETURN
  74. IPCHE1 = ipch
  75. *
  76. IF (IPCHE5.NE.0) THEN
  77. CALL REDUAF(IPCHE5,IPMODL,ipch,0,ir,kerre)
  78. IF (ir.NE.1) CALL ERREUR(kerre)
  79. IF (IERR.NE.0) RETURN
  80. IPCHE5 = ipch
  81. ENDIF
  82. *
  83. * Verification du type de IPCHE1 !
  84. *
  85. MCHELM = IPCHE1
  86. SEGACT,MCHELM
  87. IF (TITCHE.EQ.'CONTRAINTES') THEN
  88. ICONTR = 1
  89. W1 = 2.D0
  90. W2 = 1.D0
  91. W3 = 2.D0
  92. ELSE IF (TITCHE.EQ.'DEFORMATIONS') THEN
  93. ICONTR = 0
  94. W1 = 0.5D0
  95. W2 = 0.25D0
  96. W3 = 0.25D0
  97. ELSE
  98. MOTERR(1:8)='CONTRAIN'
  99. MOTERR(9:16)='DEFORMAT'
  100. CALL ERREUR(109)
  101. GOTO 666
  102. ENDIF
  103. *
  104. * Verification du lieu support des mchamls
  105. *
  106. CALL QUESUP(IPMODL,IPCHE1,0,0,iret1,ISUP1)
  107. IF (IERR.NE.0) GOTO 666
  108. *
  109. IPCH5O = IPCHE5
  110. IF (IPCHE5.NE.0) THEN
  111. CALL QUESUP(IPMODL,IPCH5O,ISUP1,0,ISUP5,iret5)
  112. IF (ISUP5.GT.1) GOTO 666
  113. IF (IERR.NE.0) GOTO 666
  114. C Le support des caractéristiques est différent de celui de IPCHE1
  115. IF (ISUP5.NE.0) THEN
  116. CALL CHASUP(IPMODL,IPCH5O,IPCHE5,irecar,ISUP1)
  117. IF (irecar.NE.0) GOTO 666
  118. ENDIF
  119. ENDIF
  120. *
  121. * Activation et verification du modele
  122. *
  123. MMODEL = IPMODL
  124. SEGACT,MMODEL
  125. NSOUS = KMODEL(/1)
  126. KEL22 = 0
  127. DO ISOUS = 1, NSOUS
  128. IMODEL=KMODEL(ISOUS)
  129. SEGACT,IMODEL
  130. IF (FORMOD(1).NE.'MECANIQUE' .AND.
  131. & FORMOD(1).NE.'POREUX') THEN
  132. MOTERR(1:8) = FORMOD(1)
  133. CALL ERREUR(193)
  134. GOTO 666
  135. ENDIF
  136. IF ((NEFMOD.EQ.22).OR.(NEFMOD.EQ.259)) KEL22 = KEL22 + 1
  137. ENDDO
  138. *
  139. C ... Initialisation des trois nouveaux MCHELM - resultats ...
  140. N1 = NSOUS - KEL22
  141. L1 = 8
  142. N3 = 6
  143. *
  144. SEGINI MCHEL1
  145. MCHEL1.IFOCHE=IFOUR
  146. MCHEL1.TITCHE='SCALAIRE'
  147. *
  148. SEGINI MCHEL2
  149. MCHEL2.IFOCHE=IFOUR
  150. MCHEL2.TITCHE='SCALAIRE'
  151. *
  152. SEGINI MCHEL3
  153. MCHEL3.IFOCHE=IFOUR
  154. MCHEL3.TITCHE='SCALAIRE'
  155. *
  156. * Petit segment utile
  157. nbtype = 1
  158. SEGINI,notype
  159. type(1)='REAL*8'
  160. MOTYPE = notype
  161. *
  162. ISOUS = 0
  163. *
  164. * ... BOUCLE SUR LES SOUS ZONES DU MODELE ...
  165. *
  166. DO 200 JSOUS = 1, NSOUS
  167. *
  168. IMODEL = KMODEL(JSOUS)
  169. SEGACT,IMODEL
  170. *
  171. IPMAIL= IMAMOD
  172. CONM = CONMOD
  173. MELE = NEFMOD
  174. *
  175. iOK = 1
  176. IF ((MELE.EQ.22).OR.(MELE.EQ.259)) GOTO 210
  177. *
  178. iOK = 0
  179. *
  180. C ... COQUE INTEGREE OU NON ? ...
  181. IF (INFMOD(/1).NE.0) THEN
  182. NPINT = INFMOD(1)
  183. IF (NPINT.NE.0)THEN
  184. CALL ERREUR(615)
  185. GOTO 210
  186. ENDIF
  187. ELSE
  188. NPINT = 0
  189. ENDIF
  190. *
  191. * ... INITIALISATION ...
  192. *
  193. ISOUS = ISOUS + 1
  194. *
  195. IVACAR = 0
  196. IVACOM = 0
  197. MOCOMP = 0
  198. MOCARA = 0
  199. lsupno = .false.
  200. *
  201. * ... INFORMATION SUR L'ELEMENT FINI ...
  202. *
  203. MFR = INFELE(13)
  204. MINTE = INFMOD(2+ISUP1)
  205. NSTRS = INFELE(16)
  206. *
  207. * ... Verification de compatibilité des MCHAML du point de vue des
  208. * tableaux INFCHE et remplissage du tableau INFOS pour KOMCHA ...
  209. *
  210. CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE5,INFOS,IRTD)
  211. IF (IRTD.EQ.0) GOTO 210
  212. *
  213. * ... RECHERCHE DES NOMS de COMPOSANTES de CONTRAINTES/DEFORMATIONS...
  214. *
  215. IF (ICONTR.EQ.1) THEN
  216. IF (lnomid(4).NE.0) THEN
  217. MOCOMP = lnomid(4)
  218. ELSE
  219. lsupno = .true.
  220. CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  221. ENDIF
  222. ELSE
  223. IF (lnomid(5).NE.0) THEN
  224. MOCOMP = lnomid(5)
  225. ELSE
  226. lsupno = .true.
  227. CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC)
  228. ENDIF
  229. ENDIF
  230. nomid = MOCOMP
  231. SEGACT,nomid
  232. NCOMP = lesobl(/2)
  233. NFAC = lesfac(/2)
  234. *
  235. * ... VERIFICATION DE LEUR PRESENCE ...
  236. *
  237. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE,1,INFOS,3,IVACOM)
  238. IF (IERR.NE.0) GOTO 220
  239. *
  240. * ... TRAITEMENT DES CHAMPS DE CARACTERISTIQUES ...
  241. *
  242. nbrobl = 0
  243. nbrfac = 0
  244. nomid = 0
  245. * ... EPAISSEUR DANS LE CAS DES COQUES MINCES ...
  246. IF (MFR.EQ.3 .OR. MFR.EQ.9) THEN
  247. nbrobl = 1
  248. nbrfac = 0
  249. SEGINI,nomid
  250. lesobl(1) = 'EPAI'
  251. ENDIF
  252. *
  253. MOCARA = nomid
  254. NCARA = nbrobl
  255. NCARF = nbrfac
  256. NCARR = NCARA+NCARF
  257. *
  258. IF (MOCARA.NE.0 .AND. NCARA.GE.1) THEN
  259. IF (IPCHE5.NE.0) THEN
  260. C ... On vérifie si elle est présente dans le champ de
  261. C caractéristiques qui a été fourni ...
  262. CALL KOMCHA(IPCHE5,IPMAIL,CONM,MOCARA,MOTYPE,1,
  263. & INFOS,3,IVACAR)
  264. ELSE
  265. C ... S'il n'y a pas de champ de caractéristiques, on râle ...
  266. MOTERR(1:8)='CARACTER'
  267. MOTERR(9:12)=NOMTP(MELE)
  268. MOTERR(13:20)='INVA'
  269. CALL ERREUR(145)
  270. ENDIF
  271. IF (IERR.NE.0) GOTO 230
  272. ENDIF
  273. *
  274. C Creation des MELVAL de la zone élémentaire
  275. *
  276. * ... RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER ...
  277. *
  278. MPTVAL = IVACOM
  279. N1PTEL= 0
  280. N1EL = 0
  281. DO 110 ICOMP = 1, NCOMP
  282. MELVAL = IVAL(ICOMP)
  283. N1PTEL = MAX(N1PTEL,VELCHE(/1))
  284. N1EL = MAX(N1EL ,VELCHE(/2))
  285. 110 CONTINUE
  286. N2PTEL=0
  287. N2EL =0
  288. *
  289. SEGINI,MELVA1,MELVA2,MELVA3
  290. *
  291. * Création des MCHAML ...
  292. *
  293. N2 = 1
  294. SEGINI,MCHAM1
  295. SEGINI,MCHAM2
  296. SEGINI,MCHAM3
  297. *
  298. MCHAM1.NOMCHE(1)='SCAL'
  299. MCHAM1.TYPCHE(1)='REAL*8'
  300. MCHAM1.IELVAL(1)=MELVA1
  301. *
  302. MCHAM2.NOMCHE(1)='SCAL'
  303. MCHAM2.TYPCHE(1)='REAL*8'
  304. MCHAM2.IELVAL(1)=MELVA2
  305. *
  306. MCHAM3.NOMCHE(1)='SCAL'
  307. MCHAM3.TYPCHE(1)='REAL*8'
  308. MCHAM3.IELVAL(1)=MELVA3
  309. *
  310. * Remplissage des attributs de la sous-zone ...
  311. *
  312. MCHEL1.INFCHE(ISOUS,1)=0
  313. MCHEL1.INFCHE(ISOUS,2)=0
  314. MCHEL1.INFCHE(ISOUS,3)=NIFOUR
  315. MCHEL1.INFCHE(ISOUS,4)=MINTE
  316. MCHEL1.INFCHE(ISOUS,5)=0
  317. MCHEL1.INFCHE(ISOUS,6)=ISUP1
  318. MCHEL1.IMACHE(ISOUS)=IPMAIL
  319. MCHEL1.CONCHE(ISOUS)=CONMOD
  320. MCHEL1.ICHAML(ISOUS)=MCHAM1
  321. *
  322. MCHEL2.INFCHE(ISOUS,1)=0
  323. MCHEL2.INFCHE(ISOUS,2)=0
  324. MCHEL2.INFCHE(ISOUS,3)=NIFOUR
  325. MCHEL2.INFCHE(ISOUS,4)=MINTE
  326. MCHEL2.INFCHE(ISOUS,5)=0
  327. MCHEL2.INFCHE(ISOUS,6)=ISUP1
  328. MCHEL2.IMACHE(ISOUS)=IPMAIL
  329. MCHEL2.CONCHE(ISOUS)=CONMOD
  330. MCHEL2.ICHAML(ISOUS)=MCHAM2
  331. *
  332. MCHEL3.INFCHE(ISOUS,1)=0
  333. MCHEL3.INFCHE(ISOUS,2)=0
  334. MCHEL3.INFCHE(ISOUS,3)=NIFOUR
  335. MCHEL3.INFCHE(ISOUS,4)=MINTE
  336. MCHEL3.INFCHE(ISOUS,5)=0
  337. MCHEL3.INFCHE(ISOUS,6)=ISUP1
  338. MCHEL3.IMACHE(ISOUS)=IPMAIL
  339. MCHEL3.CONCHE(ISOUS)=CONMOD
  340. MCHEL3.ICHAML(ISOUS)=MCHAM3
  341. *
  342. **********************************************************************
  343. * *
  344. * BRANCHEMENT SUIVANT LA FORMULATION *
  345. * *
  346. **********************************************************************
  347. * MASSI COQUE COQEP CIST
  348. GOTO ( 30, 99, 60, 99, 80, 99, 99, 99,120, 99,
  349. & 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
  350. & 99, 99, 99, 99, 99, 99, 99, 99, 99, 99,
  351. * INCO PORE
  352. & 30, 99, 30, 99, 99, 99, 99, 99, 99, 99), MFR
  353. C XFEM : idem massif
  354. IF (MFR.EQ.63) GOTO 30
  355. C
  356. 99 CONTINUE
  357. MOTERR(1:8) = NOMFR(MFR/2+1)
  358. CALL ERREUR(193)
  359. GOTO 240
  360. *_______________________________________________________________________
  361. *
  362. * FORMULATION MASSIVE / INCOMPRESSIBLE / POREUX / XFEM
  363. *_______________________________________________________________________
  364. *
  365. 30 CONTINUE
  366. DO 31 IB=1,N1EL
  367. DO 31 IGAU=1,N1PTEL
  368. *
  369. C ... Recherche des composantes du champ des contraintes ...
  370. MPTVAL=IVACOM
  371. DO 35 ICOMP=1,NCOMP
  372. MELVAL=IVAL(ICOMP)
  373. IGMN=MIN(IGAU,VELCHE(/1))
  374. IBMN=MIN(IB ,VELCHE(/2))
  375. SIG(ICOMP)=VELCHE(IGMN,IBMN)
  376. 35 CONTINUE
  377.  
  378. C ... Calcul des invariants ...
  379.  
  380. XI1=SIG(1)+SIG(2)+SIG(3)
  381. IF (IFOUR.LT.1.AND.IFOUR.GT.-3) THEN
  382. XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)+
  383. . W1*SIG(4)*SIG(4)
  384. XI3=SIG(3)*(SIG(1)*SIG(2)-W2*SIG(4)*SIG(4))
  385. ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  386. XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)
  387. XI3=SIG(1)*SIG(2)*SIG(3)
  388. ELSE
  389. XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)+
  390. . W1*(SIG(4)*SIG(4)+SIG(5)*SIG(5)+SIG(6)*SIG(6))
  391. XI3=SIG(1)*SIG(2)*SIG(3)-
  392. . W2*(SIG(1)*SIG(6)*SIG(6)+SIG(2)*SIG(5)*SIG(5)+
  393. . SIG(3)*SIG(4)*SIG(4))+W3*SIG(4)*SIG(5)*SIG(6)
  394. ENDIF
  395.  
  396. C ... et leur stockage ...
  397.  
  398. MELVA1.VELCHE(IGAU,IB)=XI1
  399. MELVA2.VELCHE(IGAU,IB)=XI2
  400. MELVA3.VELCHE(IGAU,IB)=XI3
  401.  
  402. 31 CONTINUE
  403. GOTO 250
  404. *_______________________________________________________________________
  405. *
  406. * FORMULATION COQUE MINCE
  407. *_______________________________________________________________________
  408. *
  409. 60 CONTINUE
  410. DO 61 IB=1,N1EL
  411. DO 61 IGAU=1,N1PTEL
  412. C ... Recherche des composantes du champ des contraintes généralisées ...
  413. MPTVAL=IVACOM
  414. DO 62 ICOMP=1,NCOMP
  415. MELVAL=IVAL(ICOMP)
  416. IGMN=MIN(IGAU,VELCHE(/1))
  417. IBMN=MIN(IB ,VELCHE(/2))
  418. SIG(ICOMP)=VELCHE(IGMN,IBMN)
  419. 62 CONTINUE
  420. *
  421. C ... Recherche de l'épaisseur de la coque ...
  422. MPTVAL=IVACAR
  423. MELVAL=IVAL(1)
  424. IGMN=MIN(IGAU,VELCHE(/1))
  425. IBMN=MIN(IB ,VELCHE(/2))
  426. EPAIST=VELCHE(IGMN,IBMN)
  427. *
  428. * ... CALCUL DES CONTRAINTES ...
  429. *
  430. CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  431. IF(IFOUR.GT.0) THEN
  432. SIG(1)=SIG(1)+SIG(4)*IMIL
  433. SIG(2)=SIG(2)+SIG(5)*IMIL
  434. SIG(3)=SIG(3)+SIG(6)*IMIL
  435. ELSE IF(IFOUR.LE.0) THEN
  436. SIG(1)=SIG(1)+SIG(3)*IMIL
  437. SIG(2)=SIG(2)+SIG(4)*IMIL
  438. SIG(3)=0.D0
  439. ENDIF
  440. *
  441. C ... Calcul des invariants ...
  442.  
  443. XI1=SIG(1)+SIG(2)
  444. XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+W1*SIG(3)*SIG(3)
  445. XI3=0.D0
  446. *
  447. C ... et leur stockage ...
  448. MELVA1.VELCHE(IGAU,IB)=XI1
  449. MELVA2.VELCHE(IGAU,IB)=XI2
  450. MELVA3.VELCHE(IGAU,IB)=XI3
  451. *
  452. 61 CONTINUE
  453. GOTO 250
  454. *_______________________________________________________________________
  455. *
  456. * FORMULATION COQUE EPAISSE
  457. *_______________________________________________________________________
  458. *
  459. 80 CONTINUE
  460. DO 81 IB=1,N1EL
  461. DO 81 IGAU=1,N1PTEL
  462. C ... Recherche des composantes du champ des contraintes ...
  463. MPTVAL=IVACOM
  464. DO 85 ICOMP=1,NCOMP
  465. MELVAL=IVAL(ICOMP)
  466. IGMN=MIN(IGAU,VELCHE(/1))
  467. IBMN=MIN(IB ,VELCHE(/2))
  468. SIG(ICOMP)=VELCHE(IGMN,IBMN)
  469. 85 CONTINUE
  470. *
  471. C ... Calcul des invariants ...
  472.  
  473. XI1=SIG(1)+SIG(2)
  474. XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+
  475. & W1*(SIG(3)*SIG(3)+SIG(4)*SIG(4)+SIG(5)*SIG(5))
  476. XI3=-W2*(SIG(1)*SIG(5)*SIG(5)+SIG(2)*SIG(4)*SIG(4))
  477. & +W3*SIG(3)*SIG(4)*SIG(5)
  478. *
  479. C ... et leur stockage ...
  480.  
  481. MELVA1.VELCHE(IGAU,IB)=XI1
  482. MELVA2.VELCHE(IGAU,IB)=XI2
  483. MELVA3.VELCHE(IGAU,IB)=XI3
  484. *
  485. 81 CONTINUE
  486. GOTO 250
  487. *_______________________________________________________________________
  488. *
  489. * FORMULATION COQUE AVEC CISAILLEMENT
  490. *_______________________________________________________________________
  491. *
  492. 120 CONTINUE
  493. DO 121 IB=1,N1EL
  494. DO 121 IGAU=1,N1PTEL
  495. C ... Recherche des composantes du champ des contraintes ...
  496. MPTVAL=IVACOM
  497. DO 122 ICOMP=1,NCOMP
  498. MELVAL=IVAL(ICOMP)
  499. IGMN=MIN(IGAU,VELCHE(/1))
  500. IBMN=MIN(IB ,VELCHE(/2))
  501. SIG(ICOMP)=VELCHE(IGMN,IBMN)
  502. 122 CONTINUE
  503. *
  504. C ... Recherche de l'épaisseur de la coque ...
  505. MPTVAL=IVACAR
  506. MELVAL=IVAL(1)
  507. IGMN=MIN(IGAU,VELCHE(/1))
  508. IBMN=MIN(IB ,VELCHE(/2))
  509. EPAIST=VELCHE(IGMN,IBMN)
  510. *
  511. * ... CALCUL DES CONTRAINTES ...
  512. *
  513. CALL EFCONT(EPAIST,0.D0,NSTRS,SIG)
  514. SIG(1)=SIG(1)+SIG(4)*IMIL
  515. SIG(2)=SIG(2)+SIG(5)*IMIL
  516. SIG(4)=SIG(3)+SIG(6)*IMIL
  517. SIG(3)=0.D0
  518. SIG(5)=SIG(7)
  519. SIG(6)=SIG(8)
  520.  
  521. C ... Calcul des invariants ...
  522.  
  523. XI1=SIG(1)+SIG(2)+SIG(3)
  524. XI2=SIG(1)*SIG(1)+SIG(2)*SIG(2)+SIG(3)*SIG(3)+
  525. & W1*(SIG(4)*SIG(4)+SIG(5)*SIG(5)+SIG(6)*SIG(6))
  526. XI3=SIG(1)*SIG(2)*SIG(3)-
  527. & W2*(SIG(1)*SIG(6)*SIG(6)+SIG(2)*SIG(5)*SIG(5)+
  528. & SIG(3)*SIG(4)*SIG(4))+W3*SIG(4)*SIG(5)*SIG(6)
  529. *
  530. C ... et leur stockage ...
  531. MELVA1.VELCHE(IGAU,IB)=XI1
  532. MELVA2.VELCHE(IGAU,IB)=XI2
  533. MELVA3.VELCHE(IGAU,IB)=XI3
  534. *
  535. 121 CONTINUE
  536. GOTO 250
  537. *
  538. **********************************************************************
  539. * *
  540. * FIN DU BRANCHEMENT SUIVANT LA FORMULATION *
  541. * *
  542. **********************************************************************
  543. *
  544. * ... DESACTIVATION DES SEGMENTS PROPRES A LA GEOMETRIE ISOUS ...
  545. *
  546. 250 CONTINUE
  547. iOK = 1
  548.  
  549. 240 CONTINUE
  550. SEGDES,MELVA1,MELVA2,MELVA3
  551. SEGDES,MCHAM1,MCHAM2,MCHAM3
  552. *
  553. 230 CONTINUE
  554. IF (MOCARA.NE.0) THEN
  555. nomid = MOCARA
  556. SEGSUP,nomid
  557. ENDIF
  558. *
  559. CALL DTMVAL(IVACOM,1)
  560. *
  561. 220 CONTINUE
  562. nomid = MOCOMP
  563. SEGDES,nomid
  564. IF (lsupno) SEGSUP,nomid
  565. *
  566. 210 CONTINUE
  567. SEGDES,IMODEL
  568. *
  569. * ... ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR ...
  570. IF (iOK.EQ.0) GOTO 990
  571. *
  572. 200 CONTINUE
  573.  
  574. C ... FIN DE LA GRANDE BOUCLE SUR LES ZONES ÉLÉMENTAIRES ...
  575.  
  576. IRET = 1
  577.  
  578. 990 CONTINUE
  579. SEGDES,MMODEL
  580.  
  581. IF (IRET.EQ.1) THEN
  582. SEGDES,MCHEL1,MCHEL2,MCHEL3
  583. IPCHE2 = MCHEL1
  584. IPCHE3 = MCHEL2
  585. IPCHE4 = MCHEL3
  586. ELSE
  587. SEGSUP,MCHEL1,MCHEL2,MCHEL3
  588. IPCHE2 = 0
  589. IPCHE3 = 0
  590. IPCHE4 = 0
  591. ENDIF
  592. *
  593. SEGSUP,notype
  594. IF (IPCH5O.NE.IPCHE5) THEN
  595. CALL DTCHAM(IPCHE5)
  596. IPCHE5 = IPCH5O
  597. ENDIF
  598. *
  599. 666 CONTINUE
  600. SEGDES,MCHELM
  601.  
  602. RETURN
  603. END
  604.  
  605.  
  606.  
  607.  
  608.  

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