Télécharger idmat2.eso

Retour à la liste

Numérotation des lignes :

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

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