MINICERN/packlib/zebra/rz/rzread.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.2  1997/01/28 10:43:18  jamie
   6 * bug fix for dble precision on record boundary from Marthe Brun
   7 *
   8 * Revision 1.1.1.1  1996/03/06 10:47:26  mclareni
   9 * Zebra
  10 *
  11 *
  12 #include "zebra/pilot.h"
  13       SUBROUTINE RZREAD(V,N,IPC,IFORM)
  14 *
  15 ************************************************************************
  16 *
  17 *           Read N words from input buffer into V
  18 *
  19 * Called by RZIN,RZINS,RZVIN
  20 *
  21 *  Author  : R.Brun, B.Holl
  22 *  Written : 07.05.86
  23 *  Last mod: 17.05.93 Change test on IFOCON(1) to .LT.0
  24 *            28.01.97 Several changes (commented) regarding double
  25 *                     precision words falling on record boundaries
  26 *
  27 ************************************************************************
  28 #if !defined(CERNLIB_FQXISN)
  29 #include "zebra/zunit.inc"
  30 #endif
  31 #include "zebra/rzcl.inc"
  32 #include "zebra/rzclun.inc"
  33 #include "zebra/rzcout.inc"
  34 #include "zebra/rzk.inc"
  35 #include "zebra/mzioc.inc"
  36       DIMENSION V(*)
  37 *
  38 *-----------------------------------------------------------------------
  39 *
  40 *           Find first record
  41 *
  42       NL1=LREC-IP1+1
  43       IF(IPC.LE.NL1)THEN
  44          IRS=IR1
  45          IS1=IP1+IPC-1
  46       ELSE
  47          NBEF=(IPC-NL1-1)/LREC
  48          IRS=IR2+NBEF
  49          IS1 =IPC-NL1-NBEF*LREC
  50       ENDIF
  51 *
  52       LRIN=LQ(KQSP+LTOP-7)
  53       IF(LRIN.EQ.0)THEN
  54          CALL MZBOOK(JQPDVS,LRIN,LTOP,-7,'RZIN',0,0,LREC+1,2,-1)
  55          IQ(KQSP+LRIN-5)=IQ(KQSP+LTOP-5)
  56          IQ(KQSP+LTOP+KIRIN)=0
  57          IRIN=0
  58       ELSE
  59          IRIN=IQ(KQSP+LTOP+KIRIN)
  60       ENDIF
  61       LROUT=LQ(KQSP+LTOP-6)
  62       IF(LROUT.EQ.0)THEN
  63          IROUT=0
  64       ELSE
  65          IROUT=IQ(KQSP+LTOP+KIROUT)
  66       ENDIF
  67       IF(IRS.NE.IRIN)THEN
  68          IF(IRS.NE.IROUT)THEN
  69             CALL RZIODO(LUN,LREC,IRS,IQ(KQSP+LRIN+1),1)
  70             IF(IQUEST(1).NE.0)GO TO 90
  71             IRIN=IRS
  72             IQ(KQSP+LTOP+KIRIN)=IRIN
  73          ENDIF
  74       ENDIF
  75 *
  76 *           Read record into array V
  77 *
  78 #if !defined(CERNLIB_FQXISN)
  79       IF(IMODEX.GT.0.AND.IFORM.NE.1)THEN
  80          NWFOTT = N
  81          NWFODN = 0
  82          IF(IFORM.GT.0)THEN
  83             MFO(1) = IFORM
  84             MFO(2) = -1
  85             JFOEND = 2
  86          ENDIF
  87       ENDIF
  88 #endif
  89       NLEFT=LREC-IS1+1
  90       IF(N.LE.NLEFT)THEN
  91          NP1=N
  92       ELSE
  93          NP1=NLEFT
  94       ENDIF
  95       IF(IRS.NE.IROUT)THEN
  96 #if !defined(CERNLIB_FQXISN)
  97          IF(IMODEX.GT.0.AND.IFORM.NE.1)THEN
  98             NWFOAV=NP1
  99             CALL FZICV(IQ(KQSP+LRIN+IS1),V)
 100             IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
 101             IF(NWFOAV.LT.0)IDOUB1=IQ(KQSP+LRIN+IS1+NP1-1)
 102             IQUEST(1)=0
 103          ELSE
 104 #endif
 105             CALL UCOPY(IQ(KQSP+LRIN+IS1),V,NP1)
 106 #if !defined(CERNLIB_FQXISN)
 107          ENDIF
 108 #endif
 109       ELSE
 110 #if !defined(CERNLIB_FQXISN)
 111          IF(IMODEX.GT.0.AND.IFORM.NE.1)THEN
 112             NWFOAV=NP1
 113             CALL FZICV(IQ(KQSP+LROUT+IS1),V)
 114             IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
 115             IF(NWFOAV.LT.0)IDOUB1=IQ(KQSP+LROUT+IS1+NP1-1)
 116             IQUEST(1)=0
 117          ELSE
 118 #endif
 119             CALL UCOPY(IQ(KQSP+LROUT+IS1),V,NP1)
 120 #if !defined(CERNLIB_FQXISN)
 121          ENDIF
 122 #endif
 123       ENDIF
 124       IF(NP1.LT.N)THEN
 125          NR=(N-NP1-1)/LREC+1
 126          IF(IRS.EQ.IR1)THEN
 127             IRS=IR2
 128          ELSE
 129             IRS=IRS+1
 130          ENDIF
 131          DO 60 I=1,NR
 132             IF(I.NE.NR)THEN
 133 #if !defined(CERNLIB_FQXISN)
 134                IF(IMODEX.GT.0.AND.IFORM.NE.1)THEN
 135                   CALL RZIODO(LUN,LREC,IRS+I-1,IQ(KQSP+LRIN+1),1)
 136                   IF(IQUEST(1).NE.0)GO TO 90
 137                   IF(NWFOAV.LT.0)THEN
 138                      CALL UCOPY2(IQ(KQSP+LRIN+1),IQ(KQSP+LRIN+2),LREC)
 139                      IQ(KQSP+LRIN+1)=IDOUB1
 140 * need to convert one extra word if double falls on record boundary
 141                      NWFOAV=LREC+1
 142                      CALL FZICV(IQ(KQSP+LRIN+1),V)
 143                      CALL UCOPY2(IQ(KQSP+LRIN+2),IQ(KQSP+LRIN+1),LREC)
 144                   ELSE
 145                      NWFOAV=LREC
 146                      CALL FZICV(IQ(KQSP+LRIN+1),V)
 147                   ENDIF
 148                   IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
 149 *                 IF(NWFOAV.LT.0)IDOUB1=IQ(KQSP+LROUT+LREC)
 150 * should be LRIN
 151                   IF(NWFOAV.LT.0)IDOUB1=IQ(KQSP+LRIN+LREC)
 152                   IQUEST(1)=0
 153                ELSE
 154 #endif
 155                   CALL RZIODO(LUN,LREC,IRS+I-1,V(NP1+1),1)
 156                   IF(IQUEST(1).NE.0)GO TO 90
 157 #if !defined(CERNLIB_FQXISN)
 158                ENDIF
 159 #endif
 160                NP1=NP1+LREC
 161             ELSE
 162                NL=N-NP1
 163                IRIN=IRS+I-1
 164                IF(IRIN.NE.IROUT)THEN
 165                   CALL RZIODO(LUN,LREC,IRIN,IQ(KQSP+LRIN+1),1)
 166                   IF(IQUEST(1).NE.0)GO TO 90
 167 #if !defined(CERNLIB_FQXISN)
 168                   IF(IMODEX.GT.0.AND.IFORM.NE.1)THEN
 169                      IF(NWFOAV.LT.0)THEN
 170                        CALL UCOPY2(IQ(KQSP+LRIN+1),IQ(KQSP+LRIN+2),LREC)
 171                        IQ(KQSP+LRIN+1)=IDOUB1
 172 * need to convert one extra word if double falls on record boundary
 173                        NWFOAV=NL+1
 174                        CALL FZICV(IQ(KQSP+LRIN+1),V)
 175                        CALL UCOPY2(IQ(KQSP+LRIN+2),IQ(KQSP+LRIN+1),LREC)
 176                      ELSE
 177                        NWFOAV=NL
 178                        CALL FZICV(IQ(KQSP+LRIN+1),V)
 179                      ENDIF
 180                      IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
 181                      IF(NWFOAV.LT.0)IDOUB1=IQ(KQSP+LRIN+NL)
 182                      IQUEST(1)=0
 183                   ELSE
 184 #endif
 185                      CALL UCOPY(IQ(KQSP+LRIN+1),V(NP1+1),NL)
 186 #if !defined(CERNLIB_FQXISN)
 187                   ENDIF
 188 #endif
 189                   IQ(KQSP+LTOP+KIRIN)=IRIN
 190                ELSE
 191 #if !defined(CERNLIB_FQXISN)
 192                  IF(IMODEX.GT.0.AND.IFORM.NE.1)THEN
 193                    IF(NWFOAV.LT.0)THEN
 194                      CALL UCOPY2(IQ(KQSP+LROUT+1),IQ(KQSP+LROUT+2),LREC)
 195                      IQ(KQSP+LROUT+1)=IDOUB1
 196 * need to convert one extra word if double falls on record boundary
 197                      NWFOAV=NL+1
 198                      CALL FZICV(IQ(KQSP+LROUT+1),V)
 199                      CALL UCOPY2(IQ(KQSP+LROUT+2),IQ(KQSP+LROUT+1),LREC)
 200                    ELSE
 201                      NWFOAV=NL
 202                      CALL FZICV(IQ(KQSP+LROUT+1),V)
 203                    ENDIF
 204                    IF(NWFOAV.GT.0.OR.IFOCON(1).LT.0)GO TO 95
 205                    IF(NWFOAV.LT.0)IDOUB1=IQ(KQSP+LROUT+NL)
 206                    IQUEST(1)=0
 207                  ELSE
 208 #endif
 209                      CALL UCOPY(IQ(KQSP+LROUT+1),V(NP1+1),NL)
 210 #if !defined(CERNLIB_FQXISN)
 211                   ENDIF
 212 #endif
 213                ENDIF
 214             ENDIF
 215   60     CONTINUE
 216       ENDIF
 217   90  CONTINUE
 218 #if defined(CERNLIB_QMVAX)
 219       IF(IRELAT.NE.0)UNLOCK(UNIT=LUN)
 220 #endif
 221 #if !defined(CERNLIB_FQXISN)
 222       GO TO 99
 223   95  IQUEST(1) =4
 224       IQUEST(11)=NWFOTT
 225       IQUEST(12)=NWFORE
 226       IQUEST(13)=NWFOAV
 227       IQUEST(14)=NWFODN
 228       IF(JBYT(IQ(KQSP+LTOP),15,3)-3.GE.-2) WRITE(IQLOG,1000)
 229  1000 FORMAT(' RZREAD. Error during conversion into native format')
 230 #endif
 231   99  RETURN
 232       END