kernlib.f

Go to the documentation of this file.

*-------------------------------------------------------------------------------
*
* This file contains the kernlib's package subset needed to build h2root.
* It cannot be used by any kernlib application because many kernlib
* functionalities * are missing.
*
*-------------------------------------------------------------------------------
 
      SUBROUTINE cltou (CHV)
      CHARACTER    CHV*(*)
      DO 19  jj=1,len(chv)
          j = ichar(chv(jj:jj))
          IF (j.LT.97)       GO TO 19
          IF (j.GE.123)      GO TO 19
          chv(jj:jj) = char(j-32)
   19 CONTINUE
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE cutol (CHV)
      CHARACTER    CHV*(*)
      DO 19  jj=1,len(chv)
          j = ichar(chv(jj:jj))
          IF (j.LT.65)       GO TO 19
          IF (j.GE.91)       GO TO 19
          chv(jj:jj) = char(j+32)
   19 CONTINUE
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE uoptc (DATA,POSS,IOPTV)
      INTEGER      IOPTV(9)
      CHARACTER    *(*)  DATA, POSS
      np = len(poss)
      DO 24 j=1,np
      ioptv(j) = 0
      IF (index(DATA,poss(j:j)).NE.0)  ioptv(j)= 1
   24 CONTINUE
      END
 
*-------------------------------------------------------------------------------
 
      FUNCTION lenocc (CHV)
      CHARACTER    chv*(*)
      n = len(chv)
      DO 17  jj= n,1,-1
      IF (chv(jj:jj).NE.' ') GO TO 99
   17 CONTINUE
      jj = 0
   99 lenocc = jj
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE ubunch (MS,MT,NCHP)
      dimension ms(99), mt(99), nchp(9)
*      data iblan1/x'20202020'/
*      data mask1/x'000000ff'/
      data iblan1/538976288/
      data mask1/255/
      nch = nchp(1)
      IF (nch) 91,39,11
   11 nwt = ishft(nch,-2)
      ntrail = iand(nch,3)
      js = 0
      IF (nwt.EQ.0) GO TO 31
      DO 24 jt=1,nwt
      mt(jt) = ior(ior(ior(
     + iand(ms(js+1),mask1),
     + ishft(iand(ms(js+2),mask1), 8)),
     + ishft(iand(ms(js+3),mask1),16)),
     + ishft(ms(js+4), 24) )
   24 js = js + 4
      IF (ntrail.EQ.0) RETURN
   31 mwd = iblan1
      js = nch
      DO 34 jt=1,ntrail
      mwd = ior(ishft(mwd,8), iand(ms(js),mask1))
   34 js = js - 1
      mt(nwt+1) = mwd
   39 RETURN
   91 print*, '>>> Abnormal end'
      END
 
*-------------------------------------------------------------------------------
 
      FUNCTION locf (IVAR)
      dimension    ivar(9)
      parameter(nadupw=4, ladupw=2)
      j = loc(ivar)
      locf = ishft(j, -ladupw)
      END
 
      FUNCTION locfr (VAR)
      dimension    var(9)
      parameter(nadupw=4, ladupw=2)
      j = loc(var)
      locfr = ishft(j, -ladupw)
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE vzero (A,N)
      dimension a(*)
      IF (n.LE.0)  RETURN
      DO 9 i= 1,n
    9 a(i)= 0.
      END
 
      SUBROUTINE vzeroi (J,N)
      dimension j(*)
      IF (n.LE.0)  RETURN
      DO 9 i= 1,n
    9 j(i)= 0.
      END
 
*-------------------------------------------------------------------------------
 
      FUNCTION jbit (IZW,IZP)
      jbit = iand(ishft(izw, -(izp-1)), 1)
      END
 
*-------------------------------------------------------------------------------
 
      FUNCTION jbyt (IZW,IZP,NZB)
      parameter(nbitpw=32)
      parameter(nchapw=4)
      jbyt = ishft(ishft(izw,nbitpw+1-izp-nzb), -(nbitpw-nzb))
      END
 
