From K193301%CZHRZU1A.BitNet@wigate.nic.wisc.edu Wed Nov 17 17:38:01 1993
Received: from cs.wisc.edu by tilsit.cs.wisc.edu; Wed, 17 Nov 93 17:38:00 -0600
Received: from vms3.macc.wisc.edu by cs.wisc.edu; Wed, 17 Nov 93 17:37:58 -0600
Received: from CEARN by WISCMACC.BitNet; Wed, 17 Nov 93 17:38 CDT
Received: from CZHRZU1A.BITNET (NJE origin K193301@CZHRZU1A)
          by CEARN.CERN.CH (LMail V1.1d/1.7f) with RFC822 id 9051;
          Thu, 18 Nov 1993 00:35:22 +0100
Message-Id: <23111717385021@WISCMACC.BitNet>
Date: Thu, 18 Nov 93 00:35:44 GMT
From: "P. Kall" <K193301%CZHRZU1A.BitNet@wigate.nic.wisc.edu>
Subject: service.for
To: Spyros Kontogiorgis <kontogio>
*Destination: CS.WISC.EDU
Status: R


C=====================================================================
C                          S E R V I C E
C=====================================================================
C     Procedures in this file perform services, e.g. shaking a sparse
C     matrix
C=====================================================================
      SUBROUTINE XINDIC(INDIC,NONZ,INDX1,INDBND,MAXVC)
      INTEGER MAXVC,INDIC(MAXVC),NONZ,INDX1,INDBND,I
      INDX1=0
      IF (NONZ .EQ. INDBND) RETURN
   10 CALL INDEX(INDBND,INDX1)
      DO 20 I=1,NONZ
         IF (INDIC(I) .EQ. INDX1) GOTO 10
   20 CONTINUE
      END
C=====================================================================
      SUBROUTINE YINDIC(INDIC,NONZ,INDX1,INDLBD,NQ,MAXVC)
      INTEGER MAXVC,INDIC(MAXVC),NONZ,INDX1,INDLBD,NQ,NWRK,I
      NWRK=NQ-INDLBD+1
   10 CALL INDEX(NWRK,INDX1)
      INDX1=INDX1+INDLBD-1
      IF ( NONZ .EQ. 0) RETURN
      DO 20 I=1,NONZ
         IF (INDIC(I) .EQ. INDX1) GOTO 10
   20 CONTINUE
      END
C=====================================================================
      SUBROUTINE SHAKER
     *           (FREQ,
     *            ABYCOL,ROWNOS,COLPNT,MM,NN,NPOS1,WORK1,INDIC1,NONZR1,
     *            NPOS2,WORK2,INDIC2,NONZR2,WORK3,INDIC3,NONZR3,ISTAT,
     *            MAXNZ,MAXCOP,MAXVC)
      INTEGER MAXNZ,MAXCOP,MAXVC
      REAL*8  ABYCOL(MAXNZ)
      INTEGER ROWNOS(MAXNZ),COLPNT(MAXCOP)
      REAL*8  WORK1(MAXVC),WORK2(MAXVC),WORK3(MAXVC)
      INTEGER INDIC1(MAXVC),INDIC2(MAXVC),INDIC3(MAXVC),
     *        NONZR1,NONZR2,NONZR3
      INTEGER FREQ,MM,NN,NPOS1,NPOS2,ISTAT,DUMMY,I
      LOGICAL COIN
      DO 20 I=1,FREQ
         IF (COIN(DUMMY)) THEN
             CALL INDICS(MM,NPOS1,NPOS2)
             CALL EXCROW
     *            (ABYCOL,ROWNOS,COLPNT,MM,NN,
     *             WORK1,INDIC1,NONZR1,
     *             WORK2,INDIC2,NONZR2,
     *             WORK3,INDIC3,NONZR3,
     *             NPOS1,NPOS2,ISTAT,
     *             MAXNZ,MAXCOP,MAXVC)

                         ELSE
             CALL INDICS(NN,NPOS1,NPOS2)
             CALL EXCCOL
     *            (ABYCOL,ROWNOS,COLPNT,NN,
     *             WORK1,INDIC1,NONZR1,
     *             WORK2,INDIC2,NONZR2,
     *             NPOS1,NPOS2,ISTAT,
     *             MAXNZ,MAXCOP,MAXVC)
         ENDIF
   20 CONTINUE
      END
