Sources Esope | Cast3M

ldmt
C LDMT      SOURCE    GOUNAND   24/11/12    21:15:06     12076          
      SUBROUTINE LDMT(KRIGI,IDAMEM,NOID,NOEN,PREC,ISOUCI,LAGDUA)
C
C **** SUBROUTINE QUI EXECUTE L OPERATION RESOU
C      SUR DES MATRICES SANS SYMETRIES
C **** APPELEE PAR RESOU OU PAR SUPRI
C
C Elle est équivalente à RESOU1 dans le cas de l'inversion des
C matrices symétriques
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C  Auteur : Michel BULIK
C
C  Date : Printemps '95
C
C  Langage : ESOPE + FORTRAN77
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IMPLICIT INTEGER(I-N)
      REAL*8 XKT,PREC
      INTEGER OOOVAL
      SEGMENT IDEMEM(0)
-INC SMRIGID
-INC SMVECTD
-INC PPARAM
-INC CCOPTIO
-INC SMMATRI
C
      MRIGID=KRIGI
      SEGACT MRIGID
      ICHOLX=ICHOLE
      SEGDES MRIGID
      IF(ICHOLX.NE.0) then
       MMATRI=ICHOLX
       SEGACT MMATRI
       IF (PRCHLV.lt.PREC*1.001.and.PRCHLV.gt.PREC*0.999) GO TO 1
       write (6,*) ' attention changement de precision '
       MILIGN=IILIGN
       segact milign
       DO 20 I=1,ILIGN(/1)
        LIGN=ILIGN(I)
        SEGSUP LIGN
        SEGSUP LIGN
  20   CONTINUE
       MDIAG=IDIAG
       SEGSUP MDIAG
       MDNOR=IDNORM
       SEGSUP MDNOR
       SEGSUP MMATRI
       ICHOLX=0
      ENDIF
      CALL LDMT1(KRIGI,PREC)
      IF(IERR.NE.0) GO TO 5000
      MRIGID=KRIGI
      SEGACT MRIGID
      ICHOLX=ICHOLE
      SEGDES MRIGID
C
C **** SUBROUTINE CHV2 : TRANSFORME LE CHPOIN ISECO EN VECTEUR
C
 1    CONTINUE
      IDEMEM=IDAMEM
      SEGACT IDEMEM*MOD
      NNTOT=IDEMEM(/1)
      MMATRI=ICHOLX
      SEGACT MMATRI
      MILIGN=IILIGN
      SEGACT,MILIGN
      INK=IPNO(/1)
      SEGDES MILIGN,MMATRI
      CALL INTPDO(LENB)
      NNPA= MAX(1,((OOOVAL(1,1)-NGMAXY)/(2*LENB))/INK+1)
C
C  ON TRAVAILLE AVEC AUTANT DE VECTEUR SIMULTANEE QU'IL EN RENTRE DANS
C  LA MOITIE DE LA MEMOIRE CENTRALE
C
      NN=NNPA
      DO 201 KGEN = 1,NNTOT,NNPA
         IF(KGEN+NNPA-1.GT.NNTOT)  NN= NNTOT-KGEN+1
         KGEN1=KGEN-1
         DO 2 K=1,NN
         ISECO=IDEMEM(K+KGEN1)
            CALL CHVNS(ICHOLX,ISECO,MVECTX,NOID)
            IF(IERR.NE.0) GO TO 5000
            IDEMEM(K+KGEN1)=MVECTX
 2       CONTINUE
         IF(NN.NE.1) THEN
            INC = INK * NN
            SEGINI MVECTD
            DO 3 LL=1,NN
               LD=INK*(LL-1)
               MVECT1=IDEMEM(LL+KGEN1)
               SEGACT MVECT1
               DO  L=1,INK
                  VECTBB(L+LD)=MVECT1.VECTBB(L)
               ENDDO
               SEGSUP MVECT1
    3       CONTINUE
            MVECTX=MVECTD
            SEGDES MVECTD
         ENDIF
C
C **** SUBROUTINE MONDES :
C
         IF(IIMPI.EQ.1) THEN
            WRITE(IOIMP,499)
 499        FORMAT('  TEMPS SUIVANT  AVANT APPEL MONDES')
            CALL GIBTEM(XKT)
            INTERR(1)=INT(XKT)
            CALL ERREUR(-259)
         ENDIF
         CALL MONDES(ICHOLX,MVECTX,NOEN,ISOUCI,LAGDUA)
         IF(IIMPI.EQ.1) THEN
            WRITE(IOIMP,498)
 498        FORMAT('  TEMPS SUIVANT  APRES APPEL MONDES')
            CALL GIBTEM(XKT)
            INTERR(1)=INT(XKT)
            CALL ERREUR(-259)
         ENDIF
         IF(IERR.NE.0) GO TO 5000
C
C **** SUBROUTINE VCH1 : REMET LE VECTEUR SOUS FORME D UN CHPOINT
C **** LE CHPOINT EST DE TYPE PREMIER MEMBRE
C
         MVECTA=MVECTX
         DO 5 K=1,NN
            IF(NN.EQ.1) GO TO 10
            IF(K.EQ.1) THEN
               INC=INK
               MVECT1=MVECTX
               SEGACT MVECT1
               SEGINI MVECTD
            ENDIF
            SEGACT MVECTD*mod
            LD=(K-1)*INK
            DO 6 L=1,INK
               VECTBB(L)=MVECT1.VECTBB(L+LD)
    6       CONTINUE
            MVECTA=MVECTD
            SEGDES MVECTD
            IF(K.EQ.NN) SEGSUP MVECT1
   10       CONTINUE
            CALL VCH1(ICHOLX,MVECTA,ISOLU,KRIGI)
            IF(IERR.NE.0) RETURN
C
            IDEMEM(K+KGEN1)=ISOLU
   5     CONTINUE
         MVECTD=MVECTA
         SEGSUP  MVECTD
  201 CONTINUE
      IDAMEM = IDEMEM
C
 5000 CONTINUE
      RETURN
      END