Télécharger idmat2.eso

Retour à la liste

Numérotation des lignes :

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

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