!-----Version: 11.02.2015
!               ************
!               * hprogs.f *
!               ************
!     Subroutines with (almost) no COMMON-Blocks
!
!     Any suggestions, complaints or comments are greatly appreciated
!     by the author and should be sent to:
!
!          Christian de Capitani
!          Mineralogisch-Petrographisches Institut
!          Universitaet Basel
!          Bernoullistrasse 30
!          CH-4056 BASEL
!
!
      SUBROUTINE FIBLA(CH,II)
      IMPLICIT NONE
      CHARACTER*(*) CH
      INTEGER*4 II,I,LAE
      LAE=LEN(CH)
      DO 501,I=1,LAE
  501 IF (CH(I:I).NE.' ') GOTO 1
    1 II=I
      IF (II.EQ.LAE+1) II=0
      RETURN
      END
!-----
!******************************
      SUBROUTINE LABLA(CH,II)
      IMPLICIT NONE
      CHARACTER*(*) CH
      INTEGER*4 II,I,LAE
      LAE=LEN(CH)
      DO 501,I=LAE,1,-1
  501 IF (CH(I:I).NE.' ') GOTO 1
    1 II=I
      RETURN
      END
!-----
!******************************
      SUBROUTINE PUST(I001,CH)
      IMPLICIT NONE
      CHARACTER*(*) CH
      INTEGER*4 I001,II
      CALL LABLA(CH,II)
      IF (II.EQ.0) II=1
      WRITE (UNIT=I001,FMT='(A)') CH(1:II)
      RETURN
      END
!-----
!******************************
      SUBROUTINE PUSTCOL(I001,CH,COL1,COL2)
      IMPLICIT NONE
      CHARACTER*(*) CH
      CHARACTER*16 FORMA
      INTEGER*4 I001,II,COL1,COL2,LAE,IA,IE,IL,I
      LAE=COL2-COL1+1
      IF (COL1.EQ.1) THEN
      WRITE (UNIT=FORMA,FMT='(''(A)'')')
      ELSE
      WRITE (UNIT=FORMA,FMT='(''('',I3,''X,A)'')') COL1-1
      END IF
      CALL FIBLA(FORMA,IA)
      CALL LABLA(FORMA,IE)
      CALL LABLA(CH,IL)
!      IF (IL.EQ.0) IL=1
      IL=IL+1
      DO I=1,IL,LAE
       II=MIN(I+LAE-1,IL)
       WRITE (UNIT=I001,FMT=FORMA(IA:IE)) CH(I:II)
      END DO
      RETURN
      END
