




C






C

C





C


C



C



C



C



C


C


C


C


C


C


C


C



C



C



C


C
      SUBROUTINE GHS000


















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'







      ELLUNT=0
      GHSLEX=0
      GHSHEX=0
      CALL GVSRT0 (CNTGHS,MAXGHS)
      CALL GVSRT0 (LOWGHS,MAXGHS)
      CALL GVSRT0 (HGHGHS,MAXGHS)
      CALL GVSRT0 (ELLLOW,3)
      CALL GVSRT0 (ELLMID,3)
      CALL GVSRT0 (ELLHGH,3)





      RETURN
      END   
      SUBROUTINE GHS001 (NUMGHS,LOWVAL,HGHVAL,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       NUMGHS, IERR, I
      REAL          LOWVAL, HGHVAL
      LOGICAL       GVFIBN







      IF (.NOT.GVFIBN(NUMGHS,1,MAXGHS)) THEN
         IERR=1
         CALL GVSTTB ('?M2248')
         GOTO 998
      END IF
      IF (LOWVAL.GT.HGHVAL) CALL GVSWAP (LOWVAL,HGHVAL)



      GHSUSE=NUMGHS
      IERR=0
      STPGHS=(HGHVAL-LOWVAL)/FLOAT(NUMGHS)



      DO 100 I=1,NUMGHS
         LOWGHS(I)=LOWVAL+FLOAT(I-1)*STPGHS
         HGHGHS(I)=LOWVAL+FLOAT(I)*STPGHS
 100  CONTINUE



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS002 (VALUE)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IBIN
      REAL          VALUE
      LOGICAL       GVFRIN







      IF (VALUE.LT.LOWGHS(1)) THEN
         GHSLEX=GHSLEX+1
         GOTO 998
      END IF
      IF (VALUE.GT.HGHGHS(GHSUSE)) THEN
         GHSHEX=GHSHEX+1
         GOTO 998
      END IF



      DO 10 IBIN=1,GHSUSE
         IF (GVFRIN(VALUE,LOWGHS(IBIN),HGHGHS(IBIN))) THEN
            CNTGHS(IBIN)=CNTGHS(IBIN)+1.0
            GOTO 998
         END IF
 10   CONTINUE



      CALL GVSTTB ('?M2249')
      GOTO 998



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS003

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'DATBAS.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       I, IUPPER
      REAL          VALMAX, GVFMAX
      CHARACTER*30  CHAR30
      SAVE          CHAR30
      DATA CHAR30   /'=============================='/







      VALMAX=GVFMAX(CNTGHS,GHSUSE)



      CALL GVSFMT ('?FMT675')
      DO 100 I=1,GHSUSE
         CALL GVSCTB (LINE,80)
         WRITE (LINE(1:28),FMT,ERR=999) LOWGHS(I),HGHGHS(I),
     +    NINT(CNTGHS(I))
         IUPPER=NINT(30.0*CNTGHS(I)/VALMAX)
         IF (IUPPER.LT.0) IUPPER=0
         IF (IUPPER.GT.30) IUPPER=30
         CALL GVSSTX (LINE(31:60),CHAR30(1:IUPPER))
         CALL GVSTT6 (LINE)
         IF (DATOPE) CALL GVSTTU (DATLOG,LINE)
 100  CONTINUE
      CALL GVSNL6 (1)
      IF (GHSLEX.GT.0) CALL GVSTTI ('?M2250',GHSLEX) 
      IF (GHSHEX.GT.0) CALL GVSTTI ('?M2251',GHSHEX)
      IF (DATOPE) THEN
         IF (GHSLEX.GT.0) CALL GVSTUI (DATLOG,'?M2250',GHSLEX) 
         IF (GHSHEX.GT.0) CALL GVSTUI (DATLOG,'?M2251',GHSHEX)
      END IF 
      GOTO 998



 999  CONTINUE
      CALL GVSEIW ('GHS003')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS004

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       I, IUPPER, IERR
      REAL          VALMAX, GVFMAX
      LOGICAL       GRAPON
      CHARACTER*30  CHAR30







      IF (.NOT.GRAPON()) GOTO 998



      CALL GRTVIN
      VALMAX=GVFMAX(CNTGHS,GHSUSE)



      CALL GRTLIN (0.0,0.0,0.0, 20.0,0.0,0.0, 240, IERR)
      CALL GRTLIN (0.0,10.0,0.0, 0.0,0.0,0.0, 240, IERR)
      CALL GVSFMT ('?FMT675')
      DO 100 I=1,GHSUSE
         CALL GVSCTB (LINE,80)
         WRITE (LINE(1:28),FMT,ERR=999) LOWGHS(I),HGHGHS(I),
     +    NINT(CNTGHS(I))
         IUPPER=NINT(30.0*CNTGHS(I)/VALMAX)
         IF (IUPPER.LT.0) IUPPER=0
         IF (IUPPER.GT.30) IUPPER=30
         CALL GVSSTX (LINE(31:60),CHAR30(1:IUPPER))
         CALL GVSTT6 (LINE)
 100  CONTINUE
      CALL GVSTT6 (' ')
      IF (GHSLEX.GT.0) CALL GVSTTI ('?M2250',GHSLEX) 
      IF (GHSHEX.GT.0) CALL GVSTTI ('?M2251',GHSHEX) 
      GOTO 998



 999  CONTINUE
      CALL GVSEIW ('GHS004')



  998 CONTINUE


      RETURN
      END
      SUBROUTINE GHS005 (IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, IBIN, ICNT
      REAL          GVFRSM







      IF (GVFRSM(CNTGHS,GHSUSE).LT.0.1) THEN
         CALL GVSTTE ('?M3244')
         IERR=1
         GOTO 999
      END IF



      CALL GHS021 (0,0,IERR)



      DO 20 IBIN=1,GHSUSE
         IF (CNTGHS(GHSUSE).GT.0.1) THEN
            DO 10 ICNT=1,NINT(CNTGHS(GHSUSE))
               CALL GHS022 (0,(LOWGHS(IBIN)+HGHGHS(IBIN))/2.0,IERR)
               IF (IERR.NE.0) GOTO 999
 10         CONTINUE
         END IF
 20   CONTINUE
      GOTO 998



  999 CONTINUE
      CALL GVSEIW ('GHS005')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS011

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR







      IF (ELLUNT.NE.0) THEN
         CALL GVSTTI (' ',ELLUNT)
         CALL GVSCLF (ELLUNT)
      END IF
      CALL GVSROF (ELLUNT,IERR)
      IF (ELLUNT.LE.0.OR.IERR.NE.0) GO TO 999



      CALL GVSODF (ELLUNT,.FALSE.,'ELLIPS.XYZ','UNKNOWN',3,' ',IERR)
      IF (IERR.NE.0) GOTO 999



      CALL WIF083
      GOTO 998



 999  CONTINUE
      CALL GVSEIW ('GHS011')



 998  CONTINUE


      RETURN
      END   
      SUBROUTINE GHS012 (POINTR,X,Y,Z)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       POINTR
      REAL          X, Y, Z
      LOGICAL       GVFFOP







      IF (ELLUNT.LE.0) THEN
         CALL GVSTTE ('?M2814')
         GOTO 999
      ELSE IF (.NOT.GVFFOP(ELLUNT)) THEN
         CALL GVSTTE ('?M2815')
         GOTO 999
      END IF



      WRITE (ELLUNT,REC=POINTR,ERR=999) X,Y,Z
      GOTO 998



  999 CONTINUE
      CALL GVSEIW ('GHS012')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS013 (ILOW,IHGH,XC,YC,ZC,AVE,SDEV,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       I, ILOW, IHGH, IERR
      REAL          X, Y, Z, XC, YC, ZC, AVE, SDEV, GENDST
      LOGICAL       GVFFOP







      IF (ELLUNT.LE.0) THEN
         CALL GVSTTE ('?M2814')
         GOTO 999
      ELSE IF (.NOT.GVFFOP(ELLUNT)) THEN
         CALL GVSTTE ('?M2815')
         GOTO 999
      ELSE IF (IHGH-ILOW.LT.3) THEN
         CALL GVSTTE ('?M2824')
         GOTO 998
      END IF



      CALL GHS021 (0,0,IERR)
      IF (IERR.NE.0) GOTO 998



      DO 10 I=ILOW,IHGH
         READ (ELLUNT,REC=I,ERR=999) X,Y,Z
         GENDST=SQRT((X-XC)**2+(Y-YC)**2+(Z-ZC)**2)
         CALL GHS022 (I,GENDST,IERR)
         IF (IERR.NE.0) GOTO 998
 10   CONTINUE
      CALL GHS023 (ILOW,IHGH,AVE,SDEV,IERR)
      IF (IERR.NE.0) GOTO 998
      GOTO 998



  999 CONTINUE
      CALL GVSEIW ('GHS013')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS014 (ILOW,IHGH,IERR)

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       NUM, I, J, K, ILOW, IHGH, IERR
      REAL          MATRIX(3,3), CENTROID(3), X, Y, Z
      LOGICAL       GVFFOP







      IERR=1
      ELLWOK=.FALSE.
      NUM=IHGH-ILOW+1
      IF (ELLUNT.LE.0) THEN
         CALL GVSTTE ('?M2814')
         GOTO 998
      ELSE IF (.NOT.GVFFOP(ELLUNT)) THEN
         CALL GVSTTE ('?M2815')
         GOTO 998
      END IF      
      IF (NUM.LT.4) THEN
         CALL GVSTTE ('?M2816')
         GOTO 998
      END IF   



      IERR=0
      CALL GVSRT0 (ELLMAT,9)
      CALL GVSRT0 (ELLVEC,3)
      CALL GVSRT0 (CENTROID,3)
      CALL GVSRT0 (MATRIX,9)
      CALL GVSRT0 (ELLCEN,3)



      DO 10 I=ILOW,IHGH
         READ (ELLUNT,REC=I,ERR=998) X,Y,Z
         ELLCEN(1)=ELLCEN(1)+X
         ELLCEN(2)=ELLCEN(2)+Y
         ELLCEN(3)=ELLCEN(3)+Z
 10   CONTINUE
      CALL GVSVDI (ELLCEN,NUM,3)



      DO 40 K=ILOW,IHGH
         READ (ELLUNT,REC=K,ERR=998) X,Y,Z
         CV(1)=X-ELLCEN(1)
         CV(2)=Y-ELLCEN(2)
         CV(3)=Z-ELLCEN(3)
         DO 30 J=1,3
            CENTROID(J)=CENTROID(J)+CV(J)
            DO 20 I=1,3
               MATRIX(I,J)=MATRIX(I,J)+CV(I)*CV(J)
 20         CONTINUE
 30      CONTINUE
 40   CONTINUE



      DO 45 J=1,3
         CENTROID(J)=CENTROID(J)/FLOAT(NUM)
 45   CONTINUE
      DO 60 J=1,3
         DO 50 I=1,3
            MATRIX(I,J)=MATRIX(I,J)/FLOAT(NUM) -
     +       CENTROID(I)*CENTROID(J)
 50      CONTINUE
 60   CONTINUE



      CALL GVSEIG2 (3,MATRIX,ELLVEC,ELLMAT)
      ELLVEC(1)=SQRT(ELLVEC(1))
      ELLVEC(2)=SQRT(ELLVEC(2))
      ELLVEC(3)=SQRT(ELLVEC(3))
      ELLWOK=.TRUE.



      CALL GVSRT0 (ELLHGH,3)
      ELLHGH(1)=ELLVEC(1)*2.236
      CALL GVSMVV (ELLHGH,ELLMAT)
      CALL GVSRT0 (ELLMID,3)
      ELLMID(2)=ELLVEC(2)*2.236
      CALL GVSMVV (ELLMID,ELLMAT)
      CALL GVSRT0 (ELLLOW,3)
      ELLLOW(3)=ELLVEC(3)*2.236
      CALL GVSMVV (ELLLOW,ELLMAT)



  998 CONTINUE


      RETURN
      END
      SUBROUTINE GHS015

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, IDOT
      LOGICAL       GVFFOP







      IF (ELLUNT.LE.0) THEN
         CALL GVSTTE ('?M2814')
         GOTO 998
      ELSE IF (.NOT.GVFFOP(ELLUNT)) THEN
         CALL GVSTTE ('?M2815')
         GOTO 998
      END IF
      IF (.NOT.ELLWOK) GOTO 998



      DO 10 IDOT=1,WIFPAR(68)
         CV(1)=XUACC(IDOT)*ELLVEC(1)*2.236
         CV(2)=YUACC(IDOT)*ELLVEC(2)*2.236
         CV(3)=ZUACC(IDOT)*ELLVEC(3)*2.236
         CALL GVSMVV (CV,ELLMAT)
         CALL GRTDOT (CV(1)+ELLCEN(1),CV(2)+ELLCEN(2),CV(3)+
     +    ELLCEN(3),WIFPAR(295),IERR)
   10 CONTINUE



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS016

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      REAL          GVFLNV







      CALL GVSWM4 (ELLMAT,ELLVEC)
      CALL GVSTTR3 ('?M4516',ELLHGH(1),ELLHGH(2),ELLHGH(3))
      CALL GVSTTR3 ('?M4517',ELLMID(1),ELLMID(2),ELLMID(3))
      CALL GVSTTR3 ('?M4518',ELLLOW(1),ELLLOW(2),ELLLOW(3))
      CALL GVSTTR3 ('?M4519',GVFLNV(ELLHGH),GVFLNV(ELLMID),
     + GVFLNV(ELLLOW))
      CALL GVSTTR3 ('?M4520',GVFLNV(ELLHGH)/GVFLNV(ELLMID),
     + GVFLNV(ELLMID)/GVFLNV(ELLLOW),GVFLNV(ELLHGH)/GVFLNV(ELLLOW))





      RETURN
      END   
      SUBROUTINE GHS017

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR







      CALL GRTLIN (ELLCEN(1)-ELLHGH(1),ELLCEN(2)-ELLHGH(2),
     + ELLCEN(3)-ELLHGH(3),ELLCEN(1)+ELLHGH(1),ELLCEN(2)+ELLHGH(2),
     + ELLCEN(3)+ELLHGH(3),320,IERR)
      CALL GRTLIN (ELLCEN(1)-ELLMID(1),ELLCEN(2)-ELLMID(2),
     + ELLCEN(3)-ELLMID(3),ELLCEN(1)+ELLMID(1),ELLCEN(2)+ELLMID(2),
     + ELLCEN(3)+ELLMID(3),320,IERR)
      CALL GRTLIN (ELLCEN(1)-ELLLOW(1),ELLCEN(2)-ELLLOW(2),
     + ELLCEN(3)-ELLLOW(3),ELLCEN(1)+ELLLOW(1),ELLCEN(2)+ELLLOW(2),
     + ELLCEN(3)+ELLLOW(3),320,IERR)





      RETURN
      END   
      SUBROUTINE GHS018 (ILOW,IHGH,IERR)

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       NUM, I, ILOW, IHGH, IERR
      REAL          X, Y, Z, UX, UY, UZ, UX2, UY2, UZ2, UXY, UXZ, UYZ,
     +              FACTOR
      LOGICAL       GVFFOP







      IERR=1
      NUM=IHGH-ILOW+1
      IF (ELLUNT.LE.0) THEN
         CALL GVSTTE ('?M2814')
         GOTO 998
      ELSE IF (.NOT.GVFFOP(ELLUNT)) THEN
         CALL GVSTTE ('?M2815')
         GOTO 998
      END IF      
      IF (NUM.LT.4) THEN
         CALL GVSTTE ('?M2816')
         GOTO 998
      END IF   



      IERR=0
      FACTOR=1.0/FLOAT(NUM)
      UX=0.0
      UX2=0.0
      UY=0.0
      UY2=0.0
      UZ=0.0
      UZ2=0.0
      UXY=0.0
      UXZ=0.0
      UYZ=0.0






      DO 10 I=ILOW,IHGH
         READ (ELLUNT,REC=I,ERR=998) X,Y,Z
         IF (ILOW.LT.110) PRINT*,I,X,Y,Z
         UX=UX+FACTOR*X
         UX2=UX2+FACTOR*(X**2)
         UY=UY+FACTOR*Y
         UY2=UY2+FACTOR*(Y**2)
         UZ=UZ+FACTOR*Z
         UZ2=UZ2+FACTOR*(Z**2)
         UXY=UXY+FACTOR*X*Y
         UXZ=UXZ+FACTOR*X*Z
         UYZ=UYZ+FACTOR*Y*Z
 10   CONTINUE
      IF (ILOW.LT.110) PRINT*,UX,UY,UZ,UX2,UY2,UZ2,UXY,UXZ,UYZ
      ELLUMX(1,1)=UX2-UX**2
      ELLUMX(1,2)=UXY-UX*UY
      ELLUMX(1,3)=UXZ-UX*UZ
      ELLUMX(2,1)=ELLUMX(1,2)
      ELLUMX(2,2)=UY2-UY**2
      ELLUMX(2,3)=UYZ-UY*UZ
      ELLUMX(3,1)=ELLUMX(1,3)
      ELLUMX(3,2)=ELLUMX(2,3)
      ELLUMX(3,3)=UY2-UY**2



  998 CONTINUE


      RETURN
      END
      SUBROUTINE GHS019 (ILOW,IHGH,ICOL,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       NUM, I, ILOW, IHGH, ICOL, IERR
      REAL          X, Y, Z
      LOGICAL       GVFFOP







      IERR=1
      NUM=IHGH-ILOW+1
      IF (ELLUNT.LE.0) THEN
         CALL GVSTTE ('?M2814')
         GOTO 998
      ELSE IF (.NOT.GVFFOP(ELLUNT)) THEN
         CALL GVSTTE ('?M2815')
         GOTO 998
      END IF      
      IF (NUM.LT.4) THEN
         CALL GVSTTE ('?M2816')
         GOTO 998
      END IF   



      IERR=0






      DO 10 I=ILOW,IHGH
         READ (ELLUNT,REC=I,ERR=998) X,Y,Z
         CALL GRTCRS (X,Y,Z,0.1,ICOL,IERR)
 10   CONTINUE



  998 CONTINUE


      RETURN
      END
      SUBROUTINE GHS021 (ILOW,IHGH,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       ILOW, IHGH, IREC, IERR
      REAL          ZERO







      IF (STAUNT.NE.0) THEN
         CALL GVSCLF (STAUNT)
         CALL GVSDEL ('VALUES.STA')
      END IF
      CALL GVSROF (STAUNT,IERR)
      IF (STAUNT.LE.0.OR.IERR.NE.0) GOTO 999



      IERR=0
      STACNT=0
      ZERO=0.0



      CALL GVSODF (STAUNT,.FALSE.,'VALUES.STA','UNKNOWN',1,' ',IERR)
      IF (IERR.NE.0) GOTO 999



      IF (ILOW.GE.1.AND.IHGH.GE.ILOW) THEN
         DO 10 IREC=ILOW,IHGH
            WRITE (STAUNT,REC=IREC,ERR=999) ZERO
 10      CONTINUE
      END IF
      GOTO 998



 999  CONTINUE
      IERR=1
      CALL GVSEIW ('GHS021')



 998  CONTINUE


      RETURN
      END   
      SUBROUTINE GHS022 (IREC,VALUE,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, IREC
      REAL          VALUE
      LOGICAL       GVFFOP







      IF (STAUNT.LE.0) THEN
         CALL GVSTTE ('?M2814A')
         IERR=1
         GOTO 999
      ELSE IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      END IF



      IERR=0



      IF (IREC.EQ.0) THEN
         STACNT=STACNT+1
      ELSE
         STACNT=IREC
      END IF



      WRITE (STAUNT,REC=STACNT,ERR=999) VALUE
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIW ('GHS022')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS023 (ILOWIN,IHGHIN,AVE,SDEV,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       ILOW, IHGH, ILOWIN, IHGHIN, IERR
      REAL          AVE, ADEV, SDEV, SKEW, CURT
      LOGICAL       GVFFOP







      IERR=0
      IF (ILOWIN.EQ.0.AND.IHGHIN.EQ.0) THEN
         ILOW=1
         IHGH=STACNT
      ELSE
         ILOW=ILOWIN
         IHGH=IHGHIN
      END IF



      IF (ILOW.EQ.0.AND.IHGH.EQ.0.AND.STAUNT.LE.0) THEN
         CALL GVSTTE ('?M2814A')
         IERR=1
         GOTO 998
      ELSE IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      ELSE IF (IHGH-ILOW.LT.3.OR.ILOW.LE.0) THEN
         CALL GVSTTE ('?M2824A')
         IERR=1
         GOTO 998
      END IF    



      CALL GHS025 (STAUNT,ILOW,IHGH,AVE,ADEV,SDEV,SKEW,CURT)
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIW ('GHS023')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS023A (ILOWIN,IHGHIN,AVE,SDEV,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       ILOW, IHGH, ILOWIN, IHGHIN, IERR
      REAL          AVE, ADEV, SDEV, SKEW, CURT
      LOGICAL       GVFFOP







      IERR=0
      IF (ILOWIN.EQ.0.AND.IHGHIN.EQ.0) THEN
         ILOW=1
         IHGH=STACNT
      ELSE
         ILOW=ILOWIN
         IHGH=IHGHIN
      END IF



      IF (ILOW.EQ.0.AND.IHGH.EQ.0.AND.STAUNT.LE.0) THEN
         CALL GVSTTE ('?M2814A')
         IERR=1
         GOTO 998
      ELSE IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      ELSE IF (IHGH-ILOW.LT.3.OR.ILOW.LE.0) THEN
         CALL GVSTTE ('?M2824A')
         IERR=1
         GOTO 998
      END IF    



      CALL GHS025A (STAUNT,ILOW,IHGH,AVE,ADEV,SDEV,SKEW,CURT)
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIW ('GHS023A')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS024 (IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR
      LOGICAL       GVFIBN, GVFFOP







      IF (STAUNT.EQ.0) GOTO 998
      IF (.NOT.GVFIBN(STAUNT,1,250)) THEN
         CALL GVSTTB ('?M3137')
         IERR=1
         GOTO 998
      END IF
      IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTB ('?M3138')
         IERR=1
         GOTO 998
      END IF



      IERR=0
      STACNT=0



      CALL GVSCLF (STAUNT)



      STAUNT=0



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS025 (IUNIT,ILOW,IHGH,AVE,ADEV,SDEV,SKEW,CURT)
























      IMPLICIT      NONE
      INTEGER       N, J, IUNIT, ILOW, IHGH
      REAL          S, P, AVE, ADEV, SDEV, VAR, VALUE, CURT, SKEW







      S=0.0
      N=IHGH-ILOW+1
      DO 10 J=ILOW,IHGH
         READ (IUNIT,REC=J,ERR=999) VALUE
         S=S+VALUE
   10 CONTINUE
      AVE=S/N



      ADEV=0.0
      VAR =0.0
      SKEW=0.0
      CURT=0.0
      DO 20 J=ILOW,IHGH
         READ (IUNIT,REC=J,ERR=999) VALUE
         S=VALUE-AVE
         ADEV=ADEV+ABS(S)
         P=S*S
         VAR=VAR+P
         P=P*S
         SKEW=SKEW+P
         P=P*S
         CURT=CURT+P
   20 CONTINUE
      ADEV=ADEV/N
      VAR=VAR/(N-1)
      SDEV=SQRT(VAR)
      IF (ABS(VAR).GT.0.0000001) THEN
         SKEW=SKEW/(N*SDEV**3)
         CURT=CURT/(N*VAR**2)-3.
      ELSE
         SKEW=0.0
         CURT=0.0
      END IF
      GOTO 998



 999  CONTINUE
      CALL GVSEIR ('GHS025')
      CALL GVSKIL



  998 CONTINUE


      RETURN
      END
      SUBROUTINE GHS025A (IUNIT,ILOW,IHGH,AVE,ADEV,SDEV,SKEW,CURT)
























      IMPLICIT      NONE
      INTEGER       N, J, IUNIT, ILOW, IHGH
      REAL          S, P, AVE, ADEV, SDEV, VAR, VALUE, CURT, SKEW







      S=0.0
      N=IHGH-ILOW+1
      DO 10 J=ILOW,IHGH
         READ (IUNIT,REC=J,ERR=999) VALUE
         PRINT*,J,VALUE
         S=S+VALUE
   10 CONTINUE
      AVE=S/N



      ADEV=0.0
      VAR =0.0
      SKEW=0.0
      CURT=0.0
      DO 20 J=ILOW,IHGH
         READ (IUNIT,REC=J,ERR=999) VALUE
         S=VALUE-AVE
         ADEV=ADEV+ABS(S)
         P=S*S
         VAR=VAR+P
         P=P*S
         SKEW=SKEW+P
         P=P*S
         CURT=CURT+P
   20 CONTINUE
      ADEV=ADEV/N
      VAR=VAR/(N-1)
      SDEV=SQRT(VAR)
      IF (ABS(VAR).GT.0.0000001) THEN
         SKEW=SKEW/(N*SDEV**3)
         CURT=CURT/(N*VAR**2)-3.
      ELSE
         SKEW=0.0
         CURT=0.0
      END IF
      CALL GVSTTI ('Number of values ...... :',N)
      CALL GVSTTR ('Average ............... :',AVE)
      CALL GVSTTR ('Standard deviation .... :',SDEV)
      CALL GVSTTR ('Skewness .............. :',SKEW)
      CALL GVSTTR ('Kurtosis .............. :',CURT)
      GOTO 998



 999  CONTINUE
      CALL GVSEIR ('GHS025')
      CALL GVSKIL



  998 CONTINUE


      RETURN
      END
      SUBROUTINE GHS026 (IREC,VALUE,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, IREC
      REAL          VALUE
      LOGICAL       GVFFOP







      IF (STAUNT.LE.0) THEN
         CALL GVSTTE ('?M2814A')
         IERR=1
         GOTO 999
      ELSE IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      END IF
      IF (IREC.LE.0) THEN
         CALL GVSTTB ('?M3249')
         IERR=1
         GOTO 999
      END IF



      IERR=0



      READ (STAUNT,REC=IREC,ERR=999) VALUE
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIR ('GHS026')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS027 (ILOWIN,IHGHIN,IERR)

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, ILOWIN, IHGHIN, ILOW, IHGH, J
      REAL          AVE, ADEV, SDEV, VALUE, FAC, CURT, SKEW







      IERR=0



      IF (ILOWIN.EQ.0.AND.IHGHIN.EQ.0) THEN
         ILOW=1
         IHGH=STACNT
      ELSE
         ILOW=ILOWIN
         IHGH=IHGHIN
      END IF



      CALL GHS025 (STAUNT,ILOW,IHGH,AVE,ADEV,SDEV,SKEW,CURT)



      CALL GHS000
      FAC=FLOAT(WIFPAR(441))
      CALL GHS001 (WIFPAR(440),AVE-FAC*SDEV,AVE+FAC*SDEV,IERR)
      IF (IERR.NE.0) GOTO 999



      DO 10 J=ILOW,IHGH
         READ (STAUNT,REC=J,ERR=999) VALUE
         CALL GHS002 (VALUE)
   10 CONTINUE



      CALL GHS003
      GOTO 998



  999 CONTINUE
      CALL GVSEIW ('GHS027')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS028 (TEXT,ILOWIN,IHGHIN,IERR)

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, ILOWIN, IHGHIN, ILOW, IHGH, J
      REAL          AVE, ADEV, SDEV, VALUE, FAC, CURT, SKEW
      CHARACTER*(*) TEXT







      IERR=0
      CALL GVSBOX (TEXT)



      IF (ILOWIN.EQ.0.AND.IHGHIN.EQ.0) THEN
         ILOW=1
         IHGH=STACNT
      ELSE
         ILOW=ILOWIN
         IHGH=IHGHIN
      END IF



      CALL GHS025 (STAUNT,ILOW,IHGH,AVE,ADEV,SDEV,SKEW,CURT)
      CALL GVSTTI ('Number of taus ....... :',IHGH-ILOW+1) 
      CALL GVSPRS (AVE,ADEV,SDEV,SKEW,CURT)



      CALL GHS000
      FAC=FLOAT(WIFPAR(441))
      CALL GHS001 (WIFPAR(440),AVE-FAC*SDEV,AVE+FAC*SDEV,IERR)
      IF (IERR.NE.0) GOTO 999



      DO 10 J=ILOW,IHGH
         READ (STAUNT,REC=J,ERR=999) VALUE
         CALL GHS002 (VALUE)
   10 CONTINUE



      CALL GHS003
      GOTO 998



  999 CONTINUE
      CALL GVSEIW ('GHS028')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS028X (ILOWIN,IHGHIN,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, ILOWIN, IHGHIN, ILOW, IHGH, J, NUM, I1, I2
      REAL          PCTL(5), LOW, VL, HGH, FRACT







      IERR=0
      NUM=0
      PCTL(1)=0.05
      PCTL(2)=0.5
      PCTL(3)=2.5
      PCTL(4)=17.0



      IF (ILOWIN.EQ.0.AND.IHGHIN.EQ.0) THEN
         ILOW=1
         IHGH=STACNT
      ELSE
         ILOW=ILOWIN
         IHGH=IHGHIN
      END IF



      DO 10 J=ILOW,IHGH
         NUM=NUM+1
         READ (STAUNT,REC=J,ERR=999) GHSROW(NUM)
   10 CONTINUE



      CALL GVSRT1 (GHSROW,NUM)



      DO 20 J=1,4
         VL=PCTL(J)*FLOAT(NUM)/100.0
         IF (VL.LT.5.0) THEN
            GOTO 20
         END IF
         I1=INT(VL)
         I2=I1+1
         FRACT=PCTL(J)-FLOAT(INT(PCTL(J)))
         LOW=FRACT*GHSROW(I2)+(1.0-FRACT)*GHSROW(I2)
         I1=NUM-I1+1
         I2=I1-1
         HGH=FRACT*GHSROW(I2)+(1.0-FRACT)*GHSROW(I2)
         CALL GVSTTR3 ('?M4521',PCTL(J),LOW,HGH)
 20   CONTINUE
      GOTO 998



  999 CONTINUE
      CALL GVSEIW ('GHS028')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS029 (IREC,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, IREC
      LOGICAL       GVFFOP







      IF (STAUNT.LE.0) THEN
         CALL GVSTTE ('?M2814A')
         IERR=1
         GOTO 999
      ELSE IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      END IF



      IERR=0



      IREC=STACNT
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIW ('GHS029')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS030 (NUM,XVAL,YVAL,A,B,Q)

















      IMPLICIT      NONE
      INTEGER       NUM, I
      REAL          XVAL(NUM), YVAL(NUM), A, B, Q, ANUM, SX, SY, SXX, 
     +              SXY







      IF (NUM.LE.1) THEN
         A=0.0
         B=0.0
         Q=0.0
         GOTO 998
      END IF



      ANUM=FLOAT(NUM)
      SX=0.0
      SY=0.0
      SXX=0.0
      SXY=0.0
      Q=0.0
      DO 10 I=1,NUM
         SX=SX+XVAL(I)
         SY=SY+YVAL(I)
         SXY=SXY+XVAL(I)*YVAL(I)
         SXX=SXX+XVAL(I)*XVAL(I)
 10   CONTINUE



      B=(ANUM*SXY-SX*SY)/(ANUM*SXX-SX*SX)
      A=(1/ANUM)*SY-(1/ANUM)*B*SX



      DO 20 I=1,NUM
         Q=Q+(YVAL(I)-(A+B*XVAL(I)))**2
 20   CONTINUE
      Q=Q/ANUM



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS031 (IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR







      IF (STAUNT.NE.0) CALL GVSCLF (STAUNT)



      CALL GVSROF (STAUNT,IERR)
      IF (STAUNT.LE.0.OR.IERR.NE.0) GOTO 999



      IERR=0
      STACNT=0
      CALL GVSIT0 (POLPNT,MAXPOL)



      CALL GVSODF (STAUNT,.FALSE.,'POLSTS.STA','UNKNOWN',1,' ',IERR)
      IF (IERR.NE.0) GOTO 999
      GOTO 998



 999  CONTINUE
      IERR=1
      CALL GVSEIW ('GHS031')



 998  CONTINUE


      RETURN
      END   
      SUBROUTINE GHS032 (PREC,VALUE,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, PREC, LOCPNT
      REAL          VALUE
      LOGICAL       GVFFOP, GVFIBN







      IF (STAUNT.LE.0) THEN
         CALL GVSTTE ('?M2814A')
         IERR=1
         GOTO 999
      ELSE IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      END IF
      IF (.NOT.GVFIBN(PREC,1,MAXPOL)) THEN
         IERR=1
         CALL GVSTTI ('BUG. PREC OOR in GHS032:',PREC)
         CALL GVSKIL
         GOTO 998
      END IF



      IERR=0



      POLPNT(PREC)=POLPNT(PREC)+1
      LOCPNT=20000*(PREC-1)+POLPNT(PREC)



      WRITE (STAUNT,REC=LOCPNT,ERR=999) VALUE
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIW ('GHS032')
      CALL GVSKIL



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS033 (PREC,AVE,SDEV,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       ILOW, IHGH, PREC, IERR
      REAL          AVE, ADEV, SDEV, CURT, SKEW
      LOGICAL       GVFFOP, GVFIBN







      IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      END IF
      IF (.NOT.GVFIBN(PREC,1,MAXPOL)) THEN
         CALL GVSTTE ('PREC OOR in GHS033')
         IERR=1
         GOTO 998
      END IF
      IF (POLPNT(PREC).LE.0) THEN
         CALL GVSTTI ('No values observed for parameter:',PREC)
         IERR=0
         GOTO 998
      END IF



      IERR=0
      ILOW=20000*(PREC-1)+1
      IHGH=20000*(PREC-1)+POLPNT(PREC)



      CALL GHS025 (STAUNT,ILOW,IHGH,AVE,ADEV,SDEV,SKEW,CURT)
      CALL GHS027 (ILOW,IHGH,IERR)
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIW ('GHS033')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS034 (IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR
      LOGICAL       GVFIBN, GVFFOP







      IF (.NOT.GVFIBN(STAUNT,1,250)) THEN
         CALL GVSTTB ('?M3137')
         IERR=1
         GOTO 998
      END IF
      IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTB ('?M3138')
         IERR=1
         GOTO 998
      END IF



      IERR=0
      STACNT=0



      CALL GVSCLF (STAUNT)



      STAUNT=0



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS035 (PREC,PVAL,VALUE,IERR)

















      IMPLICIT      NONE
      INCLUDE       'HISTOG.INC'
      INCLUDE       'ESPACE.INC'
      INTEGER       IERR, PREC, LOCPNT, PVAL
      REAL          VALUE
      LOGICAL       GVFFOP, GVFIBN







      IF (STAUNT.LE.0) THEN
         CALL GVSTTE ('?M2814A')
         IERR=1
         GOTO 999
      ELSE IF (.NOT.GVFFOP(STAUNT)) THEN
         CALL GVSTTE ('?M2815A')
         IERR=1
         GOTO 999
      END IF
      IF (.NOT.GVFIBN(PREC,1,MAXPOL)) THEN
         IERR=1
         CALL GVSTTE ('PREC OOR in GHS035')
         GOTO 998
      END IF



      IERR=0



      LOCPNT=20000*(PREC-1)+PVAL



      READ (STAUNT,REC=LOCPNT,ERR=999) VALUE
      GOTO 998



  999 CONTINUE
      IERR=1
      CALL GVSEIW ('GHS035')



  998 CONTINUE


      RETURN
      END   
      SUBROUTINE GHS100

















      IMPLICIT      NONE
      INCLUDE       'BIGINC.INC'
      INTEGER       I, J, IERR, GVFIAN, IT, I1, I2, I3
      REAL          GVFRAN, ROW(1000), AVER, ADEV, SDEV, VAR, SKEW, T,
     +              CURT, NSKEW, NCURT, ADDER, A1, A2, A3







      CALL GHS021 (0,0,IERR)



      DO 20 I=1,1000
         ROW(I)=100.0
         DO 10 J=1,1000
            ROW(I)=ROW(I)+GVFRAN(-1.0,1.0)
 10      CONTINUE
         CALL GHS022 (I,ROW(I),IERR)
 20   CONTINUE
      CALL GHS023 (0,0,AVER,SDEV,IERR)
      CALL GVSTTR2 ('Omega aver/sdev',AVER,SDEV)
      CALL GHS024 (IERR)
      PRINT*,'Initial distribution'
      CALL GVSRAV (ROW,1000,AVER,ADEV,SDEV,VAR,SKEW,CURT)
      CALL GVSPRS (AVER,ADEV,SDEV,SKEW,CURT)



      DO 28 IT=20,10,-1
         T=FLOAT(IT)/10.0
         PRINT*,'Treshold:',T
         DO 25 J=1,10000*(20-IT)
            I=GVFIAN(1,1000)
            ADDER=GVFRAN(-10.0,10.0)
 26         CONTINUE
            ROW(I)=ROW(I)+ADDER
            CALL GVSRAV (ROW,1000,AVER,ADEV,SDEV,VAR,NSKEW,NCURT)
            IF (ABS(NSKEW).GT.ABS(SKEW).OR.ABS(NCURT).GT.
     +          T*ABS(CURT)) THEN
               ROW(I)=ROW(I)-ADDER
               GOTO 25
            END IF
            SKEW=NSKEW
            CURT=NCURT
            PRINT*,'New:',SKEW,CURT
            GOTO 26
 25      CONTINUE
 28   CONTINUE
      DO 29 J=1,1000000
         IF (MOD(J,100000).EQ.0) PRINT*,'T=0 loop:',J/100000
         I1=GVFIAN(1,1000)
         A1=GVFRAN(-10.0,10.0)
         I2=GVFIAN(1,1000)
         A2=GVFRAN(-10.0,10.0)
         I3=GVFIAN(1,1000)
         A3=GVFRAN(-10.0,10.0)
 27      CONTINUE
         ROW(I1)=ROW(I1)+A1
         ROW(I2)=ROW(I2)+A2
         ROW(I3)=ROW(I3)+A3
         CALL GVSRAV (ROW,1000,AVER,ADEV,SDEV,VAR,NSKEW,NCURT)
         IF (ABS(NSKEW).GT.ABS(SKEW).OR.ABS(NCURT).GT.ABS(CURT)) THEN
            ROW(I1)=ROW(I1)-A1
            ROW(I2)=ROW(I2)-A2
            ROW(I3)=ROW(I3)-A3
            GOTO 29
         END IF
         SKEW=NSKEW
         CURT=NCURT
         PRINT*,'New:',SKEW,CURT
         GOTO 27
 29   CONTINUE
      PRINT*,'Optimized distribution'
      CALL GVSRAV (ROW,1000,AVER,ADEV,SDEV,VAR,SKEW,CURT)
      CALL GVSPRS (AVER,ADEV,SDEV,SKEW,CURT)



      DO 30 I=1,1000
         ROW(I)=(ROW(I)-100.0)/SDEV
 30   CONTINUE
      PRINT*,'Z-score distribution'
      CALL GVSRAV (ROW,1000,AVER,ADEV,SDEV,VAR,SKEW,CURT)
      CALL GVSPRS (AVER,ADEV,SDEV,SKEW,CURT)










      RETURN
      END   
