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

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