*
* $Id$
*
* $Log$
* Revision 1.1  1996/02/15 17:48:32  mclareni
* Initial revision
*
*
#if defined(CERNLIB_QMIBMVF)
* ** last mod 2 Oct 1990 15:00:59
LOCATI   CSECT               vector version of locati
*                            tuned for 3090E CERN
*                            section size 128
#if defined(CERNLIB_QMIBMXA)
LOCATI   AMODE 31
LOCATI   RMODE ANY
#endif
*****************************************************************
         PRINT NOGEN         vector version of locati
         USING *,15          tuned for 3090E CERN
*--------------------------
KSECT    EQU   128           (section size 128)
*--------------------------
         STM   14,12,12(13)
*****************************************************************
         LM    G4,G6,0(G1)   get addresses
**       LE    F0,0(G6)      get object
         L     G1,0(G6)      get object
         L     G5,0(G5)      get length
         SR    G0,G0         zero g0 for work
*--------------------------
         C     G5,K64       comp length with 64
         BL    L64          if lt 64 go to L64
*====================
         S     G5,K4096      comp length with 4096
         BM    P32           if lt 4096 go to p32
         S     G5,K4096      comp length with 8192
         BM    P64           if lt 8192 go to p64
         B     PSCAV         else go to pscav
*====================
P32      EQU   *             vector length lt 4096
         A     G5,K4064      reset to length-32
         LA    G8,32(G5)     copy G5 in G8 (length)
         LR    G11,G4        copy array address
*====================
         LA    G4,KSECT(G4)  add 128 (32 words) to begin addr
         LA    G7,32         set G7 to stride (32)
*====================
         SR    G6,G6         zero G6 for work
******************           vector loop
         SRL   G8,5          divide length by 32
VLOOP    EQU   *             vector loop on full vector
         VLVCU G8            with stride = 32
         VCS   LE,G1,G4(G7)  search object
         VCZVM G6            count left zero in vmr
         BC    8,NF          if none go to nf
         SLL   G6,5          mult sum by 32 (stride)
         B     NEXTK         go to seq search
*====================
NF       EQU   *             not found in sect
         LTR   G8,G8         test vector length
         BC    2,VLOOP       if some more loop
         LR    G6,G5         set g6 to length-32
NEXTK    EQU   *             seq search with length = 32
         LR    G7,G6         copy k-1
         SLL   G6,2          (k-1)*4
         AR    G11,G6        array(k) address
         LR    G3,G11        copy array address
******************           seq search
         VLVCA 32(0)         with length=32
         VCS   LE,G1,G3      search object
         VCZVM G0            count left zeros (n-1)
         LR    G2,G0         copy count in G2
         SLL   G2,2          mult by 4 (convert to addr)
         AR    G0,G7         add displ
         C     G1,0(G11,G2)  comp object for equal
         BE    EQUAL         if eq branch
         LCR   G0,G0         set (n-1) = -(n-1)
         LM    2,12,28(13)
         BR    14
* END SUBROUTINE *********** seq search
EQUAL    A     G0,K1         set value to n
         LM    2,12,28(13)
         BR    14
* END SUBROUTINE *********** seq search
* no sectionning ************
L64      EQU   *             no sect length le 32
         LR    G3,G4         get array addr
         VLVCU G5            set vector length (le.64)
         VCS   LE,G1,G3      search object
         VCZVM G0            count left zeros (n-1)
         LR    G2,G0         copy count in G2
         SLL   G2,2          mult by 4 (convert to addr)
         C     G1,0(G4,G2)   comp object for equal
         BE    EQL64         if eq branch
         LCR   G0,G0         if ne set (n-1)= -(n-1)
         LM    2,12,28(13)   reset
         BR    14            return
* END SUBROUTINE ***********
EQL64    A     G0,K1         set value to n
         LM    2,12,28(13)   reset
         BR    14            return
* END SUBROUTINE ***********
*****************************************************************
PSCAV    EQU   *
         A     G5,K8192      RESET G5 VALUE (LENGTH)
         SR    G3,G3         nbel=0
         LA    G5,1(G5)      nab = length + 1
