Télécharger muchsc.eso

Retour à la liste

Numérotation des lignes :

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

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