Télécharger muchsc.eso

Retour à la liste

Numérotation des lignes :

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

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