DIX      EQU   *
         LR    G6,G5         copy nab
         SR    G6,G3         g7 = (nab-nbel)
         C     G6,K128
         BNH   VECT          then go vector (one sect max)
         LR    G12,G5        copy nab in g12
         AR    G12,G3        g12 = (nab+nbel)
         SRL   G12,1         g12 = (nab+nbel)/2
         LR    G11,G12       copy mid in g11
         BCTR  G12,0         mid-1
         SLL   G12,2         (mid-1)*4 for addressing
         C     G1,0(G4,G12)  if(object-array(mid)) 100,180,140
         BE    EQU           180
         BL    MINUS         100
PLUS     EQU   *             140
         LR    G3,G11        nbel=mid
         B     DIX           go to dix
MINUS    EQU   *             100
         LR    G5,G11        nab=mid
         B     DIX           go to dix
EQU      LR    G0,G11        locata=mid     180
#include "exitg.inc"
VECT     LR    G8,G3         get nbel
         SLL   G8,2          g8 = (nbel+1)*4
         AR    G8,G4         g8=array(nbel+1)
         LR    G9,G8         g9=g8=array(nbel+1)
         VLVCU G6            vect length= (nab-nbel)
         VCS   LE,G1,G8      search object
         VCZVM G0            get loc
         BC    8,NFS
         LR    G2,G0         copy in g2
         SLL   G2,2          mult by 4
         C     G1,0(G9,G2)   comp object array(loc)
         BE    EQUV
         AR    G0,G3         locata=loc+nbel
         LCR   G0,G0         locata= - locata
#include "exitg.inc"
EQUV     AR    G0,G3
         A     G0,K1         locata=loc+nbel
#include "exitg.inc"
NFS      S     G0,K1         LOCATA= - LOCATA
         AR    G0,G3         locata=loc+nbel
         LCR   G0,G0         locata= - locata
#include "exitg.inc"
*****************************************************************
*====================
P64      EQU   *
         A     G5,K8128      reset G5 to length-64
         LA    G8,64(G5)     copy length in G8
         LR    G11,G4        copy array address
*====================
         LA    G4,256(G4)    add 256 (64 words) to begin addr
         LA    G7,64         set G7 to stride (64)
*====================
         SR    G6,G6         zero G6 for work
******************           vector loop
         SRL   G8,6          divide length by 64
VL64     EQU   *             vector loop on full vector
         VLVCU G8            with stride = 64
         VCS   LE,G1,G4(G7)  search object
         VCZVM G6            count left zero in vmr
         BC    8,NF64
         SLL   G6,6          mult sum by 64 (stride)
         B     SEQ64
*====================
NF64     EQU   *             not found in sect
         LTR   G8,G8         test vector count
         BC    2,VL64        if some more loop
         LR    G6,G5         set g6 to length-64
SEQ64    EQU   *             seq search with length = 64
         LR    G7,G6         copy k-1
         SLL   G6,2          (k-1)*4
         AR    G11,G6        array(k) address
         LR    G3,G11        copy array address
****     SR    G0,G0         zero g0 for work
******************           seq search
         VLVCA 64(0)         with length=64
         VCS   LE,G1,G3      search object
         VCZVM G0            count left zeros (n-1)
         LR    G2,G0         copy count in G2
         SLL   G2,2          mult by 4 (convert to addr)
         AR    G0,G7         add displ
         C     G1,0(G11,G2)  comp object for equal
         BE    EQ64          if eq branch
         LCR   G0,G0         set (n-1) = -(n-1)
         LM    2,12,28(13)
         BR    14
* END SUBROUTINE *********** seq search
EQ64     A     G0,K1         set value to n
         LM    2,12,28(13)
         BR    14
* END SUBROUTINE *********** seq search
*====================
         DS    0D
K1       DC    F'1'
K32      DC    F'32'
K48      DC    F'48'
K64      DC    F'64'
K128     DC    F'128'
K2048    DC    F'2048'
K4064    DC    F'4064'
K4096    DC    F'4096'
K8128    DC    F'8128'
K8192    DC    F'8192'
#include "equats.inc"
         END
#endif
