Sources Esope | Cast3M

shole3
C SHOLE3    SOURCE    MB234859  26/01/26    21:15:12     12460          
      SUBROUTINE SHOLE3(IPREL,IDERL,LPL,KIDEPN,IMASQ,
     &                  IPPR,IDDR,NBG1,IVPO1)
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC SMRIGID
-INC CCHOLE
-INC CCREEL
      DIMENSION IVPO1(*),IMASQ(*)
C
C     Recuperer en cas de super element dans cchole
      nbnnma=nbnnmc
C
C     Nombre de ddl sur chaque ligne
      NA=IDERL-IPREL+1
      NA1=IDDR-IPPR+1
C     Nombre de termes sur la ligne
      nval=lpl
C     Colonne de la premiere valeur non nulle
      idepv=iprel-nval+1
C
C     Ne faire les operations que si le masque est nul
      kidepg=kidepn
      icpt=0
      do 121 im1=1,na1
        icmv=ippr+im1-idepv
        if(icmv.le.0) goto 121
        imsq=imasq(masqa(icmv))
        if (imsq.le.0) goto 121
        imh=masqh(imsq)+masqd(icmv)-1
        if ((imh+IDEPV-1).lt.ippr) goto 121
        imh=masqb(imsq)+masqd(icmv)-1
        if ((imh+IDEPV-1).gt.iddr) goto 121
C
        IPOSI=ICMV-MASQD(ICMV)+1
        IF (IMSQ.LE.0) THEN
          msqb=iposi
          msqh=iposi
        ELSE
          MSQH=MAX(MASQH(IMSQ),IPOSI)
          MSQB=MIN(MASQB(IMSQ),IPOSI)
        ENDIF
        IMASQ(MASQA(ICMV))=MASQV(MSQB,MSQH)
C
        kidepg=max(kidepg,icmv)
        icpt=icpt+1
 121  continue
C
      if (icpt.eq.na1) then
        kidepn=max(kidepn,ippr+na1-1-idepv+1)
        goto 998
      endif
C
      nval1=ivpo1(2*(nbg1+1)-1)-1                 
      idepv1=ippr-nval1+1
      imb=idepv1-idepv
C
C     Boucles sur les groupes de valeurs (hors groupe diagonal)
      DO 10 IG1=1,NBG1-1
        ildeb1=ivpo1(2*ig1)
        ilfin1=ivpo1(2*(ig1+1))-1
        ideb1=ivpo1(2*ig1-1)
        ifin1=ideb1+ilfin1-ildeb1
        ifin1=min(ifin1,nbnnma-idepv1+1)
C
        ideb1n=max(1-imb,ideb1)
        long=ifin1-ideb1n+1
        lond=min(long,kidepg-imb-ideb1n+1)
        ifin1=lond+ideb1n-1
C
        IF (IFIN1.LT.1-IMB)  GOTO 10
        IF (IDEB1N.GT.IFIN1) GOTO 10
        IF (LOND.LE.0)       GOTO 10
C
        MIPOSR=MASQA(IDEB1N+IMB)
        MIFIN1=MASQA(IFIN1 +IMB)
  15    CONTINUE
        IF (MIPOSR.GT.MIFIN1) GOTO 10
        IMSQ=IMASQ(MIPOSR)
        IF (IMSQ.LE.0) THEN
          IMSQ=-IMSQ
          IF (IMSQ.GT.(IFIN1+IMB))  GOTO 10
        ELSE
**msq
          IMSQ=masqh(imsq)+(miposr-1)*masdim
          IF (IMSQ.LT.(IDEB1N+IMB)) THEN
            MIPOSR=MIPOSR+1
            GOTO 15
          ENDIF
        ENDIF
C
        IVAB=IPPR-IDEPV+1
        DO 300 IA1=0,NA1-1
          IVAD=IVAB+IA1
          IPOSI=IVAD-MASQD(IVAD)+1
          MVAD=MASQA(IVAD)
          IMSQ=IMASQ(MVAD)
          IF (IMSQ.LE.0) THEN
            MSQH=IPOSI
            MSQB=IPOSI
          ELSE
            MSQH=MAX(MASQH(IMSQ),IPOSI)
            MSQB=MIN(MASQB(IMSQ),IPOSI)
          ENDIF
          IMASQ(MVAD)=MASQV(MSQB,MSQH)
  300   CONTINUE
C
C       Mise a jour du masque
        IUY=MASQB(IMASQ(MASQA(IVAB)))+MASQD(IVAB)-1
        DO IMT=MASQA(IVAB)-1,1,-1
          IF (IMASQ(IMT).GT.0) GOTO 215
C         IMASQ(IMT)=-IVAB
          IMASQ(IMT)=-IUY
        ENDDO
  215   CONTINUE
C
        kidepn=max(kidepn,ivad)
C
        GOTO 999
  10  CONTINUE
C
  999 CONTINUE
C
C     Le groupe diagonal
      ivadb=ippr-idepv+1
      do 210 im=1,na
        ivac=(im-1)*lpl+((im-2)*(im-1))/2
        do 220 im1=1,na1
          ideb1=ivpo1(2*nbg1-1)
          ideb1n=max(1-imb,ideb1)
          ifin1=ideb1+im1-2
          ifin1=min(ifin1,nbnnma-idepv1+1)
C
          if (ifin1-ideb1n.ge.0) then
            ivad=ippr-idepv+im1+ivac
            if (ivad.lt.1) goto 220
            ivadb=ippr-idepv+im1
            if (ivadb.lt.1) goto 220
C
            iposr=ideb1n+imb
            do 200 ipos=ideb1n,ifin1
              miposr=masqa(iposr)
              imsq=imasq(miposr)
              if (imsq.le.0) goto 217
**msq
              msqh=MASQH(IMSQ)
              msqb=MASQB(IMSQ)
              if (msqh.eq.0) then
                write(*,*) 'erreur interne shole3'
                call erreur(5)
              endif
              imsq=msqh+MASQD(IPOSR)-1
              if (imsq.lt.(IDEB1N+IMB)) goto 217
C             if (imsq.ge.(IFIN1+IMB)) goto 217
              imsq=msqb+MASQD(IPOSR)-1
              if (imsq.gt.(IFIN1+IMB)) goto 217
C
              iadd=masqa(ivadb)
              iposi=ivadb-masqd(ivadb)+1
              IMSQ=IMASQ(iadd)
              IF (IMSQ.LE.0) THEN
                MSQH=IPOSI
                MSQB=IPOSI
              ELSE
                MSQH=MAX(MASQH(IMSQ),IPOSI)
                MSQB=MIN(MASQB(IMSQ),IPOSI)
              ENDIF
              IMASQ(IADD)=MASQV(MSQB,MSQH)
C
              IUY=MASQB(IMASQ(IADD))+MASQD(IVADB)-1
              do imt=iadd-1,1,-1
                if (imasq(imt).gt.0) goto 213
C               imasq(imt)=-IVADB
                imasq(imt)=-IUY
              enddo
 217          continue
              iposr=iposr+1
 200        continue
            goto 220
 213        continue
            kidepn=max(kidepn,ivadb)
          endif
 220    continue
 210  continue
C
  998 CONTINUE
      END