Télécharger muchsc.eso

Retour à la liste

Numérotation des lignes :

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

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