Télécharger la plaquette Cast3M


fr en

Télécharger kmfn.eso

Retour à la liste

Numérotation des lignes : 

kmfn

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

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