Télécharger kmfn.eso

Retour à la liste

Numérotation des lignes :

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

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