Sources Esope | Cast3M

resou1
C RESOU1    SOURCE    MB234859  26/08/26    21:15:17     12626          
      SUBROUTINE RESOU1(KRIGI,IDAMEM,
     &                  NOID,NOEN,PREC,ISTAB,ISOUCI,INSYM,IGRADJ)
C----------------------------------------------------------------------
C          Assemblage et inversion de la matrice de rigidite
C
C Methode de resolution utilisee
C   IGRADJ = 0 : resolution directe
C   IGRADJ = 1 : resolution iterative
C Pour la resolution directe
C   INSYM  = 0 si toutes les matrices sont symetriques
C   INSYM  = 1 si au moins une matrice est non symetrique
C Si la solution trouvee n'est pas suffisamment precise
C   ISOUCI = 0 affichera une erreur
C   ISOUCI = 1 affichera un souci
C Si l'operateur de resolution n'est pas positif alors
C   ISTAB  = 0 ne fera rien de plus
C   ISTAB  = 1 augmentera le terme diagonal
C Si le systeme est singulier alors
C   NOEN   = 0 retourne un CHPOINT contenant les DDLs des modes
C              d'ensemble actifs et le nombre de modes actifs
C   NOEN   = 1 ne renvoie pas d'informations supplementaires
C
C En sortie, l'element ICHOLE de la rigidite de pointeur KRIGI contient 
C le pointeur de la matrice factorisee. Les vecteurs solutions ont leur 
C pointeur stockes dans le tableau IDAMEM.
C----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER OOOVAL
      SEGMENT IDEMEM(0)
-INC SMRIGID
-INC SMVECTD
-INC PPARAM
-INC CCOPTIO
-INC SMMATRI
C
      MRIGID=KRIGI
      SEGACT MRIGID
      LAGDUA=IMLAG
      ICHOLX=ICHOLE
      SEGDES MRIGID
C
      IF (ICHOLX.NE.0) THEN
        MMATRI=ICHOLX
        SEGACT,MMATRI
C
C       Resolution iterative et matrice deja factorisee
        IF (IGRADJ.EQ.1) GOTO 1
C
C       Resolution directe et matrice deja factorisee
        IF (MFACT.EQ.0) GOTO 1
C
C       C'est XZPREC qui est utilise, ce test semble inutile 
C       IF (PRCHLV.lt.PREC*1.001.and.PRCHLV.gt.PREC*0.999) GOTO 1
C
        MILIGN=IILIGN
        SEGACT,MILIGN
        CALL OOOFRC(1)
        DO 20 I=1,ILIGN(/1)
          LIGN=ILIGN(I)
          SEGSUP,LIGN
  20    CONTINUE
        IF (IILIGS.NE.0) THEN
          MILIG1=IILIGS
          DO I=1,ILIGN(/1)
            LIGN=MILIG1.ILIGN(I)
            SEGSUP LIGN
          ENDDO
        ENDIF
        MDIAG=IDIAG
        SEGSUP MDIAG
        MDNOR=IDNORM
        SEGSUP MDNOR
        SEGSUP MMATRI
        CALL OOOFRC(0)
        ICHOLX=0
      ENDIF
C
      CALL TRIANG(KRIGI,PREC,ISTAB,IGRADJ,INSYM)
      IF (IERR.NE.0) GOTO 5000
C
      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 CHV2(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/GRACO6 :
C
        IF (IIMPI.EQ.1) THEN
          WRITE(IOIMP,499)
 499      FORMAT('  TEMPS SUIVANT AVANT APPEL MONDES/GRACO6')
          CALL GIBTEM(XKT)
          INTERR(1)=INT(XKT)
          CALL ERREUR(-259)
        ENDIF
C
        IF (IGRADJ.EQ.0) THEN
          CALL MONDES(ICHOLX,MVECTX,NOEN,ISOUCI,LAGDUA)
          MVECTY=MVECTX
        ELSE
          CALL GRACO6(ICHOLX,MVECTX,NOEN,MSOL,lenb)
          MVECTY=MSOL
        ENDIF
        IF (IERR.NE.0) GOTO 5000
C
        IF (IIMPI.EQ.1) THEN
          WRITE(IOIMP,498)
 498      FORMAT('  TEMPS SUIVANT APRES APPEL MONDES/GRACO6')
          CALL GIBTEM(XKT)
          INTERR(1)=INT(XKT)
          CALL ERREUR(-259)
        ENDIF
C
C **** SUBROUTINE VCH1 : REMET LE VECTEUR SOUS FORME D UN CHPOINT
C **** LE CHPOINT EST DE TYPE PREMIER MEMBRE
C
        MVECTA=MVECTY
        DO 5 K=1,NN
          IF (NN.EQ.1) GO TO 10
          IF (K.EQ.1) THEN
            INC=INK
            MVECT1=MVECTY
            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
****  SEGDES IDEMEM
C
 5000 CONTINUE
      RETURN
      END