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

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