C=======================================================================
      SUBROUTINE ENTROP(FREQ,
     *            ABYCOL,ROWNOS,COLPNT,MM,NN,NPOS1,WORK1,INDIC1,NONZR1,
     *            NPOS2,WORK2,INDIC2,NONZR2,WORK3,INDIC3,NONZR3,ISTAT,
     *            MAXNZ,MAXCOP,MAXVC)
      INTEGER MAXNZ,MAXCOP,MAXVC
      REAL*8  ABYCOL(MAXNZ)
      INTEGER ROWNOS(MAXNZ),COLPNT(MAXCOP)
      REAL*8  WORK1(MAXVC),WORK2(MAXVC),WORK3(MAXVC)
      INTEGER INDIC1(MAXVC),INDIC2(MAXVC),INDIC3(MAXVC),
     *        NONZR1,NONZR2,NONZR3
      INTEGER FREQ,MM,NN,NPOS1,NPOS2,ISTAT,I
      DO 10 I=1,FREQ
         CALL INDICS(NN,NPOS1,NPOS2)
C        IF (I .EQ. NPOS1) NPOS1=NPOS2
         CALL EXCCOL
     *            (ABYCOL,ROWNOS,COLPNT,NN,
     *             WORK1,INDIC1,NONZR1,
     *             WORK2,INDIC2,NONZR2,
     *             NPOS1,NPOS2,ISTAT,
     *             MAXNZ,MAXCOP,MAXVC)
   10 CONTINUE
      END
C=======================================================================
      SUBROUTINE MIXARR
     *           (WORK1,INDIC1,NONZR1,
     *            WORK2,INDIC2,NONZR2,
     *            WORK3,INDIC3,NONZR3,
     *            DIMI,MAXVAL,INTVAL,NONZRS,ZERO,SIGDIG,
     *            MAXNZ,MAXCOP,MAXVC)
      INTEGER MAXNZ,MAXCOP,MAXVC
      REAL*8  WORK1(MAXVC),WORK2(MAXVC),WORK3(MAXVC),MAXVAL,ZERO
      INTEGER INDIC1(MAXVC),INDIC2(MAXVC),INDIC3(MAXVC),
     *        NONZR1,NONZR2,NONZR3
      INTEGER DIMI,NONZRS,INTVAL,SIGDIG,SIGDOG,XXXX
      REAL*8  CUTENT,WMAX
      INTEGER I,INX
      DO 100 I=1,DIMI
  100 WORK3(I)=0.0D0
      DO 110 I=1,NONZR1
         INX=INDIC1(I)
  110 WORK3(INX)=WORK3(INX)+WORK1(I)
      DO 120 I=1,NONZR2
         INX=INDIC2(I)
  120 WORK3(INX)=WORK3(INX)+WORK2(I)
      WMAX=0.0D0
      DO 130 I=1,DIMI
         IF( DABS(WORK3(I)) .GT. WMAX) WMAX=DABS(WORK3(I))
  130 CONTINUE

      WMAX=DABS(MAXVAL)/WMAX*0.9D0
      SIGDOG=SIGDIG
      IF (SIGDIG .GT. 1) SIGDOG=SIGDOG/2
      WMAX=CUTENT(WMAX,SIGDOG)
      DO 140 I=1,DIMI
         WORK3(I)=WORK3(I)*WMAX
         WORK3(I)=CUTENT(WORK3(I),SIGDIG)
  140 CONTINUE
      XXXX=0
      DO 160 I=1,DIMI
      IF (DABS(WORK3(I)) .GT. ZERO) XXXX=XXXX+1
  160 CONTINUE
      IF (XXXX .LE. NONZR2) RETURN
      NONZRS=NONZRS-NONZR2
      NONZR2=0
      DO 150 I=1,DIMI
         IF (DABS(WORK3(I)) .GT. ZERO) THEN
            NONZR2=NONZR2+1
            NONZRS=NONZRS+1
            WORK2(NONZR2)=WORK3(I)
            INDIC2(NONZR2)=I
         ENDIF
  150 CONTINUE
      END
C=====================================================================