*-------------------------------------------------------------------------------
 
      FUNCTION locati(ARRAY,LENGTH,OBJECT)
      dimension array(2)
      INTEGER array,object
      nabove = length + 1
      nbelow = 0
   10 IF (nabove-nbelow .LE. 1)  GO TO 200
      middle = (nabove+nbelow) / 2
      IF (object - array(middle))  100, 180, 140
  100 nabove = middle
      GO TO 10
  140 nbelow = middle
      GO TO 10
  180 locati = middle
      GO TO 300
  200 locati = -nbelow
  300 RETURN
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE vfill (A,N,STUFF)
      INTEGER   A(*), STUFF
      IF (n.LE.0)  RETURN
      DO 9 i= 1,n
    9 a(i)= stuff
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE vblank (A,N)
      INTEGER      A(*), BLANK
      DATA  blank  / 4h     /
      IF (n.LE.0)  RETURN
      DO 9 i= 1,n
    9 a(i)= blank
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE sbyt (IT,IZW,IZP,NZB)
      parameter(nbitpw=32)
      parameter(nchapw=4)
      parameter(iall11 = -1)
      msk = ishft(iall11, -(nbitpw-nzb))
      izw = ior( iand(izw, not(ishft(msk,izp-1)))
     +, ishft(iand(it,msk),izp-1))
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE sbit1 (IZW,IZP)
      izw = ior(izw, ishft(1,izp-1))
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE sbit0 (IZW,IZP)
      izw = iand(izw, not(ishft(1,izp-1)) )
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE uctoh (MS,MT,NPW,NCH)
      CHARACTER    MS*99
      dimension    mt(99)
      parameter(nbitpw=32)
      parameter(nchapw=4)
      CHARACTER    CHWORD*(NCHAPW)
      CHARACTER    BLANK *(NCHAPW)
      parameter(blank = ' ')
      INTEGER      IWORD
      equivalence(iword,chword)
      IF   (nch)             91, 29, 11
   11 IF (npw.LE.0)          GO TO 91
      IF (npw.EQ.1)          GO TO 21
      IF (npw.LT.nchapw)     GO TO 31
      js     = 0
      nwt    = nch / nchapw
      ntrail = nch - nwt*nchapw
      DO 14  jt=1,nwt
      chword = ms(js+1:js+nchapw)
      mt(jt) = iword
   14 js     = js + nchapw
      IF (ntrail.EQ.0)       RETURN
      chword    = ms(js+1:js+ntrail)
      mt(nwt+1) = iword
      RETURN
   21 chword = blank
      DO 24 js=1,nch
      chword(1:1) = ms(js:js)
      mt(js)      = iword
   24 CONTINUE
   29 RETURN
   31 chword = blank
      js     = 0
      nwt    = nch / npw
      ntrail = nch - nwt*npw
      DO 34  jt=1,nwt
      chword(1:npw) = ms(js+1:js+npw)
      mt(jt) = iword
   34 js     = js + npw
      IF (ntrail.EQ.0)       RETURN
      chword    = ms(js+1:js+ntrail)
      mt(nwt+1) = iword
      RETURN
   91 print*, '>>> Abnormal end'
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE uhtoc (MS,NPW,MT,NCH)
      dimension    ms(99)
      CHARACTER    MT*99
      parameter(nchapw=4)
      CHARACTER    CHWORD*(NCHAPW)
      INTEGER      IWORD
      equivalence(iword,chword)
      IF   (nch)             91, 29, 11
   11 IF (npw.LE.0)          GO TO 91
      IF (npw.EQ.1)          GO TO 21
      IF (npw.LT.nchapw)     GO TO 31
      jt     = 0
      nws    = nch / nchapw
      ntrail = nch - nws*nchapw
      DO 14  js=1,nws
      iword  = ms(js)
      mt(jt+1:jt+nchapw) = chword
   14 jt  = jt + nchapw
      IF (ntrail.EQ.0)       RETURN
      iword = ms(nws+1)
      mt(jt+1:jt+ntrail) = chword(1:ntrail)
      RETURN
   21 DO 24  js=1,nch
      iword  = ms(js)
      mt(js:js) = chword(1:1)
   24 CONTINUE
   29 RETURN
   31 jt     = 0
      nws    = nch / npw
      ntrail = nch - nws*npw
      DO 34  js=1,nws
      iword  = ms(js)
      mt(jt+1:jt+npw) = chword(1:npw)
   34 jt  = jt + npw
      IF (ntrail.EQ.0)       RETURN
      iword = ms(nws+1)
      mt(jt+1:jt+ntrail) = chword(1:ntrail)
      RETURN
   91 print *,' UHTOC: wrong args.'
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE uctoh1 (MS,MT,NCH)
      CHARACTER    MS*99
      dimension    mt(99)
      parameter(nbitpw=32)
      parameter(nchapw=4)
      CHARACTER    CHWORD*(NCHAPW)
      CHARACTER    BLANK *(NCHAPW)
      parameter(blank = ' ')
      INTEGER      IWORD
      equivalence(iword,chword)
      IF   (nch)             91, 29, 11
   11 chword = blank
      DO 24 js=1,nch
      chword(1:1) = ms(js:js)
      mt(js)      = iword
   24 CONTINUE
   29 RETURN
   91 print*, '>>> Abnormal end'
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE ucopyi (IA,IB,N)
      dimension ia(*),ib(*)
      IF (n.EQ.0) RETURN
         DO 21 i=1,n
   21 ib(i)=ia(i)
      END
      SUBROUTINE ucopy (A,B,N)
      dimension a(*),b(*)
      IF (n.EQ.0) RETURN
         DO 21 i=1,n
   21 b(i)=a(i)
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE upkbyt (MBV,JTHP,MIV,NINTP,NBITS)
      dimension miv(99), mbv(99), jthp(9), nintp(9), nbits(2)
      parameter(nbitpw=32)
      parameter(nchapw=4)
      parameter(iall11 = -1)
 
      jth = jthp(1)
      nint = nintp(1)
      IF (nint.LE.0) RETURN
      nzb = nbits(1)
      IF (nzb.GT.0) GO TO 11
      nzb = 1
      npwd = nbitpw
      mska = 1
      GO TO 12
   11 npwd = nbits(2)
      mska = ishft(iall11, -(nbitpw-nzb))
   12 jbv = 1
      jiv = 0
      IF (jth.LT.2) GO TO 21
      jbv = (jth-1)/npwd + 1
      jpos = jth - (jbv-1)*npwd - 1
      IF (jpos.EQ.0) GO TO 21
      nr = jpos*nzb
      jive = npwd - jpos
      izw = ishft(mbv(jbv), -nr)
      GO TO 22
   21 jive = jiv + npwd
      izw = mbv(jbv)
   22 jive = min(nint,jive)
   24 jiv = jiv + 1
      miv(jiv) = iand(mska,izw)
      IF (jiv.EQ.jive) GO TO 27
      izw = ishft(izw, -nzb)
      GO TO 24
   27 IF (jiv.EQ.nint) RETURN
      jbv = jbv + 1
      GO TO 21
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE cfopen (LUNDES, MEDIUM, NWREC, MODE, NBUF, NAME, ISTAT)
      dimension    lundes(9), istat(9)
      CHARACTER    MODE*(*), NAME*(*)
      dimension    nvmode(4)
      CHARACTER    CHUSE*4
      lgn = lnblnk(name)
      chuse = mode
      CALL cutol (chuse)
      CALL vzeroi (nvmode,4)
      IF (index(chuse,'a').NE.0)  nvmode(1) = 2
      IF (index(chuse,'w').NE.0)  THEN
          IF (nvmode(1).NE.0)      GO TO 91
          nvmode(1) = 1
        ENDIF
      IF (index(chuse,'r').NE.0)  THEN
          IF (nvmode(1).NE.0)      GO TO 91
        ENDIF
      IF (index(chuse,'+').NE.0)  nvmode(2) = 1
      IF (index(chuse,'l').NE.0)  nvmode(3) = 1
      CALL cfopei (lundes,medium,nwrec,nvmode,nbuf,name,istat,lgn)
      RETURN
   91 lundes(1) = 0
      istat(1)  = -1
      END
 
*-------------------------------------------------------------------------------
 
      INTEGER FUNCTION cfstat (NAME, INFO)
      CHARACTER*(*)  name
      INTEGER        info(12), cfstati
      lgn   = lnblnk(name)
      cfstat = cfstati(name, info, lgn)
      END
 
*-------------------------------------------------------------------------------
 
      SUBROUTINE ucopy2 (A,B,N)
      dimension a(*),b(*)
      IF (n.LT.2) GO TO 41
      ia = locfr(a)
      ib = locfr(b)
      IF (ia-ib) 20,99,10
   10 DO 15 i=1,n
   15 b(i) = a(i)
      RETURN
   20 DO 25 i=n,1,-1
   25 b(i) = a(i)
      RETURN
   41 IF (n.LE.0) RETURN
      b(1) = a(1)
   99 RETURN
      END
 
*-------------------------------------------------------------------------------