!-----
!******************************
      SUBROUTINE GELI(CH,FF)
      IMPLICIT NONE
      include 'files.cmn'
      CHARACTER*(*) CH
      CHARACTER*250 CH001
      CHARACTER*50 CH002
      CHARACTER*16 CH016
      REAL*8 FF,F1,F2
      INTEGER*4 I001,I002,I,II
      CALL FIBLA(CH,I001)
      IF (I001.EQ.0) THEN
      FF=0.0D0
      RETURN
      END IF
      CH001=CH(I001:)
      I001=INDEX(CH001,' ')
      CH002=CH001(1:I001)
      I002=INDEX(CH002,'/')
      IF (I002.EQ.0) THEN
      CH016=CH001(1:I001-1)
      READ (UNIT=CH016,FMT='(BN,D16.0)',ERR=999) FF
      ELSE
      CH016=CH002(1:I002-1)
      READ (UNIT=CH016,FMT='(BN,D16.0)',ERR=999) F1
      CH016=CH002(I002+1:I001-1)
      READ (UNIT=CH016,FMT='(BN,D16.0)',ERR=999) F2
      FF=F1/F2
      END IF
      CH=CH001(I001:)
      RETURN
  999 CALL SHOUTF
      WRITE (UNIT=6,FMT=302)
      WRITE (UNIT=out,FMT=302)
  302 FORMAT (//' Troubles with format-free reading')
      CALL LABLA(CH001,II)
      WRITE (UNIT=6,FMT=303) (CH001(I:I),I=1,II)
      WRITE (UNIT=out,FMT=303) (CH001(I:I),I=1,II)
  303 FORMAT (/' Remaining record: ',250A1)
      WRITE (UNIT=6,FMT=304) CH016
      WRITE (UNIT=out,FMT=304) CH016
  304 FORMAT (' The following string cannot be converted', &
      ' to a real number: ',A16/ &
      ' PRTCOD = -2 may be useful to trace error')
      STOP
      END
!-----
!******************************
      SUBROUTINE TAXI(REC,CHST)
      IMPLICIT NONE
      CHARACTER*(*) REC
      CHARACTER*250 CH001
      CHARACTER*(*) CHST
      INTEGER*4 I1
      CALL FIBLA(REC,I1)
      IF (I1.EQ.0) THEN
      CHST=' '
      RETURN
      END IF
      CH001=REC(I1:)
      I1=INDEX(CH001,'  ')
      CHST=CH001(1:I1-1)
      REC=CH001(I1:)
      RETURN
      END
!-----
!******************************
      SUBROUTINE TAXI1(REC,CHST)
      IMPLICIT NONE
      CHARACTER*(*) REC
      CHARACTER*250 CH001
      CHARACTER*(*) CHST
      INTEGER*4 I1
      CALL FIBLA(REC,I1)
      IF (I1.EQ.0) THEN
      CHST=' '
      RETURN
      END IF
      CH001=REC(I1:)
      I1=INDEX(CH001,' ')
      CHST=CH001(1:I1-1)
      REC=CH001(I1:)
      RETURN
      END
!-----
!******************************
      SUBROUTINE MAKEZAHL(XX,IST,CHXX,IX)
      IMPLICIT NONE
      CHARACTER*80 CHXE,CHXF
      CHARACTER*(*) CHXX
      CHARACTER*25 FORME,FORMF
      REAL*8 XX,FL1
      INTEGER*4 L,I,I1,I2,IST,IFF,IEE,IX
!-----
      IF (XX.GT.0.0D0) FL1=DLOG10(XX)
      IF (XX.LT.0.0D0) FL1=DLOG10(-XX)
      IF (FL1.GT.0.0D0) THEN
        L=IDINT(FL1+1)
      ELSE
        L=IDINT(FL1-1)
      END IF
      WRITE (UNIT=FORME,FMT=3000) IST+6,IST-1
 3000 FORMAT ('(1PE',I2,'.',I3,')')
      CALL COLLAPS(FORME,I)
      WRITE (UNIT=CHXE,FMT=FORME(1:I)) XX
      CALL COLLAPS(CHXE,IEE)
!
      IF (L.GT.0) I1=IST-L
      IF (L.LT.0) I1=IST-1-L
      IF (I1.LE.0) I1=0
      WRITE (UNIT=FORMF,FMT=3005) I1
 3005 FORMAT ('(1F25.',I3,')')
      CALL COLLAPS(FORMF,I)
      WRITE (UNIT=CHXF,FMT=FORMF(1:I)) XX
      CALL COLLAPS(CHXF,I1)
      I2=I1
      DO I=I1,1,-1
        IF (CHXF(I:I).NE.'0') THEN
         I2=I
         GOTO 10
        END IF
      END DO
   10 CONTINUE
      CHXF(I2+1:)=' '
      CALL LABLA(CHXF,IFF)
      IF (CHXF(IFF:IFF).EQ.'.') THEN
        CHXF(IFF:IFF)=' '
        IFF=IFF-1
      END IF
! return shorter
      IF (IFF.GT.IEE) THEN
        CHXX=CHXE
        IX=IEE
      ELSE
        CHXX=CHXF
        IX=IFF
      END IF

!=====
      RETURN
      END
!-----
!******************************
      SUBROUTINE NUMTEX(X,B,NT)
      IMPLICIT NONE
      CHARACTER*40 A,B
      INTEGER*4 NT,I,I1,I2
      REAL*8 X
!-----
      A=' '
      WRITE (UNIT=A,FMT='(F22.10)') X
      CALL FIBLA(A,I1)
      I2=40
      DO I=40,1,-1
       IF (A(I:I).EQ.'0'.OR.A(I:I).EQ.' ') THEN
       I2=I2-1
       ELSE
       GOTO 1
       END IF
      END DO
    1 CONTINUE
      IF (A(I:I).EQ.'.') I2=I2-1
      NT=I2-I1+1
      B=A(I1:I2)
!-----
      RETURN
      END
!-----
!******************************
      SUBROUTINE CHEMIE(COMAY,NC,OXYDE,OXANZ,FORMUL,CHE)
      IMPLICIT NONE
      include 'files.cmn'
      INTEGER*4 I,I1,I2,I3,NC,COMAY,II,MACHO
      CHARACTER*(*) FORMUL
      CHARACTER*500 CH170
      CHARACTER*10 ELE,OXYDE(COMAY)
      REAL*8 CHE(COMAY),OXANZ(COMAY),FF
!-----
      MACHO=0
      DO 501,I=1,COMAY
  501 CHE(I)=0.0D0
      CALL FIBLA(FORMUL,I1)
 1001 IF (I1.EQ.0) GOTO 2
      I2=INDEX(FORMUL,'(')
      I3=INDEX(FORMUL,')')
      IF (I2.LE.I1) I2=I1+1
      IF (I3.LE.I2+1) I3=I2+2
      ELE=FORMUL(I1:I2-1)
      DO 502,I=1,NC
  502 IF (ELE.EQ.OXYDE(I)) GOTO 1
    1 IF (I.EQ.NC+1) THEN
      CALL SHOUTF
      CALL LABLA(FORMUL,II)
      WRITE (UNIT=6,FMT=302) (FORMUL(I:I),I=1,II)
      WRITE (UNIT=out,FMT=302) (FORMUL(I:I),I=1,II)
!  100 FORMAT (//' Troubles with formula: ',250A1)
      WRITE (UNIT=6,FMT=102) ELE
      WRITE (UNIT=out,FMT=102) ELE
  102 FORMAT (/1X,A10,': is not a known component')
      STOP
      END IF
      CH170=FORMUL(I2+1:I3-1)
!-----
      IF (ELE.EQ.'O'.AND.CH170.EQ.'?') THEN
      MACHO=I
      ELSE
!     READ (UNIT=CH170,FMT='(BN,D16.0)',ERR=999) FF
      CALL GELI(CH170,FF)
      CHE(I)=CHE(I)+FF
      END IF
!-----
      CH170=FORMUL
      FORMUL=CH170(I3+1:)
      CALL FIBLA(FORMUL,I1)
      GOTO 1001
    2 IF (MACHO.GT.0) THEN
      DO 600,I=1,NC
      CHE(MACHO)=CHE(MACHO)+OXANZ(I)*CHE(I)
  600 CONTINUE
      END IF
      RETURN
!=====
      CALL SHOUTF
      CALL LABLA(FORMUL,II)
      WRITE (UNIT=6,FMT=302) (FORMUL(I:I),I=1,II)
      WRITE (UNIT=out,FMT=302) (FORMUL(I:I),I=1,II)
  302 FORMAT (//' Troubles with formula: ',250A1)
      CALL LABLA(CH170,II)
      WRITE (UNIT=6,FMT=304) (CH170(I:I),I=1,II)
      WRITE (UNIT=out,FMT=304) (CH170(I:I),I=1,II)
  304 FORMAT (' The following string cannot be converted', &
      ' to a real number: ',250A1)
      WRITE (UNIT=6,FMT=306)
      WRITE (UNIT=out,FMT=306)
  306 FORMAT (' PRTCOD = -2 may be useful to trace error')
      STOP
      END
!-----
!********************************
      SUBROUTINE TRENNE(IMAX)
      include 'files.cmn'
      INTEGER*4 I,IMAX
      CHARACTER*1 CH1
      CH1='-'
      WRITE (UNIT=6,FMT='(/132A1)') (CH1,I=1,IMAX)
      WRITE (UNIT=out,FMT='(/132A1)') (CH1,I=1,IMAX)
      RETURN
      END
!-----
!******************************
      SUBROUTINE SHOUTI
      IMPLICIT NONE
      WRITE (UNIT=6,FMT=1000)
 1000 FORMAT (// &
      '    #    #    #  #####   #    #   #####'/ &
      '    #    ##   #  #    #  #    #     #'/ &
      '    #    # #  #  #    #  #    #     #'/ &
      '    #    #  # #  #####   #    #     #'/ &
      '    #    #   ##  #       #    #     #'/ &
      '    #    #    #  #        ####      #'// &
      ' ######  #####   #####    ####   #####'/ &
      ' #       #    #  #    #  #    #  #    #'/ &
      ' #####   #    #  #    #  #    #  #    #'/ &
      ' #       #####   #####   #    #  #####'/ &
      ' #       #   #   #   #   #    #  #   #'/ &
      ' ######  #    #  #    #   ####   #    #')
      RETURN
      END
!-----
!******************************
      SUBROUTINE SHOUTW
      IMPLICIT NONE
      WRITE (UNIT=6,FMT=1000)
 1000 FORMAT (// &
      ' #    #    ##    #####   #    #     #    #    #   ####'/ &
      ' #    #   #  #   #    #  ##   #     #    ##   #  #    #'/ &
      ' #    #  #    #  #    #  # #  #     #    # #  #  #'/ &
      ' # ## #  ######  #####   #  # #     #    #  # #  #  ###'/ &
      ' ##  ##  #    #  #   #   #   ##     #    #   ##  #    #'/ &
      ' #    #  #    #  #    #  #    #     #    #    #   ####')
      RETURN
      END
!-----
!******************************
      SUBROUTINE SHOUTF
      IMPLICIT NONE
      WRITE (UNIT=6,FMT=1000)
 1000 FORMAT (// &
      ' ######    ##     #####    ##    #'/ &
      ' #        #  #      #     #  #   #'/ &
      ' #####   #    #     #    #    #  #'/ &
      ' #       ######     #    ######  #'/ &
      ' #       #    #     #    #    #  #'/ &
      ' #       #    #     #    #    #  ######'// &
      ' ######  #####   #####    ####   #####'/ &
      ' #       #    #  #    #  #    #  #    #'/ &
      ' #####   #    #  #    #  #    #  #    #'/ &
      ' #       #####   #####   #    #  #####'/ &
      ' #       #   #   #   #   #    #  #   #'/ &
      ' ######  #    #  #    #   ####   #    #')
      RETURN
      END
!-----
!******************************
      SUBROUTINE SHOUTD
      IMPLICIT NONE
      WRITE (UNIT=6,FMT=1000)
 1000 FORMAT (// &
      ' #####     ##     #####    ##    #####     ##     #### ', &
      '  ######'/ &
      ' #    #   #  #      #     #  #   #    #   #  #   #     ', &
      '  #'/ &
      ' #    #  #    #     #    #    #  #####   #    #   #### ', &
      '  #####'/ &
      ' #    #  ######     #    ######  #    #  ######       #', &
      '  #'/ &
      ' #    #  #    #     #    #    #  #    #  #    #  #    #', &
      '  #'/ &
      ' #####   #    #     #    #    #  #####   #    #   #### ', &
      '  ######'// &
      ' ######  #####   #####    ####   #####'/ &
      ' #       #    #  #    #  #    #  #    #'/ &
      ' #####   #    #  #    #  #    #  #    #'/ &
      ' #       #####   #####   #    #  #####'/ &
      ' #       #   #   #   #   #    #  #   #'/ &
      ' ######  #    #  #    #   ####   #    #')
      RETURN
      END
!-----
!******************************
      SUBROUTINE LOWUP(REC)
      IMPLICIT NONE
! ----
      CHARACTER*(*) REC
      CHARACTER*250 CH001
      CHARACTER*26 UPPER,LOWER
      INTEGER*4 I1,I2,I,J
      DATA UPPER /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
      DATA LOWER /'abcdefghijklmnopqrstuvwxyz'/
! ----
      CALL LABLA(REC,I1)
      CH001=' '
      I2=1
      DO 500,I=1,I1
      J=INDEX(LOWER,REC(I:I))
      IF (J.EQ.0) THEN
      CH001(I2:I2)=REC(I:I)
      I2=I2+1
      ELSE
      CH001(I2:I2)=UPPER(J:J)
      I2=I2+1
      END IF
  500 CONTINUE
      REC=CH001
      RETURN
      END
!-----
!******************************
      SUBROUTINE COLLAPS(CH,J)
      IMPLICIT NONE
      CHARACTER*(*) CH
      CHARACTER*132 CH1
      INTEGER*4 J,I,LAE
      LAE=LEN(CH)
      CH1=' '
      J=0
      DO 500,I=1,LAE
      IF (CH(I:I).NE.' ') THEN
      J=J+1
      CH1(J:J)=CH(I:I)
      END IF
  500 CONTINUE
      CH=CH1(1:J)
      RETURN
      END
!-----
!******************************
      LOGICAL*4 FUNCTION VERGL(A1,A2)
      IMPLICIT NONE
      CHARACTER*(*) A1,A2
      CHARACTER*250 B1,B2
      B1=A1
      B2=A2
      CALL LOWUP(B1)
      CALL LOWUP(B2)
      VERGL=B1.EQ.B2
      RETURN
      END
!-----
!******************************
      SUBROUTINE SORTIER(CH001,N)
      IMPLICIT NONE
      CHARACTER*(*) CH001(*)
      CHARACTER*80 CH1(2,10000)
      INTEGER*4 I,II,N,K,K2,IN,OUT,IS,CHECK,I1,I2,I1MAX,I2MAX
!-----
      DO 500,I=1,N
  500 CH1(1,I)=CH001(I)
!=====
      IN=1
      OUT=2
      K=1
!=====
    1 CONTINUE
      II=0
      K2=2*K
!=====
      DO 510,IS=1,N,K2
      I1=IS
      I1MAX=IS+K-1
      I2=IS+K
      I2MAX=IS+K2-1
    2 CHECK=0
      IF (I1.GT.I1MAX.OR.I1.GT.N) CHECK=CHECK+1
      IF (I2.GT.I2MAX.OR.I2.GT.N) CHECK=CHECK+2
!-- normalfall
      IF (CHECK.EQ.0) THEN
      II=II+1
!C      IF (CH1(IN,I1).LT.CH1(IN,I2)) THEN
      IF (LLT(CH1(IN,I1),CH1(IN,I2))) THEN
      CH1(OUT,II)=CH1(IN,I1)
      I1=I1+1
      ELSE
      CH1(OUT,II)=CH1(IN,I2)
      I2=I2+1
      END IF
      GOTO 2
      END IF
!-- I1 ist fertig
      IF (CHECK.EQ.1) THEN
      DO 600,I=I2,MIN(I2MAX,N)
      II=II+1
      CH1(OUT,II)=CH1(IN,I)
  600 CONTINUE
      END IF
!-- I2 ist fertig
      IF (CHECK.EQ.2) THEN
      DO 605,I=I1,MIN(I1MAX,N)
      II=II+1
      CH1(OUT,II)=CH1(IN,I)
  605 CONTINUE
      END IF
!-- I1 und I2 fertig
  510 CONTINUE
!=====
      K=2*K
      IF (K.GT.N) GOTO 99
      IN=3-IN
      OUT=3-OUT
      GOTO 1
!=====
   99 CONTINUE
      DO 700,I=1,N
      CH001(I)=CH1(OUT,I)
  700 CONTINUE
!=====
      END