Télécharger muchsc.eso

Retour à la liste

Numérotation des lignes :

muchsc
  1. C MUCHSC SOURCE OF166741 25/02/21 21:18:04 12166
  2. SUBROUTINE MUCHSC(IPMODL,IPCHE1,IPCHE2,IPCHMU,LMOT1,LMOT2,LMOT3,
  3. & IPLREE,IINV)
  4. *________________________________________________________________
  5. *
  6. * MULTIPLICATION DE DEUX CHAMELEM
  7. * --------------------------------
  8. *
  9. * ENTREES :
  10. * ---------
  11. *
  12. * IPCHE1 POINTEUR SUR UN CHAMELEM
  13. * IPCHE2 POINTEUR SUR UN CHAMELEM
  14. * IPMODL POINTEUR SUR UN MMODEL ; UTILISE SEULEMENT DANS LES CAS
  15. * DES MULTIPLICATIONS :
  16. * - ( HOOKE ou HOOTAN ) * ( CONTRAINTES ou DEFORMATIONS)
  17. * - ( GRAD ou GRADFLEX ) * ( GRAD ou GRADFLEX )
  18. * pour connaitre la formulation.
  19. * IINV +1 SI MULTIPLICATION , -1 SI DIVISION
  20. * IPLREE POINTEUR LISTREEL (PONDERATION COMPOSANTES RESULTATS)
  21. *
  22. *
  23. * SORTIE :
  24. * --------
  25. *
  26. * IPCHMU POINTEUR SUR LE CHAMELEM CORRESPONDANT AU PRODUIT
  27. * DES DEUX PRECEDENTS.
  28. * =0 SI L'OPERATION EST IMPOSSIBLE.
  29. *
  30. * PASSAGE AUX NOUVEAUX CHAMELEM PAR JM CAMPENON LE 29 10 90
  31. *
  32. *________________________________________________________________
  33. *
  34. IMPLICIT INTEGER(I-N)
  35. IMPLICIT REAL*8(A-H,O-Z)
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39.  
  40. -INC SMCHAML
  41. -INC SMELEME
  42. -INC SMLREEL
  43. -INC SMCOORD
  44. -INC SMMODEL
  45. -INC SMLMOTS
  46.  
  47. -INC TMPTVAL
  48.  
  49. SEGMENT MTRAA
  50. INTEGER ITRAA(LX)
  51. ENDSEGMENT
  52.  
  53. SEGMENT INFO
  54. INTEGER INFELL(JG)
  55. ENDSEGMENT
  56.  
  57. SEGMENT NOTYPE
  58. CHARACTER*16 TYPE(NBTYPE)
  59. ENDSEGMENT
  60.  
  61. PARAMETER ( NINF=3 )
  62. INTEGER INFOS(NINF)
  63.  
  64. CHARACTER*(NCONCH) CONCH1,CONCH2,CONM
  65. CHARACTER*72 TIT1,TIT2,TITC
  66. LOGICAL lsupde,lsupre,lsupin,lsupco,lsupg1,lsupg2,lperm
  67.  
  68. * write(ioimp,*) 'muchsc : lmot1,lmot2,lmot3,iplree=', lmot1,lmot2
  69. * $ ,lmot3,iplree
  70.  
  71. IPCHMU = 0
  72. MLREE3 = 0
  73.  
  74. ivagr1=0
  75. ivagr2=0
  76. ivares=0
  77.  
  78. * si modele, on remet d'aplomb les chamelem
  79. * Utile que si k = 4 ou 5 en sortie de CALPAQ !
  80. IF (ipmodl.ne.0) then
  81. ker = 0
  82. ire = 0
  83. call reduaf(ipche1,ipmodl,ipche10,0,ire,ker)
  84. if (ire.ne.1) call erreur(ker)
  85. if (ierr.NE.0) return
  86. ipche1 = ipche10
  87. call reduaf(ipche2,ipmodl,ipche20,0,ire,ker)
  88. if (ierr.NE.0) return
  89. if(ire.ne.1) call erreur(ker)
  90. ipche2 = ipche20
  91. ELSE
  92. ipche10 = IPCHE1
  93. ipche20 = IPCHE2
  94. ENDIF
  95.  
  96. MCHEL1 = IPCHE1
  97. MCHEL2 = IPCHE2
  98. SEGACT MCHEL1,MCHEL2
  99.  
  100. * Premieres verifications :
  101. IFO1 = MCHEL1.IFOCHE
  102. IFO2 = MCHEL2.IFOCHE
  103. IF (IFO1.NE.IFO2) THEN
  104. TIT1 = MCHEL1.TITCHE
  105. TIT2 = MCHEL2.TITCHE
  106. MOTERR(1: 8) = TIT1(1:8)
  107. MOTERR(9:16) = TIT2(1:8)
  108. CALL ERREUR(175)
  109. GOTO 666
  110. ENDIF
  111. NSOUS1 = MCHEL1.ICHAML(/1)
  112. NSOUS2 = MCHEL2.ICHAML(/1)
  113. IF (NSOUS1.NE.NSOUS2) THEN
  114. CALL ERREUR(103)
  115. GOTO 666
  116. ENDIF
  117. *
  118. * SG 2018/01/16 si listmots donnes, on saute calpaq et on force le
  119. * calcul composante par composante
  120. *
  121. if (lmot1.gt.0) then
  122. K=3
  123. TITC=' '
  124. NUMCHA=1
  125. else
  126. CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET)
  127. IF (IRET.EQ.0) GOTO 666
  128. endif
  129. * write(ioimp,*) 'muchsc : K=',K
  130. * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  131. lperm=(IPCHE1.ne.ipche10).or.(IPCHE2.ne.ipche20)
  132. * Dans le cas de la division on sort si l ordre a change
  133. IF (IINV.eq.-1) THEN
  134. IF (lperm) THEN
  135. write(ioimp,*)
  136. $ 'L ORDRE DES OPERANDES N A PAS PU ETRE CONSERVE'
  137. write(ioimp,*) 'VERIFIEZ LE TYPE DES CHAMELEM'
  138. MOTERR(1:8)=' / '
  139. call ERREUR(196)
  140. GOTO 666
  141. ENDIF
  142. * CAS NON ADMIS POUR LA DIVISION
  143. IF (K.EQ.4.OR.K.EQ.5) THEN
  144. CALL ERREUR (21)
  145. GOTO 666
  146. ENDIF
  147. ENDIF
  148. *
  149. MCHEL1 = IPCHE1
  150. MCHEL2 = IPCHE2
  151. c* SEGACT MCHEL1,MCHEL2 <- toujours ACTIFs
  152. TIT1 = MCHEL1.TITCHE
  153. TIT2 = MCHEL2.TITCHE
  154. NSOUS1 = MCHEL1.ICHAML(/1)
  155. NSOUS2 = MCHEL2.ICHAML(/1)
  156. *
  157. C Multiplication composante par composante :
  158. IF (K.EQ.3) THEN
  159. jgm1 = 0
  160. c noms de composante ?
  161. IF (lmot1.gt.0) then
  162. mlmot1 = lmot1
  163. segact mlmot1
  164. jgm1 = mlmot1.mots(/2)
  165. mlmot2 = lmot2
  166. segact mlmot2
  167. jgm2 = mlmot2.mots(/2)
  168. mlmot3 = lmot3
  169. segact mlmot3
  170. jgm3 = mlmot3.mots(/2)
  171. if ((jgm1.ne.jgm2) .or. (jgm1.ne.jgm3)) then
  172. MOTERR(1:8)='LISTMOTS'
  173. MOTERR(9:16)='mots '
  174. call erreur(403)
  175. goto 666
  176. endif
  177. if (IPLREE.gt.0) then
  178. MLREE3 = IPLREE
  179. segact mlree3
  180. if (jgm1.ne.mlree3.prog(/1)) then
  181. MOTERR(1:8)='LIST****'
  182. MOTERR(9:16)='termes '
  183. call erreur(403)
  184. goto 666
  185. endif
  186. endif
  187. ENDIF
  188. ENDIF
  189.  
  190. IF (K.EQ.4.OR.K.EQ.5) THEN
  191.  
  192. * BESOIN DU MMODEL
  193. *
  194. IF (IPMODL.EQ.0) THEN
  195. MOTERR(1:8)='MMODEL '
  196. CALL ERREUR (37)
  197. GOTO 666
  198. ENDIF
  199. *
  200. * ACTIVATION DU MMODEL
  201. *
  202. MMODEL=IPMODL
  203. SEGACT MMODEL
  204. NSOUMO=KMODEL(/1)
  205. *
  206. * ON CREE UN CHAMELEM DE CONTRAINTE OU DE DEFORMATION ,
  207. * DE GRADIENT OU DE GRADIENT DE FLEXION.
  208. *
  209. L1=NUMCHA
  210. N1=NSOUMO
  211. N3=MCHEL1.INFCHE(/2)
  212. SEGINI MCHELM
  213. IPCHMU=MCHELM
  214. TITCHE=TITC
  215. IFOCHE=IFO1
  216. *
  217. * REMPLISSAGE DU CHAPEAU DU MCHAML
  218. *
  219. isouss=0
  220. DO 130 ISOUMO=1,NSOUMO
  221. IMODEL=KMODEL(ISOUMO)
  222. SEGACT IMODEL
  223. IPMAIL=IMAMOD
  224. CONM =CONMOD
  225. if((nefmod.eq.22).or.(nefmod.eq.259)) go to 134
  226. isouss=isouss+1
  227. DO 131 ISOUS1=1,NSOUS1
  228. IPMAI1=MCHEL1.IMACHE(ISOUS1)
  229. CONCH1=MCHEL1.CONCHE(ISOUS1)
  230. IF (IPMAIL.EQ.IPMAI1. AND.CONM.EQ.CONCH1) THEN
  231. DO 132 N33=1,N3
  232. INFCHE(isouss,N33)=MCHEL1.INFCHE(ISOUS1,N33)
  233. 132 CONTINUE
  234. IMACHE(ISOUss)=IPMAI1
  235. CONCHE(ISOUss)=CONCH1
  236. GOTO 134
  237. ENDIF
  238. 131 CONTINUE
  239. *
  240. * ERREUR PAS DE CORRESPONDANCE
  241. *
  242. SEGSUP MCHELM
  243. CALL ERREUR(103)
  244. GOTO 666
  245. 134 CONTINUE
  246. 130 CONTINUE
  247. if( nsoumo.ne.isouss) then
  248. n1=isouss
  249. segadj mchelm
  250. IPCHMU=mchelm
  251. endif
  252. nsous=isouss
  253. *
  254. ELSE
  255. *
  256. * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2
  257. *
  258. LX=NSOUS1
  259. SEGINI MTRAA
  260. DO 110 ISOUS1=1,NSOUS1
  261. IPMAI1=MCHEL1.IMACHE(ISOUS1)
  262. CONCH1=MCHEL1.CONCHE(ISOUS1)
  263. DO 120 ISOUS2=1,NSOUS2
  264. IPMAI2=MCHEL2.IMACHE(ISOUS2)
  265. CONCH2=MCHEL2.CONCHE(ISOUS2)
  266. IF(IPMAI1.NE.IPMAI2) GOTO 120
  267. IF(CONCH1.NE.CONCH2) GOTO 120
  268. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  269. IF (IRTD.EQ.0) GOTO 120
  270. IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  271. IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  272. IF (IMINT1.EQ.IMINT2) GOTO 121
  273. IMINT1= MCHEL1.INFCHE(ISOUS1,6)
  274. IMINT2= MCHEL2.INFCHE(ISOUS2,6)
  275. IF (IMINT1.EQ.IMINT2) GOTO 121
  276. *
  277. * ERREUR PAS DE CORRESPONDANCE 2 A 2
  278. *
  279. SEGSUP MTRAA
  280. MOTERR(1: 8) = TIT1(1:8)
  281. MOTERR(9:16) = TIT2(1:8)
  282. CALL ERREUR (175)
  283. GOTO 666
  284. 120 CONTINUE
  285. *
  286. * PAS DE CORRESPONDANCE 2 A 2
  287. *on essaye betement de voir si maillage identique avec 2 pointeurs differents
  288. *
  289. ipt1=ipmai1
  290. segact ipt1
  291. nbn1 = ipt1.num(/1)
  292. nel1 = ipt1.num(/2)
  293. DO 122 ISOUS2=1,NSOUS2
  294. IPMAI2=MCHEL2.IMACHE(ISOUS2)
  295. CONCH2=MCHEL2.CONCHE(ISOUS2)
  296. IF (CONCH1.NE.CONCH2) GOTO 122
  297. ipt2=ipmai2
  298. segact ipt2
  299. if(ipt1.itypel.ne.ipt2.itypel) then
  300. go to 122
  301. endif
  302. nel2=ipt2.num(/2)
  303. if(nel1.ne.nel2) go to 122
  304. do 123 lo=1,nel1
  305. do 1230 lp=1,nbn1
  306. if(ipt1.num(lp,lo).ne.ipt2.num(lp,lo) ) then
  307. go to 122
  308. endif
  309. 1230 continue
  310. 123 continue
  311. IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  312. IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  313. IF (IMINT1.EQ.IMINT2) GOTO 121
  314. IMINT1 = MCHEL1.INFCHE(ISOUS1,6)
  315. IMINT2 = MCHEL2.INFCHE(ISOUS2,6)
  316. IF (IMINT1.EQ.IMINT2) GOTO 121
  317. 122 continue
  318.  
  319. SEGSUP MTRAA
  320. MOTERR(1:8) = TIT1(1:8)
  321. MOTERR(9:16) = TIT2(1:8)
  322. CALL ERREUR (175)
  323. GOTO 666
  324.  
  325. 121 CONTINUE
  326. ITRAA(ISOUS1)=ISOUS2
  327. 110 CONTINUE
  328. *
  329. * CREATION DU MCHELM RESULTAT
  330. *
  331. NSOUS=NSOUS1
  332. SEGINI,MCHELM=MCHEL1
  333. IPCHMU=MCHELM
  334. ENDIF
  335. *
  336. *________________________________________________________________
  337. * BOUCLE SUR LES SOUS PAQUETS DE MCHELM
  338. *
  339. ISOUSS = 0
  340.  
  341. DO 200 ISOUS=1,NSOUS
  342.  
  343. ISOUSS = ISOUSS+1
  344. *
  345. ******** MULTIPLICATION SCALAIRE * SCALAIRE ********************
  346. *
  347. IF (K.EQ.1) THEN
  348. *
  349. ISOUS2=ITRAA(ISOUS)
  350. MCHAM1=MCHEL1.ICHAML(ISOUS)
  351. MCHAM2=MCHEL2.ICHAML(ISOUS2)
  352. SEGACT MCHAM1,MCHAM2
  353. IF (MCHAM1.TYPCHE(1).NE.'REAL*8'.OR.
  354. & MCHAM2.TYPCHE(1).NE.'REAL*8') THEN
  355. MOTERR(1:4)=MCHAM1.NOMCHE(1)(1:4)
  356. CALL ERREUR (197)
  357. GOTO 9999
  358. ENDIF
  359. MELVA1=MCHAM1.IELVAL(1)
  360. MELVA2=MCHAM2.IELVAL(1)
  361. SEGACT MELVA1,MELVA2
  362. *
  363. * CREATION DU MCHAML DE LA SOUS ZONE
  364. *
  365. N2=1
  366. SEGINI MCHAML
  367. NOMCHE(1)=MCHAM1.NOMCHE(1)
  368. TYPCHE(1)='REAL*8'
  369. ICHAML(ISOUS)=MCHAML
  370. *
  371. N1GEL=MELVA1.VELCHE(/1)
  372. N1BEL=MELVA1.VELCHE(/2)
  373. N2GEL=MELVA2.VELCHE(/1)
  374. N2BEL=MELVA2.VELCHE(/2)
  375. *
  376. N1PTEL=MAX(N1GEL,N2GEL)
  377. N1EL =MAX(N1BEL,N2BEL)
  378. N2PTEL=0
  379. N2EL =0
  380. SEGINI MELVAL
  381. IELVAL(1)=MELVAL
  382. DO 1010 IGAU=1,N1PTEL
  383. IGMN1=MIN(IGAU,N1GEL)
  384. IGMN2=MIN(IGAU,N2GEL)
  385. DO 10100 IB=1,N1EL
  386. IBMN1=MIN(IB ,N1BEL)
  387. IBMN2=MIN(IB ,N2BEL)
  388. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  389. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  390. IF(IINV.EQ.1) VELCHE(IGAU,IB)=XTT1*XTT2
  391. IF(IINV.EQ.-1)VELCHE(IGAU,IB)=XTT1/XTT2
  392. 10100 CONTINUE
  393. 1010 CONTINUE
  394. GOTO 200
  395. *
  396. ******** MULTIPLICATION COMPOSANTES * SCALAIRE *******************
  397. *
  398. ELSE IF (K.EQ.2) THEN
  399. *
  400. ISOUS2=ITRAA(ISOUS)
  401. MCHAM1=MCHEL1.ICHAML(ISOUS)
  402. MCHAM2=MCHEL2.ICHAML(ISOUS2)
  403. SEGACT MCHAM1,MCHAM2
  404. IF (MCHAM2.TYPCHE(1).NE.'REAL*8') THEN
  405. C MOTERR(1:4)=MCHAM2.NOMCHE(1)(1:4)
  406. CALL ERREUR (197)
  407. GOTO 9999
  408. ENDIF
  409. MELVA2=MCHAM2.IELVAL(1)
  410. SEGACT MELVA2
  411. N2GEL=MELVA2.VELCHE(/1)
  412. N2BEL=MELVA2.VELCHE(/2)
  413. *
  414. * CREATION DU MCHAML DE LA SOUS ZONE
  415. *
  416. SEGINI,MCHAML=MCHAM1
  417. ICHAML(ISOUS)=MCHAML
  418. DO 2010 ICOMP=1,IELVAL(/1)
  419. MELVA1=IELVAL(ICOMP)
  420. SEGACT MELVA1
  421. N1GEL=MELVA1.VELCHE(/1)
  422. IF (N1GEL.EQ.0) THEN
  423. N1GEL=MELVA1.IELCHE(/1)
  424. N1BEL=MELVA1.IELCHE(/2)
  425. N1PTEL=0
  426. N1EL=0
  427. N2PTEL=MAX(N1GEL,N2GEL)
  428. N2EL =MAX(N1BEL,N2BEL)
  429. SEGINI MELVAL
  430. IELVAL(ICOMP)=MELVAL
  431. IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  432. DO 2020 IGAU=1,N2PTEL
  433. IGMN1=MIN(IGAU,N1GEL)
  434. IGMN2=MIN(IGAU,N2GEL)
  435. DO 20200 IB=1,N2EL
  436. IBMN1=MIN(IB ,N1BEL)
  437. ILREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  438. IBMN2=MIN(IB ,N2BEL)
  439. XTT1=MELVA2.VELCHE(IGMN2,IBMN2)
  440. CALL MUFLIR (ILREE1,XTT1,ILREEL,IINV)
  441. IELCHE(IGAU,IB)=ILREEL
  442. 20200 CONTINUE
  443. 2020 CONTINUE
  444. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT ') THEN
  445. DO 2030 IGAU=1,N2PTEL
  446. IGMN1=MIN(IGAU,N1GEL)
  447. IGMN2=MIN(IGAU,N2GEL)
  448. DO 20300 IB=1,N2EL
  449. IBMN2=MIN(IB ,N2BEL)
  450. XTT1=MELVA2.VELCHE(IGMN2,IBMN2)
  451. IBMN1=MIN(IB ,N1BEL)
  452. IP=MELVA1.IELCHE(IGMN1,IBMN1)
  453. IREF=(IP-1)*(IDIM+1)
  454. *
  455. * ON CREE UN NVX POINTS :NOEUD NBNO+1
  456. *
  457. SEGACT MCOORD*mod
  458. NBNO=nbpts
  459. NBNOI=NBNO
  460. NBPTS=NBNO+1
  461. SEGADJ MCOORD
  462. *
  463. DO 2031 IC=1,IDIM
  464. IF(IINV.EQ.1) XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XTT1
  465. IF(IINV.EQ.-1)XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)/XTT1
  466. 2031 CONTINUE
  467. XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
  468. IELCHE(IGAU,IB)=NBPTS
  469. 20300 CONTINUE
  470. 2030 CONTINUE
  471. ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
  472. DO 2040 IGAU=1,N2PTEL
  473. IGMN1=MIN(IGAU,N1GEL)
  474. IGMN2=MIN(IGAU,N2GEL)
  475. DO 20400 IB=1,N2EL
  476. IBMN1=MIN(IB ,N1BEL)
  477. IEVOL1=MELVA1.IELCHE(IGMN1,IBMN1)
  478. IBMN2=MIN(IB ,N2BEL)
  479. XTT1=MELVA2.VELCHE(IGMN2,IBMN2)
  480. CALL MUFLEV(IEVOL1,XTT1,IEVOL,IINV)
  481. IELCHE(IGAU,IB)=IEVOL
  482. 20400 CONTINUE
  483. 2040 CONTINUE
  484. ELSE
  485. *
  486. * NOM DE COMPOSANTE NON RECONNU
  487. *
  488. C MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)(1:4)
  489. CALL ERREUR(197)
  490. SEGSUP MELVAL,MCHAML
  491. SEGSUP MCHELM,MTRAA,MCHAML
  492. GOTO 666
  493. ENDIF
  494. ELSE
  495. N1BEL=MELVA1.VELCHE(/2)
  496. N1PTEL=MAX(N1GEL,N2GEL)
  497. N1EL =MAX(N1BEL,N2BEL)
  498. N2PTEL=0
  499. N2EL=0
  500. SEGINI MELVAL
  501. IELVAL(ICOMP)=MELVAL
  502. DO 2050 IGAU=1,N1PTEL
  503. IGMN1=MIN(IGAU,N1GEL)
  504. IGMN2=MIN(IGAU,N2GEL)
  505. DO 20500 IB=1,N1EL
  506. IBMN1=MIN(IB ,N1BEL)
  507. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  508. IBMN2=MIN(IB ,N2BEL)
  509. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  510. IF(IINV.EQ.1) VELCHE(IGAU,IB)=XTT1*XTT2
  511. IF(IINV.EQ.-1)VELCHE(IGAU,IB)=XTT1/XTT2
  512. 20500 CONTINUE
  513. 2050 CONTINUE
  514. ENDIF
  515. 2010 CONTINUE
  516. GOTO 200
  517. *
  518. ******** MULTIPLICATION COMPOSANTE * COMPOSANTE *****************
  519. *
  520. ELSE IF (K.EQ.3) THEN
  521. *
  522. ISOUS2 = ITRAA(ISOUS)
  523. MCHAM1 = MCHEL1.ICHAML(ISOUS)
  524. MCHAM2 = MCHEL2.ICHAML(ISOUS2)
  525. SEGACT,MCHAM1,MCHAM2
  526. NCOMP1 = MCHAM1.IELVAL(/1)
  527. NCOMP2 = MCHAM2.IELVAL(/1)
  528. *
  529. * CREATION DU MCHAML DE LA SOUS ZONE
  530. *
  531. IF (lmot1.GT.0) THEN
  532. n2 = jgm1
  533. SEGINI,MCHAML
  534. NCOMP = jgm1
  535. ELSE
  536. SEGINI,MCHAML=MCHAM1
  537. NCOMP = NCOMP1
  538. ENDIF
  539. ICHAML(ISOUS) = MCHAML
  540.  
  541. DO 310 ICOMP = 1, NCOMP
  542.  
  543. icomp2 = 0
  544. IF (lmot1.GT.0) THEN
  545. icomp1 = 0
  546. CALL PLACE (MCHAM1.NOMCHE,NCOMP1, icomp1,
  547. & mlmot1.mots(icomp))
  548. IF (icomp1.EQ.0) THEN
  549. MOTERR(1:4) = mlmot1.mots(icomp)
  550. MOTERR(5:40) = 'MCHAML1'
  551. CALL ERREUR(77)
  552. SEGSUP MCHAML,MCHELM,MTRAA
  553. GOTO 666
  554. ENDIF
  555. MOTERR(1:4) = mlmot2.mots(icomp)
  556. CALL PLACE (MCHAM2.NOMCHE,NCOMP2, icomp2,
  557. & mlmot2.mots(icomp))
  558. nomche(icomp) = mlmot3.mots(icomp)
  559. ELSE
  560. icomp1 = icomp
  561. MOTERR(1:4) = mcham1.nomche(icomp1)
  562. CALL PLACE (MCHAM2.NOMCHE,NCOMP2,icomp2,
  563. & MCHAM1.NOMCHE(icomp1))
  564. ** nomche(icomp) = MCHAM1.NOMCHE(icomp1)
  565. ENDIF
  566. IF (icomp2.EQ.0) THEN
  567. MOTERR(5:40)='MCHAML2'
  568. CALL ERREUR(77)
  569. SEGSUP MCHAML,MCHELM,MTRAA
  570. GOTO 666
  571. ENDIF
  572.  
  573. MELVA1 = MCHAM1.IELVAL(icomp1)
  574. MELVA2 = MCHAM2.IELVAL(icomp2)
  575. SEGACT,MELVA1,MELVA2
  576. IF (MCHAM1.TYPCHE(icomp1).EQ.'REAL*8' .AND.
  577. & MCHAM2.TYPCHE(icomp2).EQ.'REAL*8') THEN
  578. N1GEL = MELVA1.VELCHE(/1)
  579. N1BEL = MELVA1.VELCHE(/2)
  580. N2GEL = MELVA2.VELCHE(/1)
  581. N2BEL = MELVA2.VELCHE(/2)
  582. N1PTEL = MAX(N1GEL,N2GEL)
  583. N1EL = MAX(N1BEL,N2BEL)
  584. N2PTEL = 0
  585. N2EL = 0
  586. SEGINI,MELVAL
  587. TYPCHE(icomp) = 'REAL*8 '
  588. IELVAL(icomp) = MELVAL
  589. *
  590. DO 320 IGAU=1,N1PTEL
  591. IGMN1=MIN(IGAU,N1GEL)
  592. IGMN2=MIN(IGAU,N2GEL)
  593. DO 321 IB=1,N1EL
  594. IBMN1=MIN(IB ,N1BEL)
  595. IBMN2=MIN(IB ,N2BEL)
  596. XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  597. XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  598. IF(IINV.EQ.1) XVAL=XTT1*XTT2
  599. IF(IINV.EQ.-1) XVAL=XTT1/XTT2
  600. if (MLREE3.ne.0) xval=xval*mlree3.prog(icomp)
  601. VELCHE(IGAU,IB)=XVAL
  602. 321 CONTINUE
  603. 320 CONTINUE
  604. ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'REAL*8' .AND.
  605. & MCHAM2.TYPCHE(icomp2).EQ.'POINTEURLISTREEL') THEN
  606. N1GEL = MELVA1.VELCHE(/1)
  607. N1BEL = MELVA1.VELCHE(/2)
  608. N2GEL = MELVA2.IELCHE(/1)
  609. N2BEL = MELVA2.IELCHE(/2)
  610. N1PTEL = 0
  611. N1EL = 0
  612. N2PTEL = MAX(N1GEL,N2GEL)
  613. N2EL = MAX(N1BEL,N2BEL)
  614. SEGINI MELVAL
  615.  
  616. TYPCHE(icomp) = 'POINTEURLISTREEL'
  617. IELVAL(icomp) = MELVAL
  618.  
  619. DO 331 IGAU=1,N2PTEL
  620. IGMN1=MIN(IGAU,N1GEL)
  621. IGMN2=MIN(IGAU,N2GEL)
  622. DO 3310 IB=1,N2EL
  623. IBMN1=MIN(IB ,N1BEL)
  624. IBMN2=MIN(IB ,N2BEL)
  625. xtt1 = melva1.velche(igmn1,ibmn1)
  626. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  627. SEGACT MLREE2
  628. IPROG2=MLREE2.PROG(/1)
  629. JG= IPROG2
  630. SEGINI MLREEL
  631. DO 341 IPROG=1,JG
  632. IF(IINV.EQ.1) XVAL=xtt1*MLREE2.PROG(IPROG)
  633. IF(IINV.EQ.-1) XVAL=xtt1/MLREE2.PROG(IPROG)
  634. if (MLREE3.gt.0) xval=xval*mlree3.prog(icomp)
  635. PROG(IPROG)=xval
  636. 341 CONTINUE
  637. IELCHE(IGAU,IB)=MLREEL
  638. 3310 CONTINUE
  639. 331 CONTINUE
  640. ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEURLISTREEL' .AND.
  641. & MCHAM2.TYPCHE(icomp2).EQ.'REAL*8') THEN
  642. N1GEL=MELVA1.IELCHE(/1)
  643. N1BEL=MELVA1.IELCHE(/2)
  644. N2GEL=MELVA2.VELCHE(/1)
  645. N2BEL=MELVA2.VELCHE(/2)
  646. N1PTEL=0
  647. N1EL=0
  648. N2PTEL=MAX(N1GEL,N2GEL)
  649. N2EL =MAX(N1BEL,N2BEL)
  650. SEGINI MELVAL
  651. IELVAL(icomp)=MELVAL
  652. TYPCHE(icomp) = 'POINTEURLISTREEL'
  653. DO 332 IGAU=1,N2PTEL
  654. IGMN1=MIN(IGAU,N1GEL)
  655. IGMN2=MIN(IGAU,N2GEL)
  656. DO 3320 IB=1,N2EL
  657. IBMN1=MIN(IB ,N1BEL)
  658. IBMN2=MIN(IB ,N2BEL)
  659. xtt2 = melva2.velche(igmn2,ibmn2)
  660. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  661. SEGACT MLREE1
  662. IPROG1=MLREE1.PROG(/1)
  663. JG= IPROG1
  664. SEGINI MLREEL
  665. DO 342 IPROG=1,JG
  666. IF(IINV.EQ.1) xval=xtt2*MLREE1.PROG(IPROG)
  667. IF(IINV.EQ.-1) xval=xtt2/MLREE1.PROG(IPROG)
  668. if (MLREE3.gt.0) xval=xval*mlree3.prog(icomp)
  669. PROG(IPROG)=xval
  670. 342 CONTINUE
  671. IELCHE(IGAU,IB)=MLREEL
  672. 3320 CONTINUE
  673. 332 CONTINUE
  674. ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEURLISTREEL' .AND.
  675. & MCHAM2.TYPCHE(icomp2).EQ.'POINTEURLISTREEL') THEN
  676. N1GEL=MELVA1.IELCHE(/1)
  677. N1BEL=MELVA1.IELCHE(/2)
  678. N2GEL=MELVA2.IELCHE(/1)
  679. N2BEL=MELVA2.IELCHE(/2)
  680. N1PTEL=0
  681. N1EL=0
  682. N2PTEL=MAX(N1GEL,N2GEL)
  683. N2EL =MAX(N1BEL,N2BEL)
  684. SEGINI MELVAL
  685. IELVAL(icomp)=MELVAL
  686. TYPCHE(icomp) = 'POINTEURLISTREEL'
  687.  
  688. DO 330 IGAU=1,N2PTEL
  689. IGMN1=MIN(IGAU,N1GEL)
  690. IGMN2=MIN(IGAU,N2GEL)
  691. DO 3300 IB=1,N2EL
  692. IBMN1=MIN(IB ,N1BEL)
  693. IBMN2=MIN(IB ,N2BEL)
  694. MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  695. MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  696. SEGACT MLREE1,MLREE2
  697. IPROG1=MLREE1.PROG(/1)
  698. IPROG2=MLREE2.PROG(/1)
  699. JG=MAX(IPROG1,IPROG2)
  700. SEGINI MLREEL
  701. DO 340 IPROG=1,JG
  702. IF ( (IPROG.GT.IPROG1).OR.
  703. & (IPROG.GT.IPROG2) ) THEN
  704. PROG(IPROG)=0.D0
  705. ELSE
  706. IF(IINV.EQ.1) xval=MLREE1.PROG(IPROG)
  707. $ *MLREE2.PROG(IPROG)
  708. IF(IINV.EQ.-1) xval=MLREE1.PROG(IPROG)
  709. & /MLREE2.PROG(IPROG)
  710. if (MLREE3.gt.0) xval=xval
  711. $ *mlree3.prog(icomp)
  712. PROG(IPROG)=XVAL
  713. ENDIF
  714. 340 CONTINUE
  715. IELCHE(IGAU,IB)=MLREEL
  716. 3300 CONTINUE
  717. 330 CONTINUE
  718. ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEUREVOLUTIO' .AND.
  719. & MCHAM2.TYPCHE(icomp2).EQ.'POINTEUREVOLUTIO') THEN
  720. N1GEL=MELVA1.IELCHE(/1)
  721. N1BEL=MELVA1.IELCHE(/2)
  722. N2GEL=MELVA2.IELCHE(/1)
  723. N2BEL=MELVA2.IELCHE(/2)
  724. N1PTEL=0
  725. N1EL=0
  726. N2PTEL=MAX(N1GEL,N2GEL)
  727. N2EL =MAX(N1BEL,N2BEL)
  728. SEGINI MELVAL
  729.  
  730. IELVAL(ICOMP)=MELVAL
  731. TYPCHE(ICOMP) = 'POINTEUREVOLUTIO'
  732.  
  733. DO 333 IGAU=1,N2PTEL
  734. IGMN1=MIN(IGAU,N1GEL)
  735. IGMN2=MIN(IGAU,N2GEL)
  736. DO 3330 IB=1,N2EL
  737. IBMN1=MIN(IB,N1BEL)
  738. IBMN2=MIN(IB,N2BEL)
  739. MEVOL1=MELVA1.IELCHE(IGMN1,IBMN1)
  740. MEVOL2=MELVA2.IELCHE(IGMN2,IBMN2)
  741. CALL PUIS(MEVOL1,MEVOL2,MEVOL3,IINV)
  742. IF (MLREE3.GT.0) THEN
  743. XFLOT1=MLREE3.prog(ICOMP)
  744. CALL MUFLEV(MEVOL3,XFLOT1,MEVOL3,1)
  745. ENDIF
  746. IELCHE(IGAU,IB)=MEVOL3
  747. 3330 CONTINUE
  748. 333 CONTINUE
  749. ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'REAL*8' .AND.
  750. & MCHAM2.TYPCHE(icomp2).EQ.'POINTEUREVOLUTIO') THEN
  751. N1GEL=MELVA1.VELCHE(/1)
  752. N1BEL=MELVA1.VELCHE(/2)
  753. N2GEL=MELVA2.IELCHE(/1)
  754. N2BEL=MELVA2.IELCHE(/2)
  755. N1PTEL=0
  756. N1EL=0
  757. N2PTEL=MAX(N1GEL,N2GEL)
  758. N2EL =MAX(N1BEL,N2BEL)
  759. SEGINI MELVAL
  760.  
  761. IELVAL(ICOMP)=MELVAL
  762. TYPCHE(ICOMP) = 'POINTEUREVOLUTIO'
  763.  
  764. DO 334 IGAU=1,N2PTEL
  765. IGMN1=MIN(IGAU,N1GEL)
  766. IGMN2=MIN(IGAU,N2GEL)
  767. DO 3340 IB=1,N2EL
  768. IBMN1=MIN(IB,N1BEL)
  769. IBMN2=MIN(IB,N2BEL)
  770. XFLOT1=MELVA1.VELCHE(IGMN1,IBMN1)
  771. MEVOL2=MELVA2.IELCHE(IGMN2,IBMN2)
  772. IF (MLREE3.GT.0) THEN
  773. XFLOT1=XFLOT1*MLREE3.prog(ICOMP)
  774. ENDIF
  775. CALL MUFLEV(MEVOL2,XFLOT1,IRET,IINV)
  776. IELCHE(IGAU,IB)=IRET
  777. 3340 CONTINUE
  778. 334 CONTINUE
  779. ELSE IF (MCHAM1.TYPCHE(icomp1).EQ.'POINTEUREVOLUTIO' .AND.
  780. & MCHAM2.TYPCHE(icomp2).EQ.'REAL*8') THEN
  781. N1GEL=MELVA1.IELCHE(/1)
  782. N1BEL=MELVA1.IELCHE(/2)
  783. N2GEL=MELVA2.VELCHE(/1)
  784. N2BEL=MELVA2.VELCHE(/2)
  785. N1PTEL=0
  786. N1EL=0
  787. N2PTEL=MAX(N1GEL,N2GEL)
  788. N2EL =MAX(N1BEL,N2BEL)
  789. SEGINI MELVAL
  790.  
  791. IELVAL(ICOMP) = MELVAL
  792. TYPCHE(ICOMP) = 'POINTEUREVOLUTIO'
  793.  
  794. DO 335 IGAU=1,N2PTEL
  795. IGMN1=MIN(IGAU,N1GEL)
  796. IGMN2=MIN(IGAU,N2GEL)
  797. DO 3350 IB=1,N2EL
  798. IBMN1=MIN(IB,N1BEL)
  799. IBMN2=MIN(IB,N2BEL)
  800. MEVOL1=MELVA1.IELCHE(IGMN1,IBMN1)
  801. XFLOT1=MELVA2.VELCHE(IGMN2,IBMN2)
  802. IF (MLREE3.GT.0) THEN
  803. XFLOT1=XFLOT1*MLREE3.prog(ICOMP)
  804. ENDIF
  805. CALL MUFLEV(MEVOL1,XFLOT1,IRET,IINV)
  806. IELCHE(IGAU,IB)=IRET
  807. 3350 CONTINUE
  808. 335 CONTINUE
  809. *
  810. * NOM DE COMPOSANTE NON RECONNU
  811. *
  812. ELSE
  813. MOTERR(1:4)='* '
  814. C MOTERR(5:8)=NOMCHE(ICOMP)(1:4)
  815. CALL ERREUR(335)
  816. SEGSUP MCHAML,MCHELM,MTRAA
  817. GOTO 666
  818. ENDIF
  819. 310 CONTINUE
  820. GOTO 200
  821.  
  822. *
  823. ******** MULTIPLICATION MATRICE * COMPOSANTE ******************
  824. *
  825. ELSE IF (K.EQ.4) THEN
  826. *
  827. IMODEL=KMODEL(ISOUS)
  828. SEGACT IMODEL
  829. IPMAIL=IMAMOD
  830. CONM =CONMOD
  831. MELE=NEFMOD
  832. C
  833. C COQUE INTEGREE OU PAS ?
  834. C
  835. NPINT=INFMOD(1)
  836. IF (NPINT.NE.0)THEN
  837. CALL ERREUR(615)
  838. SEGSUP MCHELM
  839. GOTO 666
  840. ENDIF
  841. *
  842. * INFORMATION SUR L'ELEMENT FINI
  843. *
  844. CALL ELQUOI (MELE,0,6,IPINF,IMODEL)
  845. IF (IERR.NE.0) THEN
  846. SEGSUP MCHELM
  847. GOTO 666
  848. ENDIF
  849. INFO=IPINF
  850. MFR=INFELL(13)
  851. segsup info
  852. *
  853. * CREATION DU TABLEAU INFOS
  854. *
  855. lsupin=.true.
  856. lsupre=.true.
  857. CALL IDENT (IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  858. if(lnomid(5).ne.0) then
  859. nomid=lnomid(5)
  860. segact nomid
  861. nobde=lesobl(/2)
  862. lsupde=.false.
  863. modef=nomid
  864. else
  865. lsupde=.true.
  866. CALL IDDEFO (IMODEL,IFO1,MOdef ,Nobde ,NFAC)
  867. endif
  868. if(lnomid(4).ne.0) then
  869. nomid=lnomid(4)
  870. segact nomid
  871. mocon=nomid
  872. nconn=lesobl(/2)
  873. nfac=lesfac(/2)
  874. lsupco=.false.
  875. else
  876. lsupco=.true.
  877. CALL IDCONT (IMODEL,IFO1,MOCOn,NCOnn ,NFAC)
  878. endif
  879. IF (NUMCHA.EQ.12) THEN
  880. mocomp=mocon
  881. ncom=nconn
  882. lsupin=lsupco
  883. mores=modef
  884. nres= nobde
  885. lsupre=lsupde
  886. ELSE
  887. mores=mocon
  888. nres=nconn
  889. lsupre=lsupco
  890. mocomp=modef
  891. ncom=nobde
  892. lsupin=lsupde
  893. ENDIF
  894. *
  895. * VERIFICATION DE LA PRESENCE DES COMPOSANTES
  896. *
  897. *
  898. NBTYPE=1
  899. SEGINI NOTYPE
  900. MOTYPE=NOTYPE
  901. TYPE(1)='REAL*8'
  902. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,
  903. 1 MOTYPE,1,INFOS,3,IVACOM)
  904. SEGSUP NOTYPE
  905. IF (IERR.NE.0) GOTO 4998
  906. *
  907. * VERIFICATION PRESENCE DE LA MATRICE DE HOOKE
  908. *
  909. NBROBL=1
  910. NBRFAC=0
  911. SEGINI NOMID
  912. MOHOOK=NOMID
  913. LESOBL(1)='MAHO'
  914. *
  915. * VERIFICATION DE LA PRESENCE DES COMPOSANTES
  916. *
  917. NBTYPE=1
  918. SEGINI NOTYPE
  919. MOTYPE=NOTYPE
  920. TYPE(1)='POINTEURLISTREEL'
  921. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOHOOK,
  922. 1 MOTYPE,1,INFOS,3,IVAHOO)
  923. SEGSUP NOTYPE
  924. IF (IERR.NE.0) GOTO 4999
  925. *
  926. * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  927. *
  928. MPTVAL=IVAHOO
  929. MELVAL=IVAL(1)
  930. N1PTEL=IELCHE(/1)
  931. N1EL =IELCHE(/2)
  932. MPTVAL=IVACOM
  933. DO 401 IO=1,NCOM
  934. MELVAL=IVAL(IO)
  935. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  936. N1EL =MAX(N1EL ,VELCHE(/2))
  937. 401 CONTINUE
  938. *
  939. * CREATION DU MCHAML DE LA SOUS ZONE
  940. *
  941. N2=NRES
  942. SEGINI MCHAML
  943. ICHAML(ISOUS)=MCHAML
  944. NSR=1
  945. NCOSOR=NRES
  946. SEGINI MPTVAL
  947. IVARES=MPTVAL
  948. NOMID=MORES
  949. SEGACT NOMID
  950. DO 402 ICOMP=1,NRES
  951. NOMCHE(ICOMP)=LESOBL(ICOMP)
  952. TYPCHE(ICOMP)='REAL*8'
  953. N2PTEL=0
  954. N2EL=0
  955. SEGINI MELVAL
  956. IELVAL(ICOMP)=MELVAL
  957. IVAL(ICOMP)=MELVAL
  958. 402 CONTINUE
  959. DO 403 IGAU=1,N1PTEL
  960. DO 4030 IB=1,N1EL
  961. MPTVAL=IVAHOO
  962. MELVAL=IVAL(1)
  963. IBMN=MIN(IB ,IELCHE(/2))
  964. IGMN=MIN(IGAU,IELCHE(/1))
  965. MLREEL=IELCHE(IGMN,IBMN)
  966. SEGACT MLREEL
  967. *
  968. * traitement special pour poreux ( mfr=33 )
  969. *
  970. NCOMM = NCOM
  971. IF(MFR.EQ.33) NCOMM=NCOM-1
  972. *
  973. DO 404 ID=1,NCOMM
  974. CC=0.D0
  975. JJ = ID
  976. MPTVAL=IVACOM
  977. DO 405 JA=1,NCOMM
  978. MELVAL=IVAL(JA)
  979. IGMN=MIN(IGAU,VELCHE(/1))
  980. IBMN=MIN(IB ,VELCHE(/2))
  981. XTT1 =VELCHE(IGMN,IBMN)
  982. IF (JJ.GT.PROG(/1)) THEN
  983. XTT2=0.D0
  984. ELSE
  985. XTT2 =PROG(JJ)
  986. ENDIF
  987. CC = CC + XTT1 * XTT2
  988. JJ = JJ + NCOMM
  989. 405 CONTINUE
  990. IF (ID.LE.NRES) THEN
  991. *
  992. * CAS MFR=17
  993. *
  994. MPTVAL=IVARES
  995. MELVAL=IVAL(ID)
  996. VELCHE(IGAU,IB)=CC
  997. ENDIF
  998. 404 CONTINUE
  999. IF(MFR.EQ.33) THEN
  1000. MPTVAL=IVACOM
  1001. MELVAL=IVAL(NCOM)
  1002. IGMN=MIN(IGAU,VELCHE(/1))
  1003. IBMN=MIN(IB ,VELCHE(/2))
  1004. CC =VELCHE(IGMN,IBMN)
  1005. MPTVAL=IVARES
  1006. MELVAL=IVAL(NRES)
  1007. VELCHE(IGAU,IB)=CC
  1008. ENDIF
  1009. 4030 CONTINUE
  1010. 403 CONTINUE
  1011. *
  1012. CALL DTMVAL(IVACOM,1)
  1013. *
  1014. CALL DTMVAL(IVAHOO,1)
  1015. *
  1016. CALL DTMVAL(IVARES,1)
  1017. *
  1018. NOMID=MOCOMP
  1019. if(lsupin)SEGSUP NOMID
  1020. NOMID=MOHOOK
  1021. SEGSUP NOMID
  1022. NOMID=MORES
  1023. if(lsupre)SEGSUP NOMID
  1024. *
  1025. * SEGSUP INFO
  1026. GOTO 200
  1027. *
  1028. * ERREUR DESACTIVATION ET RETOUR
  1029. *
  1030. 4999 CONTINUE
  1031. *
  1032. CALL DTMVAL(IVAHOO,1)
  1033. NOMID=MOHOOK
  1034. SEGSUP NOMID
  1035. *
  1036. 4998 CONTINUE
  1037. CALL DTMVAL(IVACOM,1)
  1038. NOMID=MOCOMP
  1039. if(lsupin)SEGSUP NOMID
  1040. NOMID=MORES
  1041. if(lsupre)SEGSUP NOMID
  1042. *
  1043. * SEGSUP INFO
  1044. SEGSUP MCHELM
  1045. IPCHMU=0
  1046. RETURN
  1047.  
  1048. *
  1049. ******** MULTIPLICATION GRADIENT * GRADIENT ********************
  1050. *
  1051. ELSE IF (K.EQ.5) THEN
  1052. *
  1053. 4997 CONTINUE
  1054. IMODEL=KMODEL(ISOUSS)
  1055. SEGACT IMODEL
  1056. IPMAIL=IMAMOD
  1057. CONM =CONMOD
  1058. MELE=NEFMOD
  1059. IF ((MELE.EQ.259).OR.(MELE.EQ.22)) THEN
  1060. ISOUSS = ISOUSS+1
  1061. goto 4997
  1062. ENDIF
  1063.  
  1064. *
  1065. * INFORMATION SUR L'ELEMENT FINI
  1066. *
  1067. CALL ELQUOI (MELE,0,6,IPINF,IMODEL)
  1068. IF (IERR.NE.0) THEN
  1069. SEGSUP MCHELM
  1070. IPCHMU=0
  1071. RETURN
  1072. ENDIF
  1073. INFO=IPINF
  1074. MFR=INFELL(13)
  1075. segsup info
  1076. *
  1077. * CREATION DU TABLEAU INFOS
  1078. *
  1079. CALL IDENT (IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  1080. *
  1081. lsupg1=.true.
  1082. IF (TIT1.EQ.'GRADIENT') THEN
  1083. if(lnomid(3).ne.0) then
  1084. nomid=lnomid(3)
  1085. segact nomid
  1086. mogra1=nomid
  1087. ngra1=lesobl(/2)
  1088. nfac=lesfac(/2)
  1089. lsupg1=.false.
  1090. else
  1091. CALL IDGRAD (MFR,IFO1,MOGRA1,NGRA1,NFAC)
  1092. endif
  1093. ELSE IF (TIT1.EQ.'GRADIENT DE FLEXION') THEN
  1094. if(lnomid(11).ne.0) then
  1095. nomid=lnomid(11)
  1096. segact nomid
  1097. mogra1=nomid
  1098. ngra1=lesobl(/2)
  1099. nfac=lesfac(/2)
  1100. lsupg1=.false.
  1101. else
  1102. CALL IDGRAF (MFR,IFO1,MOGRA1,NGRA1,NFAC)
  1103. endif
  1104. ELSE
  1105. CALL ERREUR (21)
  1106. SEGSUP MCHELM
  1107. IPCHMU=0
  1108. RETURN
  1109. ENDIF
  1110. *
  1111. lsupg2=.true.
  1112. IF (TIT2.EQ.'GRADIENT DE FLEXION') THEN
  1113. if(lnomid(11).ne.0) then
  1114. nomid=lnomid(11)
  1115. segact nomid
  1116. mogra2=nomid
  1117. ngra2=lesobl(/2)
  1118. nfac=lesfac(/2)
  1119. lsupg2=.false.
  1120. else
  1121. CALL IDGRAF (MFR,IFO2,MOGRA2,NGRA2,NFAC)
  1122. endif
  1123. ELSE IF (TIT2.EQ.'GRADIENT') THEN
  1124. if(lnomid(3).ne.0) then
  1125. nomid=lnomid(3)
  1126. segact nomid
  1127. mogra2=nomid
  1128. ngra2=lesobl(/2)
  1129. nfac=lesfac(/2)
  1130. lsupg2=.false.
  1131. else
  1132. CALL IDGRAD (MFR,IFO2,MOGRA2,NGRA2,NFAC)
  1133. endif
  1134. ELSE
  1135. CALL ERREUR (21)
  1136. SEGSUP MCHELM
  1137. NOMID=MOGRA1
  1138. if(lsupg1)SEGSUP NOMID
  1139. IPCHMU=0
  1140. RETURN
  1141. ENDIF
  1142. *
  1143. NBTYPE=1
  1144. SEGINI NOTYPE
  1145. MOTYPE=NOTYPE
  1146. TYPE(1)='REAL*8'
  1147. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRA1,MOTYPE,
  1148. 1 1,INFOS,3,IVAGR1)
  1149. SEGSUP NOTYPE
  1150. IF (IERR.NE.0) GOTO 5998
  1151. *
  1152. NBTYPE=1
  1153. SEGINI NOTYPE
  1154. MOTYPE=NOTYPE
  1155. TYPE(1)='REAL*8'
  1156. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOGRA2,
  1157. 1 MOTYPE,1,INFOS,3,IVAGR2)
  1158. SEGSUP NOTYPE
  1159. IF (IERR.NE.0) GOTO 5999
  1160. *
  1161. * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  1162. *
  1163. N1PTEL=0
  1164. N1EL=0
  1165. MPTVAL=IVAGR1
  1166. DO 520 IO=1,NGRA1
  1167. MELVAL=IVAL(IO)
  1168. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  1169. N1EL =MAX(N1EL ,VELCHE(/2))
  1170. 520 CONTINUE
  1171. *
  1172. * CREATION DU MCHAML DE LA SOUS ZONE
  1173. *
  1174. N2=NGRA1
  1175. SEGINI MCHAML
  1176. ICHAML(ISOUS)=MCHAML
  1177. NSR=1
  1178. NCOSOR=NGRA1
  1179. SEGINI MPTVAL
  1180. IVARES=MPTVAL
  1181. NOMID=MOGRA1
  1182. SEGACT NOMID
  1183. DO 521 ICOMP=1,NGRA1
  1184. NOMCHE(ICOMP)=LESOBL(ICOMP)
  1185. TYPCHE(ICOMP)='REAL*8'
  1186. N2PTEL=0
  1187. N2EL=0
  1188. SEGINI MELVAL
  1189. IELVAL(ICOMP)=MELVAL
  1190. IVAL(ICOMP)=MELVAL
  1191. 521 CONTINUE
  1192. *
  1193. NBPTEL=N1PTEL
  1194. NEL =N1EL
  1195. *
  1196. DO 502 IGAU=1,NBPTEL
  1197. DO 5020 IB=1,NEL
  1198. C Gradient d'un champ scalaire (1, 2 ou 3 composantes en fct. de IDIM)
  1199. IF (NGRA1.EQ.IDIM) THEN
  1200. C 1e composante
  1201. MPTVAL=IVAGR1
  1202. MELVAL=IVAL(1)
  1203. IGMN1=MIN(IGAU,VELCHE(/1))
  1204. IBMN1=MIN(IB ,VELCHE(/2))
  1205. XTT1=VELCHE(IGMN1,IBMN1)
  1206. MPTVAL=IVAGR2
  1207. MELVAL=IVAL(1)
  1208. IGMN2=MIN(IGAU,VELCHE(/1))
  1209. IBMN2=MIN(IB ,VELCHE(/2))
  1210. XTT2=VELCHE(IGMN2,IBMN2)
  1211. MPTVAL=IVARES
  1212. MELVAL=IVAL(1)
  1213. VELCHE(IGAU,IB)=XTT1*XTT2
  1214. IF (NGRA1.GT.1) THEN
  1215. C 2e composante
  1216. MPTVAL=IVAGR1
  1217. MELVAL=IVAL(2)
  1218. IGMN1=MIN(IGAU,VELCHE(/1))
  1219. IBMN1=MIN(IB ,VELCHE(/2))
  1220. XTT1=VELCHE(IGMN1,IBMN1)
  1221. MPTVAL=IVAGR2
  1222. MELVAL=IVAL(2)
  1223. IGMN2=MIN(IGAU,VELCHE(/1))
  1224. IBMN2=MIN(IB ,VELCHE(/2))
  1225. XTT2=VELCHE(IGMN2,IBMN2)
  1226. MPTVAL=IVARES
  1227. MELVAL=IVAL(2)
  1228. VELCHE(IGAU,IB)=XTT1*XTT2
  1229. ENDIF
  1230. C 3e composante
  1231. IF (NGRA1.EQ.3) THEN
  1232. MPTVAL=IVAGR1
  1233. MELVAL=IVAL(3)
  1234. IGMN1=MIN(IGAU,VELCHE(/1))
  1235. IBMN1=MIN(IB ,VELCHE(/2))
  1236. XTT1=VELCHE(IGMN1,IBMN1)
  1237. MPTVAL=IVAGR2
  1238. MELVAL=IVAL(3)
  1239. IGMN2=MIN(IGAU,VELCHE(/1))
  1240. IBMN2=MIN(IB ,VELCHE(/2))
  1241. XTT2=VELCHE(IGMN2,IBMN2)
  1242. MPTVAL=IVARES
  1243. MELVAL=IVAL(3)
  1244. VELCHE(IGAU,IB)=XTT1*XTT2
  1245. ENDIF
  1246. *
  1247. C Gradient du deplacement (9 composantes, quel que soit IDIM)
  1248. ELSEIF (NGRA1.EQ.9) THEN
  1249. DO 503 ID=1,3
  1250. CC=0.D0
  1251. DO 504 JA=1,3
  1252. MPTVAL=IVAGR1
  1253. MELVAL=IVAL(JA)
  1254. IGMN1=MIN(IGAU,VELCHE(/1))
  1255. IBMN1=MIN(IB ,VELCHE(/2))
  1256. XTT1=VELCHE(IGMN1,IBMN1)
  1257. *
  1258. JB=3*(JA-1)+ID
  1259. *
  1260. MPTVAL=IVAGR2
  1261. MELVAL=IVAL(JB)
  1262. IGMN2=MIN(IGAU,VELCHE(/1))
  1263. IBMN2=MIN(IB ,VELCHE(/2))
  1264. XTT2=VELCHE(IGMN2,IBMN2)
  1265. *
  1266. CC = CC + XTT1 * XTT2
  1267. 504 CONTINUE
  1268. MPTVAL=IVARES
  1269. MELVAL=IVAL(ID)
  1270. VELCHE(IGAU,IB)=CC
  1271. 503 CONTINUE
  1272. *
  1273. DO 505 ID=4,6
  1274. CC=0.D0
  1275. DO 506 JA=4,6
  1276. MPTVAL=IVAGR1
  1277. MELVAL=IVAL(JA)
  1278. IGMN1=MIN(IGAU,VELCHE(/1))
  1279. IBMN1=MIN(IB ,VELCHE(/2))
  1280. XTT1=VELCHE(IGMN1,IBMN1)
  1281. *
  1282. JB=3*(JA-5)+ID
  1283. *
  1284. MPTVAL=IVAGR2
  1285. MELVAL=IVAL(JB)
  1286. IGMN2=MIN(IGAU,VELCHE(/1))
  1287. IBMN2=MIN(IB ,VELCHE(/2))
  1288. XTT2=VELCHE(IGMN2,IBMN2)
  1289. *
  1290. CC = CC + XTT1 * XTT2
  1291. 506 CONTINUE
  1292. MPTVAL=IVARES
  1293. MELVAL=IVAL(ID)
  1294. VELCHE(IGAU,IB)=CC
  1295. 505 CONTINUE
  1296. *
  1297. DO 507 ID=7,9
  1298. CC=0.D0
  1299. DO 508 JA=7,9
  1300. MPTVAL=IVAGR1
  1301. MELVAL=IVAL(JA)
  1302. IGMN1=MIN(IGAU,VELCHE(/1))
  1303. IBMN1=MIN(IB ,VELCHE(/2))
  1304. XTT1=VELCHE(IGMN1,IBMN1)
  1305. *
  1306. JB=3*(JA-9)+ID
  1307. *
  1308. MPTVAL=IVAGR2
  1309. MELVAL=IVAL(JB)
  1310. IGMN2=MIN(IGAU,VELCHE(/1))
  1311. IBMN2=MIN(IB ,VELCHE(/2))
  1312. XTT2=VELCHE(IGMN2,IBMN2)
  1313. *
  1314. CC = CC + XTT1 * XTT2
  1315. 508 CONTINUE
  1316. MPTVAL=IVARES
  1317. MELVAL=IVAL(ID)
  1318. VELCHE(IGAU,IB)=CC
  1319. 507 CONTINUE
  1320. ELSE
  1321. CALL ERREUR(26)
  1322. GOTO 5998
  1323. ENDIF
  1324. 5020 CONTINUE
  1325. 502 CONTINUE
  1326. *
  1327. if (ivagr1.ne.0) CALL DTMVAL(IVAGR1,1)
  1328. if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1329. IF (IVARES.NE.0) CALL DTMVAL(IVARES,1)
  1330. *
  1331. NOMID=MOGRA1
  1332. if(lsupg1)SEGSUP NOMID
  1333. IF (MOGRA2.NE.MOGRA1) THEN
  1334. NOMID=MOGRA2
  1335. if(lsupg2)SEGSUP NOMID
  1336. ENDIF
  1337. *
  1338. * SEGSUP INFO
  1339. GOTO 200
  1340. *
  1341. * ERREUR DESACTIVATION ET RETOUR
  1342. *
  1343. 5999 CONTINUE
  1344. if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1345. *
  1346. 5998 CONTINUE
  1347. if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1348. NOMID=MOGRA1
  1349. if(lsupg1)SEGSUP NOMID
  1350. IF (MOGRA1.NE.MOGRA2) THEN
  1351. NOMID=MOGRA2
  1352. if(lsupg2)SEGSUP NOMID
  1353. ENDIF
  1354. * SEGSUP INFO
  1355. SEGSUP MCHELM
  1356. RETURN
  1357. ENDIF
  1358. *
  1359. 200 CONTINUE
  1360. *
  1361. * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1
  1362. * DESACTIVATON DES SEGMENTS
  1363. *
  1364. IF (K.NE.4 .AND. K.NE.5) THEN
  1365. SEGSUP MTRAA
  1366. ENDIF
  1367. *
  1368. RETURN
  1369. *
  1370. 9999 CONTINUE
  1371. SEGSUP MCHELM
  1372. SEGSUP MTRAA
  1373. *
  1374. 666 CONTINUE
  1375. IPCHMU=0
  1376.  
  1377. RETURN
  1378. END
  1379.  
  1380.  

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