Télécharger kmfn.eso

Retour à la liste

Numérotation des lignes :

  1. C KMFN SOURCE PV 16/11/17 21:59:47 9180
  2. SUBROUTINE KMFN
  3. C ***********************************************************************
  4. C
  5. C Objet : Cet operateur calcule soit A * U
  6. C t
  7. C soit A U
  8. C Syntaxe :
  9. C CAS 1 /
  10. C
  11. C B = KMF MATRIK MCHPOI ;
  12. C
  13. C
  14. C CAS 2 /
  15. C
  16. C B = KMF MATRIK MCHPOI 'TRAN' ;
  17. C
  18. C MATRIK MATRICES ELEMENTAIRES
  19. C MCHPOI CHPOINT CONTENANT U
  20. C
  21. C ***********************************************************************
  22. IMPLICIT INTEGER(I-N)
  23. IMPLICIT REAL*8 (A-H,O-Z)
  24. -INC CCOPTIO
  25. -INC SMELEME
  26. POINTEUR MELEMP.MELEME,MELEMD.MELEME,MELEM1.MELEME
  27. POINTEUR ISPGD.MELEME
  28. -INC SMLENTI
  29. -INC SMCHPOI
  30. POINTEUR MCHINI.MCHPOI
  31. LOGICAL LNEW,LFIRST
  32. CHARACTER*8 NOMP,NOMD,NOMD0,LDLP,NOMDX
  33. CHARACTER*4 LISMOT(1)
  34. DATA LISMOT/'TRAN'/
  35. C****
  36. MPOVA1=0
  37. C write(6,*)' SUBROUTINE KMFN'
  38. C LECTURE DES ARGUMENTS
  39. CALL LIROBJ('MATRIK',MATRIK,1,IRET)
  40. IF(IRET.EQ.0) RETURN
  41. CALL LIROBJ('CHPOINT',MCHPOI,1,IRET)
  42. IF(IRET.EQ.0) RETURN
  43. CALL LIRMOT(LISMOT,1,ITRAN,0)
  44. ITRAN0=ITRAN
  45. SEGACT MATRIK
  46. SEGACT MCHPOI
  47. SEGINI,MCHINI=MCHPOI
  48. NSOUPO=0
  49. NAT=MCHINI.JATTRI(/1)
  50. SEGADJ MCHINI
  51. SEGDES MCHINI
  52. CALL ECROBJ('CHPOINT',MCHINI)
  53. NOMD0=' '
  54. MLENT2=0
  55. ISPGD0=0
  56. MCHPO1=0
  57. IT=0
  58. NMATRI=IRIGEL(/2)
  59. NSP2 =IPCHP(/1)
  60. LFIRST=.TRUE.
  61. DO 5000 IM=1,NMATRI
  62. IKT=1
  63. IMATRI=IRIGEL(4,IM)
  64. SEGACT IMATRI
  65. NBME =LIZAFM(/2)
  66. ITYM=IRIGEL(7,IM)
  67. IF(ITYM.EQ.4)ITRAN=0
  68. 777 CONTINUE
  69. DO 5001 LP=NBME,1,-1
  70. IF(ITRAN.EQ.0)THEN
  71. NOMP=LISPRI(LP)
  72. ELSE
  73. NOMP=LISDUA(LP)
  74. ENDIF
  75. C write(6,*)' LP,NBME,ITRAN,LISPRI(LP),LISDUA(LP)=',
  76. C &LP,NBME,ITRAN,LISPRI(LP),LISDUA(LP)
  77. DO 4000 KS=1,NSP2
  78. MSOUPO=IPCHP(KS)
  79. SEGACT MSOUPO
  80. NC=NOCOMP(/2)
  81. DO 4001 KC=1,NC
  82. C WRITE(IOIMP,*)'KMFN : NOCOMP=',NOCOMP(KC),' NOMP=',NOMP(1:4)
  83. IF (NOCOMP(KC).EQ.NOMP(1:4)) THEN
  84. IT=1
  85. MELEM1=IGEOC
  86. C In KRIPAD : SEGACT MELEM1
  87. C In KRIPAD : SEGINI MLENTI
  88. CALL KRIPAD(MELEM1,MLENTI)
  89. C segact melem1
  90. C nk1=melem1.num(/1)
  91. C nk2=melem1.num(/2)
  92. C write(6,*)'Controle MELEM1=IGEOC',MELEM1,NK1,NK2
  93. C write(6,1101)(melem1.num(1,kk),kk=1,nk2)
  94.  
  95. SEGDES MELEM1
  96. MPOVAL=IPOVAL
  97. SEGACT MPOVAL
  98. IF (ITRAN.EQ.0) THEN
  99. MELEMP=IRIGEL(1,IM)
  100. MELEMD=IRIGEL(2,IM)
  101. IKSPGD=KSPGD
  102. LDLP=LISDUA(LP)
  103. ELSE
  104. MELEMP=IRIGEL(2,IM)
  105. MELEMD=IRIGEL(1,IM)
  106. IKSPGD=KSPGP
  107. LDLP=LISPRI(LP)
  108. ENDIF
  109. ISPGD=ISPGD0
  110. NOMD=NOMD0
  111. LNEW=((ISPGD0.NE.IKSPGD).OR.(NOMD0.NE.LDLP))
  112. IF (LNEW) THEN
  113. IF (.NOT.LFIRST) THEN
  114. SEGSUP MLENT2
  115. SEGDES MPOVA1
  116. SEGDES MSOUP1
  117. SEGDES MCHPO1
  118. ELSE
  119. LFIRST=.FALSE.
  120. ENDIF
  121. IF (ITRAN.EQ.0) THEN
  122. NOMD=LISDUA(LP)
  123. NOMD0=LISDUA(LP)
  124. ISPGD=KSPGD
  125. ISPGD0=KSPGD
  126. ELSE
  127. NOMD=LISPRI(LP)
  128. NOMD0=LISPRI(LP)
  129. ISPGD=KSPGP
  130. ISPGD0=KSPGP
  131. ENDIF
  132. SEGACT ISPGD
  133. N=ISPGD.NUM(/2)
  134. NC=1
  135. C WRITE(IOIMP,*)' Creation MPOVA1 N,NC=',n,nc
  136. IF (MCHPO1.NE.0)THEN
  137. CALL ECROBJ('CHPOINT',MCHPO1)
  138. CALL PRFUSE
  139. CALL DTCHPO(MCHPO1)
  140. ENDIF
  141. SEGINI,MCHPO1=MCHPOI
  142. NSOUPO=1
  143. NAT=MCHPO1.JATTRI(/1)
  144. SEGADJ MCHPO1
  145. C WRITE(IOIMP,*)' On cree MPOVA1 -> ',NOMD(1:4)
  146. SEGINI MSOUP1
  147. SEGINI MPOVA1
  148. MCHPO1.IPCHP(NSOUPO)=MSOUP1
  149. MSOUP1.NOCOMP(1)=NOMD(1:4)
  150. MSOUP1.IGEOC=ISPGD
  151. MSOUP1.IPOVAL=MPOVA1
  152. C In KRIPAD : SEGINI MLENT2
  153. CALL KRIPAD(ISPGD,MLENT2)
  154. C segact ISPGD
  155. C nk1=ISPGD.num(/1)
  156. C nk2=ISPGD.num(/2)
  157. C write(6,*)'Controle ISPGD',ISPGD,NK1,NK2
  158. C write(6,1101)(ISPGD.num(1,kk),kk=1,nk2)
  159.  
  160. SEGDES ISPGD
  161. ENDIF
  162. C WRITE(IOIMP,*)' On charge dans ',MSOUP1.NOCOMP(1)
  163.  
  164.  
  165. C CALL VERPAD(MLENTI,MELEMP,IRET)
  166. C IRET=0
  167. C IF(IRET.NE.0)THEN
  168. C write(6,*)' VERPAD Pb MELEMP '
  169. C write(6,*)' MELEMP=',MELEMP,'ITRAN=',ITRAN
  170. C segact melemp
  171. C nk1= melemp.num(/1)
  172. C nk2= melemp.num(/2)
  173. C do 6317 kkk=1,nk2
  174. C write(6,1101)(melemp.num(kk,kkk),kk=1,nk1)
  175. C6317 continue
  176. C
  177. C
  178. C MOTERR(1:40)=' '
  179. C MOTERR(1:8) ='MATRIK '
  180. C MOTERR(9:16)='CHPOINT '
  181. C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16
  182. C CALL ERREUR(135)
  183. C RETURN
  184. C ENDIF
  185.  
  186. CALL VERPAD(MLENT2,MELEMD,IRET)
  187. C IRET=0
  188. IF(IRET.NE.0)THEN
  189. C write(6,*)' VERPAD Pb MELEMD '
  190. C write(6,*)' MELEMD=',MELEMD,'ITRAN=',ITRAN
  191. C segact melemd
  192. C nk1= melemd.num(/1)
  193. C nk2= melemd.num(/2)
  194. C do 6318 kkk=1,nk2
  195. C write(6,1101)(melemd.num(kk,kkk),kk=1,nk1)
  196. C6318 continue
  197.  
  198. MOTERR(1:40)=' '
  199. MOTERR(1:8) ='MATRIK '
  200. MOTERR(9:16)='CHPOINT '
  201. C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16
  202. CALL ERREUR(135)
  203. RETURN
  204. ENDIF
  205. SEGACT MELEMP
  206. SEGACT MELEMD
  207. NBSOUM=LIZAFM(/1)
  208.  
  209. NBSP=MELEMP.LISOUS(/1)
  210. NBSD=MELEMD.LISOUS(/1)
  211. IPT1=MELEMP
  212. IPT2=MELEMD
  213. IF(NBSP.NE.0)IPT1=MELEMP.LISOUS(1)
  214. IF(NBSD.NE.0)IPT2=MELEMD.LISOUS(1)
  215. SEGACT IPT1,IPT2
  216. NBELP=IPT1.NUM(/2)
  217. NBELD=IPT2.NUM(/2)
  218. KKP=0
  219. KKD=0
  220. NSP=1
  221. NSD=1
  222.  
  223. DO 4002 LS=1,NBSOUM
  224. IZAFM=LIZAFM(LS,LP)
  225. SEGACT IZAFM
  226. NBEL=AM(/1)
  227. NP=AM(/2)
  228. MP=AM(/3)
  229. C WRITE(IOIMP,*)' BCL 4002 LS=',ls,nbel,np,mp
  230. IF(ITRAN.EQ.0)THEN
  231. DO 4033 K=1,NBEL
  232. KKP=KKP+1
  233. KKD=KKD+1
  234.  
  235. DO 4034 J=1,MP
  236. U=0.D0
  237. DO 4035 I=1,NP
  238. I1=LECT(IPT1 .NUM(I,KKP))
  239. IF(I1.EQ.0)GO TO 4035
  240. U=U+AM(K,I,J)*VPOCHA(I1,KC)
  241. 4035 CONTINUE
  242. III=IPT2 .NUM(J,KKD)
  243. I2=MLENT2.LECT(III)
  244. MPOVA1.VPOCHA(I2,1)=MPOVA1.VPOCHA(I2,1)
  245. $ +U
  246. 4034 CONTINUE
  247. 4033 CONTINUE
  248.  
  249. IF(KKP.EQ.NBELP.AND.NSP.LT.NBSP)THEN
  250. NSP=NSP+1
  251. SEGDES IPT1
  252. IPT1=MELEMP.LISOUS(NSP)
  253. SEGACT IPT1
  254. NBELP=IPT1.NUM(/2)
  255. KKP=0
  256. ENDIF
  257.  
  258. IF(KKD.EQ.NBELD.AND.NSD.LT.NBSD)THEN
  259. NSD=NSD+1
  260. SEGDES IPT2
  261. IPT2=MELEMD.LISOUS(NSD)
  262. SEGACT IPT2
  263. NBELD=IPT2.NUM(/2)
  264. KKD=0
  265. ENDIF
  266.  
  267. ELSE
  268. DO 3033 K=1,NBEL
  269. KKP=KKP+1
  270. KKD=KKD+1
  271.  
  272. DO 3034 J=1,NP
  273. U=0.D0
  274. DO 3035 I=1,MP
  275. I1=LECT(IPT1 .NUM(I,KKP))
  276. IF(I1.EQ.0)GO TO 3035
  277. U=U+AM(K,J,I)*VPOCHA(I1,KC)
  278. 3035 CONTINUE
  279. I2=MLENT2.LECT(IPT2 .NUM(J,KKD))
  280. MPOVA1.VPOCHA(I2,1)=MPOVA1.VPOCHA(I2,1)
  281. $ +U
  282. 3034 CONTINUE
  283. 3033 CONTINUE
  284.  
  285. IF(KKP.EQ.NBELP.AND.NSP.LT.NBSP)THEN
  286. NSP=NSP+1
  287. SEGDES IPT1
  288. IPT1=MELEMP.LISOUS(NSP)
  289. SEGACT IPT1
  290. NBELP=IPT1.NUM(/2)
  291. KKP=0
  292. ENDIF
  293.  
  294. IF(KKD.EQ.NBELD.AND.NSD.LT.NBSD)THEN
  295. NSD=NSD+1
  296. SEGDES IPT2
  297. IPT2=MELEMD.LISOUS(NSD)
  298. SEGACT IPT2
  299. NBELD=IPT2.NUM(/2)
  300. KKD=0
  301. ENDIF
  302.  
  303. ENDIF
  304. SEGDES IZAFM
  305. 4002 CONTINUE
  306. SEGDES MELEMP
  307. SEGDES MELEMD
  308. SEGDES MPOVAL
  309. SEGSUP MLENTI
  310. ENDIF
  311. 4001 CONTINUE
  312. SEGDES MSOUPO
  313. 4000 CONTINUE
  314. 5001 CONTINUE
  315. C write(6,*)' ITYM,IKT,ITRAN=',ITYM,IKT,ITRAN
  316. IF(ITYM.EQ.4)THEN
  317. IF(IKT.EQ.1)THEN
  318. IKT=2
  319. ITRAN=1
  320. GO TO 777
  321. ELSE
  322. ITRAN=ITRAN0
  323. IKT=1
  324. ENDIF
  325. ENDIF
  326. SEGDES IMATRI
  327. 5000 CONTINUE
  328. SEGSUP MLENT2
  329. C write(6,*)' MPOVA1=',MPOVA1
  330. C write(6,*)' FIN SUBROUTINE KMFN'
  331. IF(MPOVA1.EQ.0)THEN
  332. MOTERR(1:40)=' '
  333. MOTERR(1:8) ='MATRIK '
  334. MOTERR(9:16)='CHPOINT '
  335. C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16
  336. CALL ERREUR(135)
  337. RETURN
  338. ENDIF
  339. c SEGDES MPOVA1
  340. SEGDES MSOUP1
  341. SEGDES MCHPO1
  342. C CALL DTCHPO(MCHINI)
  343. SEGDES MCHPOI
  344. SEGDES MATRIK
  345. IF(IT.EQ.1)THEN
  346. CALL ECROBJ('CHPOINT',MCHPO1)
  347. CALL PRFUSE
  348. CALL DTCHPO(MCHPO1)
  349. ELSE
  350. MOTERR(1:40)=' '
  351. MOTERR(1:8) ='MATRIK '
  352. MOTERR(9:16)='CHPOINT '
  353. C Incompatibilité entre l'objet %m1:8 et l'objet %m9:16
  354. CALL ERREUR(135)
  355. ENDIF
  356. RETURN
  357. 1101 FORMAT(20(1X,I5))
  358. END
  359.  
  360.  
  361.  
  362.  
  363.  
  364.  
  365.  
  366.  
  367.  
  368.  
  369.  
  370.  
  371.  

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