Télécharger kmfn.eso

Retour à la liste

Numérotation des lignes :

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

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