Télécharger muchsc.eso

Retour à la liste

Numérotation des lignes :

  1. C MUCHSC SOURCE GG250959 18/02/05 21:15:32 9734
  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. * SG 2018/01/16 si listmots donnes, on saute calpaq et on force le
  120. * calcul composante par composante
  121. *
  122. if (lmot1.gt.0) then
  123. K=3
  124. TITC=' '
  125. NUMCHA=1
  126. else
  127. CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,IRET)
  128. IF (IRET.EQ.0) GOTO 666
  129. endif
  130. * write(ioimp,*) 'muchsc : K=',K
  131. * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  132. lperm=(IPCHE1.ne.ipche10).or.(IPCHE2.ne.ipche20)
  133. * Dans le cas de la division on sort si l ordre a change
  134. IF (IINV.eq.-1) THEN
  135. IF (lperm) THEN
  136. write(ioimp,*) 'L ORDRE DES OPERANDES N A PAS PU ETRE CONSERVE'
  137. write(ioimp,*) 'VERIFIEZ LE TYPE DES CHAMELEM'
  138. MOTERR(1:8)=' / '
  139. call ERREUR(196)
  140. GOTO 666
  141. ENDIF
  142. * CAS NON ADMIS POUR LA DIVISION
  143. IF (K.EQ.4.OR.K.EQ.5) THEN
  144. CALL ERREUR (21)
  145. GOTO 666
  146. ENDIF
  147. ENDIF
  148. *
  149. MCHEL1 = IPCHE1
  150. MCHEL2 = IPCHE2
  151. c* SEGACT MCHEL1,MCHEL2 <- toujours ACTIFs
  152. TIT1 = MCHEL1.TITCHE
  153. TIT2 = MCHEL2.TITCHE
  154. NSOUS1 = MCHEL1.ICHAML(/1)
  155. NSOUS2 = MCHEL2.ICHAML(/1)
  156. *
  157. C Multiplication composante par composante :
  158. IF (K.EQ.3) THEN
  159. jgm1 = 0
  160. c noms de composante ?
  161. IF (lmot1.gt.0) then
  162. mlmot1 = lmot1
  163. segact mlmot1
  164. jgm1 = mlmot1.mots(/2)
  165. mlmot2 = lmot2
  166. segact mlmot2
  167. jgm2 = mlmot2.mots(/2)
  168. mlmot3 = lmot3
  169. segact mlmot3
  170. jgm3 = mlmot3.mots(/2)
  171. if ((jgm1.ne.jgm2) .or. (jgm1.ne.jgm3)) then
  172. segdes,mlmot1,mlmot2,mlmot3
  173. MOTERR(1:8)='LISTMOTS'
  174. MOTERR(9:16)='mots '
  175. call erreur(403)
  176. goto 666
  177. endif
  178. if (IPLREE.gt.0) then
  179. MLREE3 = IPLREE
  180. segact mlree3
  181. if (jgm1.ne.mlree3.prog(/1)) then
  182. segdes,mlmot1,mlmot2,mlmot3,mlree3
  183. MOTERR(1:8)='LIST****'
  184. MOTERR(9:16)='termes '
  185. call erreur(403)
  186. goto 666
  187. endif
  188. endif
  189. ENDIF
  190. ENDIF
  191.  
  192. IF (K.EQ.4.OR.K.EQ.5) THEN
  193.  
  194. * BESOIN DU MMODEL
  195. *
  196. IF (IPMODL.EQ.0) THEN
  197. MOTERR(1:8)='MMODEL '
  198. CALL ERREUR (37)
  199. GOTO 666
  200. ENDIF
  201. *
  202. * ACTIVATION DU MMODEL
  203. *
  204. MMODEL=IPMODL
  205. SEGACT MMODEL
  206. NSOUMO=KMODEL(/1)
  207. *
  208. * ON CREE UN CHAMELEM DE CONTRAINTE OU DE DEFORMATION ,
  209. * DE GRADIENT OU DE GRADIENT DE FLEXION.
  210. *
  211. L1=NUMCHA
  212. N1=NSOUMO
  213. N3=MCHEL1.INFCHE(/2)
  214. SEGINI MCHELM
  215. IPCHMU=MCHELM
  216. TITCHE=TITC
  217. IFOCHE=IFO1
  218. *
  219. * REMPLISSAGE DU CHAPEAU DU MCHAML
  220. *
  221. isouss=0
  222. DO 130 ISOUMO=1,NSOUMO
  223. IMODEL=KMODEL(ISOUMO)
  224. SEGACT IMODEL
  225. IPMAIL=IMAMOD
  226. CONM =CONMOD
  227. if((nefmod.eq.22).or.(nefmod.eq.259)) go to 134
  228. isouss=isouss+1
  229. DO 131 ISOUS1=1,NSOUS1
  230. IPMAI1=MCHEL1.IMACHE(ISOUS1)
  231. CONCH1=MCHEL1.CONCHE(ISOUS1)
  232. IF (IPMAIL.EQ.IPMAI1. AND.CONM.EQ.CONCH1) THEN
  233. DO 132 N33=1,N3
  234. INFCHE(isouss,N33)=MCHEL1.INFCHE(ISOUS1,N33)
  235. 132 CONTINUE
  236. IMACHE(ISOUss)=IPMAI1
  237. CONCHE(ISOUss)=CONCH1
  238. GOTO 134
  239. ENDIF
  240. 131 CONTINUE
  241. *
  242. * ERREUR PAS DE CORRESPONDANCE
  243. *
  244. SEGDES IMODEL
  245. SEGDES MMODEL
  246. SEGSUP MCHELM
  247. CALL ERREUR(103)
  248. GOTO 666
  249. 134 CONTINUE
  250. SEGDES IMODEL
  251. 130 CONTINUE
  252. if( nsoumo.ne.isouss) then
  253. n1=isouss
  254. segadj mchelm
  255. IPCHMU=mchelm
  256. endif
  257. nsous=isouss
  258. *
  259. ELSE
  260. *
  261. * QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2
  262. *
  263. LX=NSOUS1
  264. SEGINI MTRAA
  265. DO 110 ISOUS1=1,NSOUS1
  266. IPMAI1=MCHEL1.IMACHE(ISOUS1)
  267. CONCH1=MCHEL1.CONCHE(ISOUS1)
  268. DO 120 ISOUS2=1,NSOUS2
  269. IPMAI2=MCHEL2.IMACHE(ISOUS2)
  270. CONCH2=MCHEL2.CONCHE(ISOUS2)
  271. IF(IPMAI1.NE.IPMAI2) GOTO 120
  272. IF(CONCH1.NE.CONCH2) GOTO 120
  273. CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  274. IF (IRTD.EQ.0) GOTO 120
  275. IMINT1=0
  276. IMINT2=0
  277. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  278. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  279. IF (IMINT1.EQ.IMINT2) GOTO 121
  280. IMINT1=1
  281. IMINT2=1
  282. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  283. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  284. IF (IMINT1.EQ.0) IMINT1=1
  285. IF (IMINT2.EQ.0) IMINT2=1
  286. IF (IMINT1.EQ.IMINT2) GOTO 121
  287. *
  288. * ERREUR PAS DE CORRESPONDANCE 2 A 2
  289. *
  290. SEGSUP MTRAA
  291. MOTERR(1: 8) = TIT1(1:8)
  292. MOTERR(9:16) = TIT2(1:8)
  293. CALL ERREUR (175)
  294. GOTO 666
  295. 120 CONTINUE
  296. *
  297. * PAS DE CORRESPONDANCE 2 A 2
  298. *on essaye betement de voir si maillage identique avec 2 pointeurs differents
  299. *
  300. ipt1=ipmai1
  301. segact ipt1
  302. nbn1 = ipt1.num(/1)
  303. nel1 = ipt1.num(/2)
  304. DO 122 ISOUS2=1,NSOUS2
  305. IPMAI2=MCHEL2.IMACHE(ISOUS2)
  306. CONCH2=MCHEL2.CONCHE(ISOUS2)
  307. IF (CONCH1.NE.CONCH2) GOTO 122
  308. ipt2=ipmai2
  309. segact ipt2
  310. if(ipt1.itypel.ne.ipt2.itypel) then
  311. segdes ipt2
  312. go to 122
  313. endif
  314. nel2=ipt2.num(/2)
  315. if(nel1.ne.nel2) go to 122
  316. do 123 lo=1,nel1
  317. do 123 lp=1,nbn1
  318. if(ipt1.num(lp,lo).ne.ipt2.num(lp,lo) ) then
  319. segdes ipt2
  320. go to 122
  321. endif
  322. 123 continue
  323. IMINT1=0
  324. IMINT2=0
  325. IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  326. IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  327. IF (IMINT1.EQ.IMINT2) GOTO 124
  328. IMINT1=1
  329. IMINT2=1
  330. IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  331. IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6)
  332. IF (IMINT1.EQ.0) IMINT1=1
  333. IF (IMINT2.EQ.0) IMINT2=1
  334. IF (IMINT1.EQ.IMINT2) GOTO 124
  335. 122 continue
  336.  
  337. segdes ipt1
  338. SEGSUP MTRAA
  339. MOTERR(1:8) = TIT1(1:8)
  340. MOTERR(9:16) = TIT2(1:8)
  341. CALL ERREUR (175)
  342. GOTO 666
  343. *
  344. 124 CONTINUE
  345. segdes ipt1
  346.  
  347. 121 CONTINUE
  348. ITRAA(ISOUS1)=ISOUS2
  349. 110 CONTINUE
  350. *
  351. * CREATION DU MCHELM RESULTAT
  352. *
  353. NSOUS=NSOUS1
  354. SEGINI,MCHELM=MCHEL1
  355. IPCHMU=MCHELM
  356. ENDIF
  357. *
  358. *________________________________________________________________
  359. * BOUCLE SUR LES SOUS PAQUETS DE MCHELM
  360. *
  361. ISOUSS = 0
  362.  
  363. DO 200 ISOUS=1,NSOUS
  364.  
  365. ISOUSS = ISOUSS+1
  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. 4997 CONTINUE
  1102. IMODEL=KMODEL(ISOUSS)
  1103. SEGACT IMODEL
  1104. IPMAIL=IMAMOD
  1105. CONM =CONMOD
  1106. MELE=NEFMOD
  1107. IF ((MELE.EQ.259).OR.(MELE.EQ.22)) THEN
  1108. ISOUSS = ISOUSS+1
  1109. SEGDES IMODEL
  1110. goto 4997
  1111. ENDIF
  1112.  
  1113. *
  1114. * INFORMATION SUR L'ELEMENT FINI
  1115. *
  1116. CALL ELQUOI (MELE,0,6,IPINF,IMODEL)
  1117. IF (IERR.NE.0) THEN
  1118. SEGDES IMODEL,MMODEL
  1119. SEGSUP MCHELM
  1120. IPCHMU=0
  1121. RETURN
  1122. ENDIF
  1123. INFO=IPINF
  1124. MFR=INFELL(13)
  1125. segsup info
  1126. *
  1127. * CREATION DU TABLEAU INFOS
  1128. *
  1129. CALL IDENT (IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRTD)
  1130. *
  1131. lsupg1=.true.
  1132. IF (TIT1.EQ.'GRADIENT') THEN
  1133. if(lnomid(3).ne.0) then
  1134. nomid=lnomid(3)
  1135. segact nomid
  1136. mogra1=nomid
  1137. ngra1=lesobl(/2)
  1138. nfac=lesfac(/2)
  1139. lsupg1=.false.
  1140. else
  1141. CALL IDGRAD (MFR,IFO1,MOGRA1,NGRA1,NFAC)
  1142. endif
  1143. ELSE IF (TIT1.EQ.'GRADIENT DE FLEXION') THEN
  1144. if(lnomid(11).ne.0) then
  1145. nomid=lnomid(11)
  1146. segact nomid
  1147. mogra1=nomid
  1148. ngra1=lesobl(/2)
  1149. nfac=lesfac(/2)
  1150. lsupg1=.false.
  1151. else
  1152. CALL IDGRAF (MFR,IFO1,MOGRA1,NGRA1,NFAC)
  1153. endif
  1154. ELSE
  1155. CALL ERREUR (21)
  1156. SEGDES IMODEL,MMODEL
  1157. SEGSUP MCHELM
  1158. IPCHMU=0
  1159. RETURN
  1160. ENDIF
  1161. *
  1162. lsupg2=.true.
  1163. IF (TIT2.EQ.'GRADIENT DE FLEXION') THEN
  1164. if(lnomid(11).ne.0) then
  1165. nomid=lnomid(11)
  1166. segact nomid
  1167. mogra2=nomid
  1168. ngra2=lesobl(/2)
  1169. nfac=lesfac(/2)
  1170. lsupg2=.false.
  1171. else
  1172. CALL IDGRAF (MFR,IFO2,MOGRA2,NGRA2,NFAC)
  1173. endif
  1174. ELSE IF (TIT2.EQ.'GRADIENT') THEN
  1175. if(lnomid(3).ne.0) then
  1176. nomid=lnomid(3)
  1177. segact nomid
  1178. mogra2=nomid
  1179. ngra2=lesobl(/2)
  1180. nfac=lesfac(/2)
  1181. lsupg2=.false.
  1182. else
  1183. CALL IDGRAD (MFR,IFO2,MOGRA2,NGRA2,NFAC)
  1184. endif
  1185. ELSE
  1186. CALL ERREUR (21)
  1187. SEGDES IMODEL,MMODEL
  1188. SEGSUP MCHELM
  1189. NOMID=MOGRA1
  1190. if(lsupg1)SEGSUP NOMID
  1191. IPCHMU=0
  1192. RETURN
  1193. ENDIF
  1194. *
  1195. NBTYPE=1
  1196. SEGINI NOTYPE
  1197. MOTYPE=NOTYPE
  1198. TYPE(1)='REAL*8'
  1199. CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOGRA1,MOTYPE,
  1200. 1 1,INFOS,3,IVAGR1)
  1201. SEGSUP NOTYPE
  1202. IF (IERR.NE.0) GOTO 5998
  1203. *
  1204. NBTYPE=1
  1205. SEGINI NOTYPE
  1206. MOTYPE=NOTYPE
  1207. TYPE(1)='REAL*8'
  1208. CALL KOMCHA(IPCHE2,IPMAIL,CONM,MOGRA2,
  1209. 1 MOTYPE,1,INFOS,3,IVAGR2)
  1210. SEGSUP NOTYPE
  1211. IF (IERR.NE.0) GOTO 5999
  1212. *
  1213. * RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER
  1214. *
  1215. N1PTEL=0
  1216. N1EL=0
  1217. MPTVAL=IVAGR1
  1218. DO 520 IO=1,NGRA1
  1219. MELVAL=IVAL(IO)
  1220. N1PTEL=MAX(N1PTEL,VELCHE(/1))
  1221. N1EL =MAX(N1EL ,VELCHE(/2))
  1222. 520 CONTINUE
  1223. *
  1224. * CREATION DU MCHAML DE LA SOUS ZONE
  1225. *
  1226. N2=NGRA1
  1227. SEGINI MCHAML
  1228. ICHAML(ISOUS)=MCHAML
  1229. NS=1
  1230. NCOSOU=NGRA1
  1231. SEGINI MPTVAL
  1232. IVARES=MPTVAL
  1233. NOMID=MOGRA1
  1234. SEGACT NOMID
  1235. DO 521 ICOMP=1,NGRA1
  1236. NOMCHE(ICOMP)=LESOBL(ICOMP)
  1237. TYPCHE(ICOMP)='REAL*8'
  1238. N2PTEL=0
  1239. N2EL=0
  1240. SEGINI MELVAL
  1241. IELVAL(ICOMP)=MELVAL
  1242. IVAL(ICOMP)=MELVAL
  1243. 521 CONTINUE
  1244. SEGDES NOMID
  1245. *
  1246. NBPTEL=N1PTEL
  1247. NEL =N1EL
  1248. *
  1249. DO 502 IGAU=1,NBPTEL
  1250. DO 502 IB=1,NEL
  1251. C Gradient d'un champ scalaire (1, 2 ou 3 composantes en fct. de IDIM)
  1252. IF (NGRA1.EQ.IDIM) THEN
  1253. C 1e composante
  1254. MPTVAL=IVAGR1
  1255. MELVAL=IVAL(1)
  1256. IGMN1=MIN(IGAU,VELCHE(/1))
  1257. IBMN1=MIN(IB ,VELCHE(/2))
  1258. XTT1=VELCHE(IGMN1,IBMN1)
  1259. MPTVAL=IVAGR2
  1260. MELVAL=IVAL(1)
  1261. IGMN2=MIN(IGAU,VELCHE(/1))
  1262. IBMN2=MIN(IB ,VELCHE(/2))
  1263. XTT2=VELCHE(IGMN2,IBMN2)
  1264. MPTVAL=IVARES
  1265. MELVAL=IVAL(1)
  1266. VELCHE(IGAU,IB)=XTT1*XTT2
  1267. IF (NGRA1.GT.1) THEN
  1268. C 2e composante
  1269. MPTVAL=IVAGR1
  1270. MELVAL=IVAL(2)
  1271. IGMN1=MIN(IGAU,VELCHE(/1))
  1272. IBMN1=MIN(IB ,VELCHE(/2))
  1273. XTT1=VELCHE(IGMN1,IBMN1)
  1274. MPTVAL=IVAGR2
  1275. MELVAL=IVAL(2)
  1276. IGMN2=MIN(IGAU,VELCHE(/1))
  1277. IBMN2=MIN(IB ,VELCHE(/2))
  1278. XTT2=VELCHE(IGMN2,IBMN2)
  1279. MPTVAL=IVARES
  1280. MELVAL=IVAL(2)
  1281. VELCHE(IGAU,IB)=XTT1*XTT2
  1282. ENDIF
  1283. C 3e composante
  1284. IF (NGRA1.EQ.3) THEN
  1285. MPTVAL=IVAGR1
  1286. MELVAL=IVAL(3)
  1287. IGMN1=MIN(IGAU,VELCHE(/1))
  1288. IBMN1=MIN(IB ,VELCHE(/2))
  1289. XTT1=VELCHE(IGMN1,IBMN1)
  1290. MPTVAL=IVAGR2
  1291. MELVAL=IVAL(3)
  1292. IGMN2=MIN(IGAU,VELCHE(/1))
  1293. IBMN2=MIN(IB ,VELCHE(/2))
  1294. XTT2=VELCHE(IGMN2,IBMN2)
  1295. MPTVAL=IVARES
  1296. MELVAL=IVAL(3)
  1297. VELCHE(IGAU,IB)=XTT1*XTT2
  1298. ENDIF
  1299. *
  1300. C Gradient du deplacement (9 composantes, quel que soit IDIM)
  1301. ELSEIF (NGRA1.EQ.9) THEN
  1302. DO 503 ID=1,3
  1303. CC=0.D0
  1304. DO 504 JA=1,3
  1305. MPTVAL=IVAGR1
  1306. MELVAL=IVAL(JA)
  1307. IGMN1=MIN(IGAU,VELCHE(/1))
  1308. IBMN1=MIN(IB ,VELCHE(/2))
  1309. XTT1=VELCHE(IGMN1,IBMN1)
  1310. *
  1311. JB=3*(JA-1)+ID
  1312. *
  1313. MPTVAL=IVAGR2
  1314. MELVAL=IVAL(JB)
  1315. IGMN2=MIN(IGAU,VELCHE(/1))
  1316. IBMN2=MIN(IB ,VELCHE(/2))
  1317. XTT2=VELCHE(IGMN2,IBMN2)
  1318. *
  1319. CC = CC + XTT1 * XTT2
  1320. 504 CONTINUE
  1321. MPTVAL=IVARES
  1322. MELVAL=IVAL(ID)
  1323. VELCHE(IGAU,IB)=CC
  1324. 503 CONTINUE
  1325. *
  1326. DO 505 ID=4,6
  1327. CC=0.D0
  1328. DO 506 JA=4,6
  1329. MPTVAL=IVAGR1
  1330. MELVAL=IVAL(JA)
  1331. IGMN1=MIN(IGAU,VELCHE(/1))
  1332. IBMN1=MIN(IB ,VELCHE(/2))
  1333. XTT1=VELCHE(IGMN1,IBMN1)
  1334. *
  1335. JB=3*(JA-5)+ID
  1336. *
  1337. MPTVAL=IVAGR2
  1338. MELVAL=IVAL(JB)
  1339. IGMN2=MIN(IGAU,VELCHE(/1))
  1340. IBMN2=MIN(IB ,VELCHE(/2))
  1341. XTT2=VELCHE(IGMN2,IBMN2)
  1342. *
  1343. CC = CC + XTT1 * XTT2
  1344. 506 CONTINUE
  1345. MPTVAL=IVARES
  1346. MELVAL=IVAL(ID)
  1347. VELCHE(IGAU,IB)=CC
  1348. 505 CONTINUE
  1349. *
  1350. DO 507 ID=7,9
  1351. CC=0.D0
  1352. DO 508 JA=7,9
  1353. MPTVAL=IVAGR1
  1354. MELVAL=IVAL(JA)
  1355. IGMN1=MIN(IGAU,VELCHE(/1))
  1356. IBMN1=MIN(IB ,VELCHE(/2))
  1357. XTT1=VELCHE(IGMN1,IBMN1)
  1358. *
  1359. JB=3*(JA-9)+ID
  1360. *
  1361. MPTVAL=IVAGR2
  1362. MELVAL=IVAL(JB)
  1363. IGMN2=MIN(IGAU,VELCHE(/1))
  1364. IBMN2=MIN(IB ,VELCHE(/2))
  1365. XTT2=VELCHE(IGMN2,IBMN2)
  1366. *
  1367. CC = CC + XTT1 * XTT2
  1368. 508 CONTINUE
  1369. MPTVAL=IVARES
  1370. MELVAL=IVAL(ID)
  1371. VELCHE(IGAU,IB)=CC
  1372. 507 CONTINUE
  1373. ELSE
  1374. CALL ERREUR(26)
  1375. GOTO 5998
  1376. ENDIF
  1377. 502 CONTINUE
  1378. *
  1379. if (ivagr1.ne.0) CALL DTMVAL(IVAGR1,1)
  1380. if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1381. IF (IVARES.NE.0) CALL DTMVAL(IVARES,1)
  1382. *
  1383. NOMID=MOGRA1
  1384. if(lsupg1)SEGSUP NOMID
  1385. IF (MOGRA2.NE.MOGRA1) THEN
  1386. NOMID=MOGRA2
  1387. if(lsupg2)SEGSUP NOMID
  1388. ENDIF
  1389. *
  1390. * SEGSUP INFO
  1391. SEGDES IMODEL
  1392. GOTO 200
  1393. *
  1394. * ERREUR DESACTIVATION ET RETOUR
  1395. *
  1396. 5999 CONTINUE
  1397. if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1398. *
  1399. 5998 CONTINUE
  1400. if (ivagr2.ne.0) CALL DTMVAL(IVAGR2,1)
  1401. NOMID=MOGRA1
  1402. if(lsupg1)SEGSUP NOMID
  1403. IF (MOGRA1.NE.MOGRA2) THEN
  1404. NOMID=MOGRA2
  1405. if(lsupg2)SEGSUP NOMID
  1406. ENDIF
  1407. * SEGSUP INFO
  1408. SEGDES IMODEL,MMODEL
  1409. SEGSUP MCHELM
  1410. RETURN
  1411. ENDIF
  1412. *
  1413. 200 CONTINUE
  1414. *
  1415. * FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1
  1416. * DESACTIVATON DES SEGMENTS
  1417. *
  1418. IF (K.EQ.4.OR.K.EQ.5) THEN
  1419. SEGDES MMODEL
  1420. ELSE
  1421. SEGSUP MTRAA
  1422. ENDIF
  1423. IF (MLREE3.GT.0) SEGDES,MLREE3
  1424. SEGDES MCHELM
  1425. SEGDES MCHEL1,MCHEL2
  1426. *
  1427. RETURN
  1428. *
  1429. 9999 CONTINUE
  1430. SEGDES MCHAM1,MCHAM2
  1431. SEGSUP MCHELM
  1432. SEGSUP MTRAA
  1433. *
  1434. 666 CONTINUE
  1435. SEGDES MCHEL1,MCHEL2
  1436. IPCHMU=0
  1437.  
  1438. RETURN
  1439. END
  1440.  
  1441.  
  1442.  
  1443.  
  1444.  
  1445.  
  1446.  
  1447.  
  1448.  

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