Télécharger idmat2.eso

Retour à la liste

Numérotation des lignes :

  1. C IDMAT2 SOURCE BP208322 17/03/01 21:17:39 9325
  2. SUBROUTINE IDMAT2(IPMODE,ICARA,NUDIR1,NUMP1,NUMP2,
  3. 1 NUDIR2,NUMP3,ANG,ANG2,IPCARA,RFLAG)
  4.  
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7.  
  8. *--------------------------------------------------------------------*
  9. * CREATION DU MCHAML CORRESPONDANT A UN MATERIAU ORTHOTROPE *
  10. * APPELE PAR MATCAR *
  11. *--------------------------------------------------------------------*
  12. * *
  13. * ENTREES: *
  14. * -------- *
  15. * *
  16. * IPMODE POINTEUR SUR UN MMODEL *
  17. * ICARA POINTEUR SUR UN MCHELM DE CARACTERISTIQUE (INCOMPLET) *
  18. * NUDIR1 NUMERO DE LA DIRECTIVE UTILISE:"DIRECTION"OU RADIAL" *
  19. * NUMP1 NUMERO DU POINT P1 ASSOCIE A LA DIRECTIVE NIDIR1 *
  20. * NUMP2 NUMERO DU POINT P2 ASSOCIE A LA DIRECTIVE NIDIR1 *
  21. * NUDIR2 NUMERO DE LA DIRECTIVE UTILISE "PARALLELE" "PERPENDIC"*
  22. * "INCLINE" *
  23. * NUMP3 NUMERO DU POINT P ASSOCIE A LA DIRECTIVE INCLINE *
  24. * ANG ANGLE UTILISE DANS LES DIRECTIONS D ORTHOTROPIE *
  25. * (EN RADIAN) *
  26. * ANG2 idem ANG mais pour rotation hors plan en 2D fourier *
  27. * *
  28. * SORTIES: *
  29. * -------- *
  30. * *
  31. * IPCARA POINTEUR SUR UN MCHELM MATERIAU *
  32. * *
  33. * *
  34. * AUTEUR JM CAMPENON LE 29 08 90 *
  35. * *
  36. * ANISOTROPIE DANS LES ELEMENTS MASSIFS, P. DOWLATYARI OCT. 90 *
  37. * *
  38. *--------------------------------------------------------------------*
  39. *
  40. -INC CCOPTIO
  41. -INC CCHAMP
  42. -INC SMCHAML
  43. -INC SMINTE
  44. -INC SMELEME
  45. -INC SMMODEL
  46. C
  47. SEGMENT INFO
  48. INTEGER INFELL(JG)
  49. ENDSEGMENT
  50. C
  51. SEGMENT XVAL
  52. REAL*8 CVAL(NPG2,NEL2),SVAL(NPG2,NEL2)
  53. ENDSEGMENT
  54. C
  55. SEGMENT YVAL
  56. REAL*8 VLOC1(IDIM2,NPG2,NEL2),VLOC2(IDIM2,NPG2,NEL2)
  57. ENDSEGMENT
  58. C
  59. INTEGER NUDIR1,NUMP1,NUMP2,NUDIR2,NUMP3
  60. LOGICAL RFLAG
  61. REAL*8 ANG
  62. INTEGER NPG2,IPVAL
  63. PARAMETER ( NINF=3 )
  64. INTEGER INFOS(NINF)
  65. CHARACTER*8 CMATE,CHARIN
  66. CHARACTER*(NCONCH) CONM
  67. C
  68. IPINF=0
  69. IPINF2=0
  70. C
  71. C ACTIVATION DU MCHELM
  72. C
  73. MCHEL2=ICARA
  74. SEGACT MCHEL2
  75. C
  76. C CREATION DU MCHELM
  77. C
  78. N1=MCHEL2.ICHAML(/1)
  79. L1=16
  80. N3=6
  81. SEGINI MCHEL1
  82. IPCARA=MCHEL1
  83. MCHEL1.TITCHE=MCHEL2.TITCHE
  84. MCHEL1.IFOCHE=MCHEL2.IFOCHE
  85. C
  86. C BOUCLE SUR LES <> SOUS ZONES
  87. C
  88. MMODEL=IPMODE
  89. NSOUS=KMODEL(/1)
  90. C
  91. C DEBUT DE LA BOUCLE SUR LES DIFFERENTES SOUS ZONES
  92. C
  93. isous=0
  94. DO 10 kSOUS=1,NSOUS
  95. IMODEL=KMODEL(kSOUS)
  96. if (nefmod.eq.22) go to 10
  97. isous=isous+1
  98. * AM 4/5/93
  99. MINTE=0
  100. C
  101. MCHEL1.IMACHE(ISOUS)=MCHEL2.IMACHE(ISOUS)
  102. MCHEL1.CONCHE(ISOUS)=MCHEL2.CONCHE(ISOUS)
  103. DO 1 I=1,N3
  104. MCHEL1.INFCHE(ISOUS,I)=MCHEL2.INFCHE(ISOUS,I)
  105. 1 CONTINUE
  106. C
  107. IPMAIL=IMAMOD
  108. CONM =CONMOD
  109. NFOR=FORMOD(/2)
  110. NMAT=MATMOD(/2)
  111. C
  112. C DANS LE CAS DE CONVECTION ON NE REMPLIT PAS MATMOD,
  113. C ON SAUTE DONC CE CAS LA
  114. C
  115. ITHER=0
  116. iplc=0
  117. iplr=0
  118. IF(formod(1).eq.'THERMIQUE') then
  119. ITHER=1
  120. call place(matmod,nmat,iplc,'CONVECTION')
  121. call place(matmod,nmat,iplr,'RAYONNEMENT')
  122. endif
  123. MATE=1
  124. IF (iplr+iplc.eq.0) THEN
  125. * CALL NOMATE(FORMOD,NFOR,MATMOD,NMAT,CMATE,MATE,INAT)
  126. MATE = IMATEE
  127. INAT = INATUU
  128. CMATE = CMATEE
  129. IF (CMATE.EQ.' ') THEN
  130. CALL ERREUR(251)
  131. RETURN
  132. ENDIF
  133. ENDIF
  134. C
  135. C COQUE INTEGREE OU PAS ?
  136. C
  137. IF(INFMOD(/1).NE.0)THEN
  138. NPINT=INFMOD(1)
  139. ELSE
  140. NPINT=0
  141. ENDIF
  142.  
  143. C_______________________________________________________________________
  144. C
  145. C TRAITEMENT PARTICULIER POUR LES MATERIAU ORTHOTROPE OU ANISOT.
  146. C_______________________________________________________________________
  147. C
  148. IF (MATE.EQ.2.OR.MATE.EQ.3.OR.MATE.EQ.4.OR.RFLAG)THEN
  149. MELE=NEFMOD
  150. MELEME=IPMAIL
  151. SEGACT MELEME
  152. NBELEM=NUM(/2)
  153. NBNN=NUM(/1)
  154. CALL IDENT (IPMAIL,CONM,ICARA,0,INFOS,IRTD)
  155. IF (IRTD.EQ.0) THEN
  156. SEGDES,MELEME,MCHEL2
  157. SEGSUP,MCHEL1
  158. RETURN
  159. ENDIF
  160. C
  161. C INFORMATION SUR L ELEMENT FINI
  162. C
  163. MFR =NUMMFR(MELE)
  164. C
  165. IF (MFR.EQ.75) THEN
  166. CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  167. IF (IERR.NE.0) THEN
  168. SEGDES,MELEME,MCHEL2
  169. SEGSUP,MCHEL1
  170. RETURN
  171. ENDIF
  172. INFO=IPINF
  173. NBPGAU = INFELL(6)
  174. segsup info
  175. ELSEIF (MFR.EQ.1.OR.MFR.EQ.31) THEN
  176. NBPGAU=1
  177. NLG=NUMGEO(MELE)
  178. CALL RESHPT (NBPGAU,NBNN,NLG,MELE,NPINT,IPT1,IRT1)
  179. MINTE=IPT1
  180. ELSEIF(MFR.EQ.45)THEN
  181. NBPGAU=1
  182. NLG=NUMGEO(MELE)
  183. SEGDES MELEME
  184. C on va récuperer le maillage des sommet pour le calcul
  185. C des fonctions de formes dans le cas DARCY
  186. CALL LEKMOD(MMODEL,IPTABL,INEFMD)
  187. CHARIN = 'MAILLAGE'
  188. CALL LEKTAB(IPTABL,CHARIN, IOBRE)
  189. IF (IERR.NE.0) RETURN
  190. IPT2 = IOBRE
  191. SEGACT IPT2
  192. MELEME=IPT2
  193. IF(IPT2.LISOUS(/1).NE.0)THEN
  194. MELEME= IPT2.LISOUS(ISOUS)
  195. SEGACT MELEME
  196. SEGDES IPT2
  197. ENDIF
  198. NBNN=NUM(/1)
  199. CALL RESHPT (NBPGAU,NBNN,NLG,NLG,NPINT,IPT1,IRT1)
  200. MINTE=IPT1
  201. ELSEIF(MFR.EQ.33)THEN
  202. * CALL ELQUOI(MELE,0,2,IPINF,IMODEL)
  203. IF (IERR.NE.0) THEN
  204. SEGDES,MELEME,MCHEL2
  205. SEGSUP,MCHEL1
  206. RETURN
  207. ENDIF
  208. NBPGAU=1
  209. MINTE=INFMOD(4)
  210. ELSEIF(MFR.EQ.3.OR.MFR.EQ.9.OR.MFR.EQ.5.OR.MFR.EQ.35) THEN
  211. IF(ITHER.EQ.0)THEN
  212. if(infmod(/1).lt.5)then
  213. CALL ELQUOI(MELE,0,3,IPINF,IMODEL)
  214. IF (IERR.NE.0) THEN
  215. SEGDES,MELEME,MCHEL2
  216. SEGSUP,MCHEL1
  217. RETURN
  218. ENDIF
  219. INFO=IPINF
  220. NBPGAU=INFELL(6)
  221. MINTE=INFELL(11)
  222. MINTE1=INFELL(12)
  223. segsup info
  224. else
  225. NBPGAU=INFELE(6)
  226. MINTE=INFMOD(5)
  227. MINTE1=INFMOD(8)
  228. endif
  229. ELSE
  230. CALL TSHAPE(MELE,'GAUSS',IPT1)
  231. MINTE=IPT1
  232. SEGACT,MINTE
  233. NBPGAU=POIGAU(/1)
  234. SEGDES MINTE
  235. IF(MFR.EQ.5)THEN
  236. CALL TSHAPE(MELE,'NOEUD',IPT2)
  237. MINTE1=IPT2
  238. ELSE
  239. MINTE1=0
  240. ENDIF
  241. ENDIF
  242. ENDIF
  243. *
  244. * CAS 'RADIAL' EN MASSIF
  245. * ON CHERCHE LES POINTS DE GAUSS
  246. *
  247. MINTE2=0
  248. IF(NUDIR1.EQ.2.AND.
  249. . (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33.OR.MFR.EQ.45)) THEN
  250. melele=mele
  251. IF (MFR.EQ.45)melele=nlg
  252. if(infmod(/1).lt.5) then
  253. CALL ELQUOI(melele,0,3,IPINF2,IMODEL)
  254. IF (IERR.NE.0) THEN
  255. SEGDES,MELEME,MCHEL2
  256. SEGSUP,MCHEL1
  257. RETURN
  258. ENDIF
  259. INFO=IPINF2
  260. MINTE2=INFELL(11)
  261. segsup info
  262. else
  263. minte2=infmod(5)
  264. endif
  265. SEGACT MINTE2
  266. NBPGA2=MINTE2.POIGAU(/1)
  267. SEGDES MINTE2
  268. ENDIF
  269. C
  270. C VERIFICATION DE LA COHERENCE DES INFORMATIONS
  271. C
  272. IF (MFR.EQ.3.AND.IDIM.NE.3) THEN
  273. c coque mince 2D: pas de mot-cle ou DIRE accepte : RADI refuse
  274. IF (NUDIR1.NE.0.AND.NUDIR1.NE.1) THEN
  275. CALL ERREUR(21)
  276. GOTO 9990
  277. ENDIF
  278. NUDIR1=1
  279. c coque mince 2D: INCLINE refuse
  280. c IF (NUDIR2.EQ.3) THEN
  281. c CALL ERREUR(21)
  282. c GOTO 9990
  283. c ENDIF
  284. ELSE
  285. *
  286. IF (NUDIR1.EQ.0) THEN
  287. C DIRECTIONS D ORTHOTROPIE NON FOURNIES
  288. CALL ERREUR(346)
  289. GOTO 9990
  290. ENDIF
  291. ENDIF
  292. IF (NUDIR2.EQ.0) THEN
  293. C OPTION PARALLELE PAR DEFAUT
  294. NUDIR2=1
  295. ENDIF
  296. IF(MFR.EQ.35)THEN
  297. IF(NUDIR1.EQ.2)THEN
  298. * CETTE DEFINITION DU REPERE D'ORTH. N'EST PAS VALABLE POUR
  299. * LES ELEMENTS JOINTS (CAR ILS SONT PLANS)
  300. CALL ERREUR (523)
  301. GO TO 9990
  302. ENDIF
  303. ENDIF
  304. C_______________________________________________________________________
  305. C
  306. C_______________________________________________________________________
  307. C
  308. MCHAM2=MCHEL2.ICHAML(ISOUS)
  309. SEGACT MCHAM2
  310. NCOMP=MCHAM2.NOMCHE(/2)
  311. N2=NCOMP
  312. C
  313. C CREATION DU MCHAML : ON PREVOIT ICI QUE L'ON DOIT CREER 2 OU 6
  314. C COMPOSANTES SUPPLEMENTAIRES
  315. C
  316. IF (MFR.EQ.3.OR.MFR.EQ.5.OR.MFR.EQ.9.OR.MFR.EQ.35) THEN
  317. N2=NCOMP+2
  318. ELSEIF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33
  319. & .OR.MFR.EQ.45.OR.MFR.EQ.75) THEN
  320. IF (IDIM.EQ.2) THEN
  321. IF(IFOUR.EQ.1) THEN
  322. IDIM2=3
  323. N2=NCOMP+6
  324. ELSE
  325. IDIM2=2
  326. N2=NCOMP+2
  327. ENDIF
  328. ELSE
  329. IDIM2=3
  330. N2=NCOMP+6
  331. ENDIF
  332. ENDIF
  333. SEGINI MCHAM1
  334. MCHEL1.ICHAML(ISOUS)=MCHAM1
  335. C
  336. C ON RECOPIE TOUS LES NOMS DE COMPOSANTE DE 1 A NCOMP
  337. C
  338. IPEPAI=0
  339. IPEXCE=0
  340. DO 100 ICOMP=1,NCOMP
  341. MCHAM1.NOMCHE(ICOMP)=MCHAM2.NOMCHE(ICOMP)
  342. MCHAM1.TYPCHE(ICOMP)=MCHAM2.TYPCHE(ICOMP)
  343. MELVA2=MCHAM2.IELVAL(ICOMP)
  344. IF(MFR.EQ.5)THEN
  345. IF(MCHAM2.NOMCHE(ICOMP).EQ.'EPAI')THEN
  346. IPEPAI=MELVA2
  347. ELSEIF(MCHAM2.NOMCHE(ICOMP).EQ.'EXCE')THEN
  348. IPEXCE=MELVA2
  349. ENDIF
  350. ENDIF
  351. SEGACT MELVA2
  352. IF (MCHAM2.TYPCHE(ICOMP).EQ.'REAL*8') THEN
  353. N1PTEL=MELVA2.VELCHE(/1)
  354. N1EL =MELVA2.VELCHE(/2)
  355. N2PTEL=0
  356. N2EL =0
  357. C
  358. SEGINI MELVA1
  359. MCHAM1.IELVAL(ICOMP)=MELVA1
  360. DO 13 J=1,N1PTEL
  361. DO 13 K=1,N1EL
  362. MELVA1.VELCHE(J,K)=MELVA2.VELCHE(J,K)
  363. 13 CONTINUE
  364. ELSE
  365. N2PTEL=MELVA2.IELCHE(/1)
  366. N2EL =MELVA2.IELCHE(/2)
  367. N1PTEL=0
  368. N1EL =0
  369. SEGINI MELVA1
  370. C
  371. MCHAM1.IELVAL(ICOMP)=MELVA1
  372. DO 14 J=1,N2PTEL
  373. DO 14 K=1,N2EL
  374. MELVA1.IELCHE(J,K)=MELVA2.IELCHE(J,K)
  375. 14 CONTINUE
  376. ENDIF
  377. 100 CONTINUE
  378. IF(MFR.EQ.5.AND.IPEPAI.EQ.0)THEN
  379. *DANS LE CAS DES ELEMENTS COQUES EPAISSES ORTHOTROPES IL FAUT DONNER
  380. *L'EPAISSEUR EN MEME TEMPS QUE LES PROPRIETES MATERIELLES
  381. CALL ERREUR (526 )
  382. DO 311 ICOMP=1,NCOMP
  383. MELVA2=MCHAM2.IELVAL(ICOMP)
  384. MELVA1=MCHAM1.IELVAL(ICOMP)
  385. SEGDES,MELVA2
  386. SEGSUP,MELVA1
  387. 311 CONTINUE
  388. SEGDES MCHAM2
  389. SEGSUP MCHAM1
  390. GOTO 9990
  391. ENDIF
  392. C_______________________________________________________________________
  393. C
  394. C ON TRAITE ICI LES COMPOSANTES 'V1X' ET 'V1Y'POUR LES ELEMENTS
  395. C COQUES ET 'V1X','V1Y','V1Z','V2X','V2Y','V2Z' POUR LES MASSIF
  396. C_______________________________________________________________________
  397. C
  398. C_______________________________________________________________________
  399. C
  400. C -- TRAITEMENT PARTICULIER SELON LE TYPE DES ELEMENTS --
  401. C_______________________________________________________________________
  402. C
  403. C
  404. IF(MFR.EQ.3.OR.MFR.EQ.9.OR.MFR.EQ.35)THEN
  405. IF (NUDIR1.EQ.1) THEN
  406. NPG2=1
  407. ENDIF
  408. IF (NUDIR1.EQ.2) THEN
  409. NPG2=NBPGAU
  410. ENDIF
  411. C
  412. IF (MELE.EQ.27.OR.MELE.EQ.28.OR.MELE.EQ.49.OR.MELE.EQ.93
  413. . .OR.MELE.EQ.87.OR.MELE.EQ.88.OR.MELE.EQ.128) THEN
  414. ICALC=0
  415. ELSEIF (MELE.EQ.44) THEN
  416. ICALC=1
  417. ENDIF
  418. C_______________________________________________________________________
  419. C
  420. C LE FLAG ICALC SERT A INDIQUER L OPTION DE CALCUL A CHOISIR
  421. C DANS LA ROUTINE IDMAT3 (IDEM MATEO2 ET COBIOR POUR MATE)
  422. C_______________________________________________________________________
  423. C
  424. IPVAL=0
  425. CALL IDMAT3 (NUDIR1,NUMP1,NUDIR2,NUMP3,ANG,
  426. 1 MELEME,MINTE,NPG2,ICALC,MFR,IPVAL)
  427. IF (IERR.NE.0) THEN
  428. DO 300 ICOMP=1,NCOMP
  429. MELVA2=MCHAM2.IELVAL(ICOMP)
  430. MELVA1=MCHAM1.IELVAL(ICOMP)
  431. SEGDES,MELVA2
  432. SEGSUP,MELVA1
  433. 300 CONTINUE
  434. SEGDES MCHAM2
  435. SEGSUP MCHAM1
  436. GOTO 9990
  437. ENDIF
  438. ELSEIF(MFR.EQ.5)THEN
  439. NPG2=NBPGAU
  440. IPVAL=0
  441. CALL IDMAT5(NUDIR1,NUMP1,NUDIR2,NUMP3,ANG,
  442. 1 MELEME,MINTE,MINTE1,IPEPAI,IPEXCE,NPG2,ITHER,IPVAL)
  443. IF (IERR.NE.0) THEN
  444. DO 312 ICOMP=1,NCOMP
  445. MELVA2=MCHAM2.IELVAL(ICOMP)
  446. MELVA1=MCHAM1.IELVAL(ICOMP)
  447. SEGDES,MELVA2
  448. SEGSUP,MELVA1
  449. 312 CONTINUE
  450. SEGDES MCHAM2
  451. SEGSUP MCHAM1
  452. GOTO 9990
  453. ENDIF
  454. ELSEIF (MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33.OR.MFR.EQ.45)THEN
  455. IPVAL=0
  456. NPG2=1
  457. cbp : afin d'interdire une description "3D" du repere local en 2D
  458. c Fourier pour DARCY, on truande un peu via IFOUR qu'on met a 0 (=axi)
  459. IFOUR1=IFOUR
  460. if(MFR.EQ.45.and.IFOUR.eq.1) IFOUR=0
  461. IF(NUDIR1.EQ.2) NPG2=NBPGA2
  462. CALL IDMAT4(NUMP1,NUMP2,NUDIR1,NUDIR2,ANG,ANG2,
  463. . MELEME,MINTE,IPVAL,NPG2,MINTE2)
  464. IFOUR=IFOUR1
  465. IF (IERR.NE.0) THEN
  466. DO 310 ICOMP=1,NCOMP
  467. MELVA2=MCHAM2.IELVAL(ICOMP)
  468. MELVA1=MCHAM1.IELVAL(ICOMP)
  469. SEGDES,MELVA2
  470. SEGSUP,MELVA1
  471. 310 CONTINUE
  472. SEGDES MCHAM2
  473. SEGSUP MCHAM1
  474. GOTO 9990
  475. ENDIF
  476. ELSEIF (MFR.EQ.75)THEN
  477. IPVAL=0
  478. NPG2=NBPGAU
  479. CALL IDMAT6(NUMP1,NUMP2,NUDIR1,NUDIR2,ANG,MELEME,
  480. . IPVAL,NPG2)
  481. IF (IERR.NE.0) THEN
  482. DO 375 ICOMP=1,NCOMP
  483. MELVA2=MCHAM2.IELVAL(ICOMP)
  484. MELVA1=MCHAM1.IELVAL(ICOMP)
  485. SEGDES,MELVA2
  486. SEGSUP,MELVA1
  487. 375 CONTINUE
  488. SEGDES MCHAM2
  489. SEGSUP MCHAM1
  490. GOTO 9990
  491. ENDIF
  492. ELSE
  493. MOTERR(5:8) = NOMTP(MELE)
  494. MOTERR(1:4) = 'ORTH'
  495. CALL ERREUR (71)
  496. DO 320 ICOMP=1,NCOMP
  497. MELVA2=MCHAM2.IELVAL(ICOMP)
  498. MELVA1=MCHAM1.IELVAL(ICOMP)
  499. SEGDES,MELVA2
  500. SEGSUP,MELVA1
  501. 320 CONTINUE
  502. SEGDES MCHAM2
  503. SEGSUP MCHAM1
  504. GOTO 9990
  505. ENDIF
  506. C
  507. IF (MFR.EQ.3 .OR.MFR.EQ.9.OR.MFR.EQ.5.OR.MFR.EQ.35 )THEN
  508. C
  509. C ON CREE LES COMPOSANTES V1X ET V1Y
  510. C
  511. IF (RFLAG) THEN
  512. MCHAM1.NOMCHE(N2-1 )='W1X '
  513. MCHAM1.NOMCHE(N2 )='W1Y '
  514. ELSE
  515. MCHAM1.NOMCHE(N2-1 )='V1X '
  516. MCHAM1.NOMCHE(N2 )='V1Y '
  517. ENDIF
  518. MCHAM1.TYPCHE(N2-1 )='REAL*8'
  519. MCHAM1.TYPCHE(N2 )='REAL*8'
  520. C
  521. C REMPLISSAGE DU SEGMENT MELVA1 CONTENANT LES COMPOSANTES
  522. C
  523. N1PTEL=NPG2
  524. N1EL = NBELEM
  525. N2PTEL=0
  526. N2EL =0
  527. C
  528. XVAL=IPVAL
  529. SEGACT XVAL
  530. C
  531. SEGINI MELVA1
  532. MCHAM1.IELVAL(N2-1)=MELVA1
  533. DO 1110 IB=1,NBELEM
  534. DO 1110 IGAU=1,NPG2
  535. IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
  536. IBMN=MIN(IB ,MELVA1.VELCHE(/2))
  537. MELVA1.VELCHE(IGMN,IBMN)=CVAL(IGAU,IB)
  538. 1110 CONTINUE
  539. C
  540. SEGINI MELVA1
  541. MCHAM1.IELVAL(N2)=MELVA1
  542. DO 2110 IB=1,NBELEM
  543. DO 2110 IGAU=1,NPG2
  544. IGMN=MIN(IGAU,MELVA1.VELCHE(/1))
  545. IBMN=MIN(IB ,MELVA1.VELCHE(/2))
  546. MELVA1.VELCHE(IGMN,IBMN)=SVAL(IGAU,IB)
  547. 2110 CONTINUE
  548. C
  549. SEGSUP XVAL
  550.  
  551. ELSEIF(MFR.EQ.1.OR.MFR.EQ.31.OR.MFR.EQ.33
  552. & .OR.MFR.EQ.45.OR.MFR.EQ.75)THEN
  553. C
  554. C ON CREE LES COMPOSANTES V1X,V1Y,V1Z, . . .
  555. C
  556. cbp IF(IDIM.EQ.2)THEN
  557. c IF(IDIM.EQ.2.AND.((MFR.NE.1.AND.MFR.NE.31).OR.IFOUR.NE.1))THEN
  558. IF(IDIM2.EQ.2)THEN
  559. NCOMPV=2
  560. IF (RFLAG) THEN
  561. MCHAM1.NOMCHE(N2-1 )='W1X '
  562. MCHAM1.NOMCHE(N2 )='W1Y '
  563. ELSE
  564. MCHAM1.NOMCHE(N2-1 )='V1X '
  565. MCHAM1.NOMCHE(N2 )='V1Y '
  566. ENDIF
  567. C
  568. cbp ELSEIF(IDIM.EQ.3)THEN
  569. ELSE
  570. NCOMPV=6
  571. C
  572. IF (RFLAG) THEN
  573. MCHAM1.NOMCHE(N2-5 )='W1X '
  574. MCHAM1.NOMCHE(N2-4 )='W1Y '
  575. MCHAM1.NOMCHE(N2-3 )='W1Z '
  576. MCHAM1.NOMCHE(N2-2 )='W2X '
  577. MCHAM1.NOMCHE(N2-1 )='W2Y '
  578. MCHAM1.NOMCHE(N2 )='W2Z '
  579. ELSE
  580. MCHAM1.NOMCHE(N2-5 )='V1X '
  581. MCHAM1.NOMCHE(N2-4 )='V1Y '
  582. MCHAM1.NOMCHE(N2-3 )='V1Z '
  583. MCHAM1.NOMCHE(N2-2 )='V2X '
  584. MCHAM1.NOMCHE(N2-1 )='V2Y '
  585. MCHAM1.NOMCHE(N2 )='V2Z '
  586. ENDIF
  587. C
  588. ENDIF
  589.  
  590. DO 200 ICOMP =1,NCOMPV
  591. MCHAM1.TYPCHE(N2-(NCOMPV-ICOMP))='REAL*8'
  592. 200 CONTINUE
  593. C
  594. C REMPLISSAGE DU SEGMENT MELVA1 CONTENANT LES COMPOSANTES
  595. C
  596. N1PTEL=NPG2
  597. N1EL =NBELEM
  598. N2PTEL=0
  599. N2EL =0
  600. YVAL=IPVAL
  601. SEGACT YVAL
  602. C
  603. DO 210 ICOMP=1,NCOMPV
  604. SEGINI MELVA1
  605. MCHAM1.IELVAL(N2-(NCOMPV-ICOMP))=MELVA1
  606. DO 220 IB=1,NBELEM
  607. DO 230 IG=1,NPG2
  608. IF(ICOMP.LE.3)THEN
  609. MELVA1.VELCHE(IG,IB)=VLOC1(ICOMP,IG,IB)
  610. ELSE
  611. MELVA1.VELCHE(IG,IB)=VLOC2((ICOMP-3),IG,IB)
  612. ENDIF
  613. 230 CONTINUE
  614. 220 CONTINUE
  615. 210 CONTINUE
  616. SEGSUP YVAL
  617. *
  618. ENDIF
  619. SEGDES MELEME
  620. C
  621. C_______________________________________________________________________
  622. C_______________________________________________________________________
  623. C
  624. ELSE
  625. C
  626. C ON RECOPIE LE CHAMELEM ICARA DANS LE CHAMELEM IPCARA
  627. C
  628. DO 17 I=1,N3
  629. MCHEL1.INFCHE(ISOUS,I)=MCHEL2.INFCHE(ISOUS,I)
  630. 17 CONTINUE
  631. C
  632. C ACTIVATION DU MCHAML
  633. C
  634. MCHAM2=MCHEL2.ICHAML(ISOUS)
  635. SEGACT MCHAM2
  636. N2=MCHAM2.NOMCHE(/2)
  637. C
  638. SEGINI MCHAM1
  639. MCHEL1.ICHAML(ISOUS)=MCHAM1
  640. DO 2 ICOMP=1,N2
  641. MCHAM1.NOMCHE(ICOMP)=MCHAM2.NOMCHE(ICOMP)
  642. MCHAM1.TYPCHE(ICOMP)=MCHAM2.TYPCHE(ICOMP)
  643. C
  644. C ACTIVATION DU MELVAL
  645. C
  646. MELVA2=MCHAM2.IELVAL(ICOMP)
  647. SEGACT MELVA2
  648. IF (MCHAM2.TYPCHE(ICOMP).EQ.'REAL*8') THEN
  649. N1PTEL=MELVA2.VELCHE(/1)
  650. N1EL =MELVA2.VELCHE(/2)
  651. N2PTEL=0
  652. N2EL =0
  653. C
  654. SEGINI MELVA1
  655. MCHAM1.IELVAL(ICOMP)=MELVA1
  656. DO 5 J=1,N1PTEL
  657. DO 5 K=1,N1EL
  658. MELVA1.VELCHE(J,K)=MELVA2.VELCHE(J,K)
  659. 5 CONTINUE
  660. ELSE
  661. N2PTEL=MELVA2.IELCHE(/1)
  662. N2EL =MELVA2.IELCHE(/2)
  663. N1PTEL=0
  664. N1EL =0
  665. SEGINI MELVA1
  666. C
  667. MCHAM1.IELVAL(ICOMP)=MELVA1
  668. DO 4 J=1,N2PTEL
  669. DO 4 K=1,N2EL
  670. MELVA1.IELCHE(J,K)=MELVA2.IELCHE(J,K)
  671. 4 CONTINUE
  672. ENDIF
  673. 2 CONTINUE
  674. ENDIF
  675. C
  676. C DESACTIVATION DES SEGMENTS
  677. NCOMP2=MCHAM2.NOMCHE(/2)
  678. DO 330 ICOMP=1,NCOMP2
  679. MELVA2=MCHAM2.IELVAL(ICOMP)
  680. SEGDES,MELVA2
  681. 330 CONTINUE
  682. NCOMP1=MCHAM1.NOMCHE(/2)
  683. DO 340 ICOMP=1,NCOMP1
  684. MELVA1=MCHAM1.IELVAL(ICOMP)
  685. SEGDES,MELVA1
  686. 340 CONTINUE
  687. C
  688. SEGDES,MCHAM1,MCHAM2
  689. C
  690. 10 CONTINUE
  691. C
  692. SEGDES,MCHEL1,MCHEL2
  693. RETURN
  694. C
  695. C ERREUR DANS UNE SOUS ZONE DESACTIVATION ET RETOUR
  696. C
  697. 9990 CONTINUE
  698. SEGDES MELEME
  699. IF (MINTE.NE.0) SEGDES MINTE
  700. SEGSUP MCHEL1
  701. SEGDES MCHEL2
  702. RETURN
  703. END
  704.  
  705.  
  706.  
  707.  
  708.  
  709.  

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