MINICERN/packlib/zebra/rz/rziodo.F

   1 *
   2 * $Id$
   3 *
   4 * $Log$
   5 * Revision 1.6  1998/09/25 09:33:38  mclareni
   6 * Modifications for the Mklinux port flagged by CERNLIB_PPC
   7 *
   8 * Revision 1.5  1998/03/13 16:51:18  mclareni
   9 * Put the record length warning behind a CERNLIB_DEBUG flag to avoid spurious warnings
  10 *
  11 * Revision 1.4  1997/09/02 15:16:12  mclareni
  12 * WINNT corrections
  13 *
  14 * Revision 1.3  1997/05/14 08:33:39  couet
  15 * - Bug fixed by S.O'Neale. atlas problems with cernlib 97a, with rfio/cio
  16 * the record was not correct in rziodo. Now rzfdir.F rest the correct one.
  17 *
  18 * Revision 1.2  1996/04/24 17:26:56  mclareni
  19 * Extend the include file cleanup to dzebra, rz and tq, and also add
  20 * dependencies in some cases.
  21 *
  22 * Revision 1.1.1.1  1996/03/06 10:47:24  mclareni
  23 * Zebra
  24 *
  25 *
  26 #include "zebra/pilot.h"
  27       SUBROUTINE RZIODO(LUNRZ,JREC,IREC1,IBUF,IRW)
  28 *
  29 **********************************************************************
  30 *
  31 *        To read/write a block from disk or memory
  32 *
  33 *       LUNRZ Logical unit number for disk (LUN>0)
  34 *       JREC  Record length
  35 *       IREC  RECORD NUMBER
  36 *       IBUF  ADDRESS OF BUFFER TO BE READ/WRITTEN ON IREC
  37 *       IRW   =1 TO READ
  38 *       IRW   =2 TO WRITE
  39 *
  40 * Called by RZCOP1,RZDELT,RZDFIR,RZFILE,RZFREE,RZLLOK,RZLOCK
  41 *           RZMAKE,RZMDIR,RZOUT,RZREAD,RZSAVE,RZOPEN
  42 *
  43 *  Author  : R.Brun DD/US/PD
  44 *  Written : 01.04.86
  45 *  Last mod: 10.06.94 Implement File striping for PIAF (R.Brun)
  46 *                     New routine RZSTRIR called
  47 *  Last mod: 26.10.93 IQUEST(1) = 101 in case of READ error,
  48 *                                 102 in case of WRITE error
  49 *
  50 ************************************************************************
  51 *
  52 #include "zebra/zunit.inc"
  53 #include "zebra/rzcl.inc"
  54 #include "zebra/rzclun.inc"
  55 #include "zebra/rzbuff.inc"
  56 #include "zebra/rzcount.inc"
  57 #if defined(CERNLIB_QMUIX)
  58 #include "zebra/rzcstr.inc"
  59 #endif
  60       DIMENSION IBUF(JREC)
  61       PARAMETER (MEDIUM=0)
  62 *
  63 *-----------------------------------------------------------------------
  64 *
  65
  66 #include "zebra/q_jbyt.inc"
  67
  68 *
  69 *     I/O statistics
  70 *
  71       RZXIO(IRW) = RZXIO(IRW) + JREC
  72
  73       IREC=IREC1
  74       IF(LUNRZ.GT.0)THEN
  75          NERR=0
  76 #if defined(CERNLIB_DEBUG)
  77 C    Too many false alarms occur if we leave this in production code.
  78          IF ( IREC.GT.2 .AND. IZRECL.NE.JREC ) THEN
  79             WRITE(IQLOG,10010) LUNRZ,IREC,IZRECL,JREC
  80 10010       FORMAT(' RZIODO. Potential Record Length Problem   LUN =',I6,
  81      +             ' IREC =',I6,' IZRECL =',I6,'  JREC =',I6)
  82          END IF
  83 #endif
  84          IF(IMODEH.NE.0) THEN
  85 *
  86             IQUEST(1) = JBYT(IQ(KQSP+LTOP),7,7)
  87             IQUEST(2) = JREC
  88             IQUEST(4) = IREC
  89             IOWAY     = IRW - 1
  90 *
  91 #if defined(CERNLIB_QMVAX)||defined(CERNLIB_QMVMI)||defined(CERNLIB_QMDOS)||(defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
  92 *
  93 *     Byte swap
  94 *
  95             IF(IRW.EQ.2.AND.IMODEX.NE.0) CALL VXINVB(IBUF,JREC)
  96 #endif
  97             CALL JUMPST(LUNRZ)
  98             CALL JUMPX2(IBUF,IOWAY)
  99
 100             IF(IQUEST(1).NE.0) IQUEST(1) = 100 + IRW
 101 #if defined(CERNLIB_QMVAX)||defined(CERNLIB_QMVMI)||defined(CERNLIB_QMDOS)||(defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
 102 *
 103 *     Byte swap
 104 *
 105             IF(IMODEX.NE.0) CALL VXINVB(IBUF,JREC)
 106 #endif
 107          ELSE
 108 *
 109 *     Read a record
 110 *
 111    10       IF (IRW.EQ.1)THEN
 112 *
 113 *     Fortran I/O
 114 *
 115                IF(IMODEC.EQ.0) THEN
 116 #if defined(CERNLIB_QMUIX)
 117 *-* Case of File striping
 118 *
 119       if(nstrip(lunrz).gt.0)then
 120          call rzstrir(lunrz,irec)
 121       endif
 122 *
 123 #endif
 124 #if defined(CERNLIB_QMVDS)
 125                   CALL READ_ASS(LUNRZ,IREC,ISTAT,IBUF)
 126                   IF(ISTAT.EQ.1)GO TO 20
 127 #endif
 128 #if (!defined(CERNLIB_QMVDS))&&(!defined(CERNLIB_QMCRY))&&(!defined(CERNLIB_QMCV64))
 129                   READ (UNIT=LUNRZ,REC=IREC,ERR=20,IOSTAT=ISTAT)IBUF
 130 #endif
 131 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 132 *
 133 *     Exchange mode on Cray and Convex - read JREC/2 64 bit
 134 *     words (=JREC 32 bit words)
 135 *
 136                   IF(IMODEX.NE.0) THEN
 137                      CALL RZIPHD(LUNRZ,JREC/2,IREC,ITEST,ISTAT)
 138                      IF(ISTAT.NE.0) GOTO 20
 139 #endif
 140 #if defined(CERNLIB_QMCV64)
 141 *
 142 *     Unpack 32 bit words to 64 bit words
 143 *
 144                      CALL UPAK32(ITEST,IBUF,JREC)
 145 #endif
 146 #if defined(CERNLIB_QMCRY)
 147 *
 148 *     Unpack 32 bit words to 64 bit words
 149 *
 150                      CALL UNPACK(ITEST,32,IBUF,JREC)
 151 #endif
 152 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 153 *
 154 *     Native mode
 155 *
 156                   ELSE
 157                      READ(UNIT=LUNRZ,REC=IREC,ERR=20,IOSTAT=ISTAT)IBUF
 158                   ENDIF
 159 #endif
 160 *
 161 *     C I/O
 162 *
 163                ELSE
 164 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 165                   IF(IMODEX.NE.0) THEN
 166 *
 167 *      Exchange mode?
 168 *
 169                      CALL CFSEEK(LUNRZ-1000,MEDIUM,IZRECL/2,IREC-1,
 170      +               ISTAT)
 171                      NWTAK = JREC / 2
 172                      CALL CFGET(LUNRZ-1000,MEDIUM,JREC,NWTAK,ITEST,
 173      +               ISTAT)
 174                      IF(ISTAT.NE.0) GOTO 20
 175 #endif
 176 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 177 *
 178 *     Unpack
 179 *
 180 #endif
 181 #if defined(CERNLIB_QMCRY)
 182                      CALL UNPACK(ITEST,32,IBUF,JREC)
 183 #endif
 184 #if defined(CERNLIB_QMCV64)
 185                      CALL UPAK32(ITEST,IBUF,JREC)
 186 #endif
 187 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 188                   ELSE
 189 #endif
 190 #if defined(CERNLIB_QMIBM)||defined(CERNLIB_QMVDS)
 191 *
 192 *     C I/O not supported
 193 *
 194                      ISTAT = 99
 195 #endif
 196 #if defined(CERNLIB_QMUIX)
 197 *-* Case of File striping
 198 *
 199       if(nstrip(lunrz-1000).gt.0)then
 200          call rzstrir(lunrz-1000,irec)
 201       endif
 202 *
 203 #endif
 204 #if (!defined(CERNLIB_QMVDS))&&(!defined(CERNLIB_QMIBM))
 205                      CALL CFSEEK(LUNRZ-1000,MEDIUM,IZRECL,IREC-1,ISTAT)
 206                      NWTAK = JREC
 207                      CALL CFGET(LUNRZ-1000,MEDIUM,JREC,NWTAK,IBUF,
 208      +               ISTAT)
 209                      IF(ISTAT.NE.0) GOTO 20
 210 #endif
 211 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 212                   ENDIF
 213 #endif
 214                ENDIF
 215 #if defined(CERNLIB_QMVAX)||defined(CERNLIB_QMVMI)||defined(CERNLIB_QMDOS)||(defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
 216 *
 217 *     Byte swap if exchange mode
 218 *
 219                IF(IMODEX.NE.0) CALL VXINVB(IBUF,JREC)
 220 #endif
 221 *
 222 *     Write
 223 *
 224             ELSE
 225 #if defined(CERNLIB_QMVAX)||defined(CERNLIB_QMVMI)||defined(CERNLIB_QMDOS)||(defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
 226 *
 227 *     Byte swap if exchange mode
 228 *
 229                IF(IMODEX.NE.0) CALL VXINVB(IBUF,JREC)
 230 #endif
 231                IF(IMODEC.EQ.0) THEN
 232 #if defined(CERNLIB_QMVDS)
 233                   CALL WRITE_ASS(LUNRZ,IREC,ISTAT,IBUF)
 234                   IF(ISTAT.EQ.1)GO TO 20
 235 #endif
 236 #if (!defined(CERNLIB_QMVDS))&&(!defined(CERNLIB_QMCRY))&&(!defined(CERNLIB_QMCV64))
 237                   WRITE(UNIT=LUNRZ,REC=IREC,ERR=20,IOSTAT=ISTAT)IBUF
 238 #endif
 239 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 240                   IF(IMODEX.NE.0) THEN
 241 *
 242 *     Pack
 243 *
 244 #endif
 245 #if defined(CERNLIB_QMCRY)
 246                      CALL PACK(IBUF,32,ITEST,JREC)
 247 #endif
 248 #if defined(CERNLIB_QMCV64)
 249                      CALL PACK32(IBUF,ITEST,JREC)
 250 #endif
 251 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 252                      CALL RZOPHD(LUNRZ,IZRECL/2,IREC,ITEST,ISTAT)
 253                      IF(ISTAT.NE.0) GOTO 20
 254                   ELSE
 255                      WRITE(UNIT=LUNRZ,REC=IREC,ERR=20,IOSTAT=ISTAT)
 256      +               IBUF
 257                   ENDIF
 258 #endif
 259                ELSE
 260 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 261                   IF(IMODEX.NE.0) THEN
 262 *
 263 *     Pack
 264 *
 265 #endif
 266 #if defined(CERNLIB_QMCRY)
 267                      CALL PACK(IBUF,32,ITEST,JREC)
 268 #endif
 269 #if defined(CERNLIB_QMCV64)
 270                      CALL PACK32(IBUF,ITEST,JREC)
 271 #endif
 272 #if defined(CERNLIB_QMCRY)||defined(CERNLIB_QMCV64)
 273                      JREC = JREC / 2
 274                      CALL CFSEEK(LUNRZ-1000,MEDIUM,IZRECL/2,IREC-1,
 275      +               ISTAT)
 276                      IF(ISTAT.NE.0) GOTO 20
 277                      CALL CFPUT(LUNRZ-1000,MEDIUM,JREC/2,ITEST,ISTAT)
 278                      IF(ISTAT.NE.0) GOTO 20
 279                   ELSE
 280                      CALL CFSEEK(LUNRZ-1000,MEDIUM,IZRECL,IREC-1,ISTAT)
 281                      IF(ISTAT.NE.0) GOTO 20
 282                      CALL CFPUT(LUNRZ-1000,MEDIUM,JREC,IBUF,ISTAT)
 283                      IF(ISTAT.NE.0) GOTO 20
 284                   ENDIF
 285 #endif
 286 #if defined(CERNLIB_QMIBM)||defined(CERNLIB_QMVDS)
 287 *
 288 *     C I/O not supported
 289 *
 290                   ISTAT = 99
 291 #endif
 292 #if (!defined(CERNLIB_QMVDS))&&(!defined(CERNLIB_QMCRY))&&(!defined(CERNLIB_QMCV64))&&(!defined(CERNLIB_QMIBM))
 293                   CALL CFSEEK(LUNRZ-1000,MEDIUM,IZRECL,IREC-1,ISTAT)
 294                   IF(ISTAT.NE.0) GOTO 20
 295                   CALL CFPUT(LUNRZ-1000,MEDIUM,JREC,IBUF,ISTAT)
 296                   IF(ISTAT.NE.0) GOTO 20
 297 #endif
 298                ENDIF
 299 #if defined(CERNLIB_QMVAX)||defined(CERNLIB_QMVMI)||defined(CERNLIB_QMDOS)||(defined(CERNLIB_QMLNX) && !defined(CERNLIB_PPC))||defined(CERNLIB_WINNT)
 300 *
 301 *     Byte swap back
 302 *
 303                IF(IMODEX.NE.0) CALL VXINVB(IBUF,JREC)
 304 #endif
 305             ENDIF
 306             RETURN
 307    20       NERR=NERR+1
 308 #if defined(CERNLIB_QMVAX)
 309             CALL LIB$WAIT(0.1)
 310 #endif
 311 #if defined(CERNLIB_QMCRY)
 312             IC = SLEEPF(1)
 313 #endif
 314             IF(NERR.LT.100)GO TO 10
 315             IQUEST(1)=100+IRW
 316             WRITE(IQLOG,1000)IREC,LUNRZ,ISTAT
 317  1000       FORMAT(' RZIODO. Error at record =',I5,' LUN =',I6,
 318      +             ' IOSTAT =',I6)
 319          ENDIF
 320       ELSE
 321          KOF=IQ(KQSP+LRZ0-2*LUNRZ-1)+IQ(KQSP+LRZ0-2*LUNRZ)*(IREC-1)
 322          IF (IRW.EQ.1)THEN
 323             CALL UCOPY(IQ(KOF),IBUF,JREC)
 324          ELSE
 325             CALL UCOPY(IBUF,IQ(KOF),JREC)
 326          ENDIF
 327       ENDIF
 328 *
 329       END