Télécharger muchsc.eso

Retour à la liste

Numérotation des lignes :

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

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