*
* $Id: fmcopy.F,v 1.1.1.1 1996/03/07 15:18:10 mclareni Exp $
*
* $Log: fmcopy.F,v $
* Revision 1.1.1.1 1996/03/07 15:18:10 mclareni
* Fatmen
*
*
#include "fatmen/pilot.h"
SUBROUTINE FMCOPY(GENAM1,LBANK1,KEYS1,GENAM2,LBANK2,KEYS2,
+CHOPT,IRC)
*
* Subroutine to copy the dataset referenced by GENAM1 to GENAM2.
* If LBANKn not zero, GENAMn is not used.
* Otherwise the bank is fetched from the RZ file using FMGETK
*
* Options:
* A - input already staged (i.e. from FMSMCF)
* if IOPTA.NE.0 cannot call FMOPEN!
* C - use STAGE CHANGE, implies S
* K - queue to CHEOPS
* S - STAGE the input file
* W - with option Z - WAIT for output stage to complete
* Z - STAGE the output file
* F - use FZIN/FZOUT to permit conversion of FZ formats
* (triggered automatically if file format is F*
* but different in input/output banks)
* R - skip Zebra start-of-run/end-of-run records
* U - update catalogue with bank at LBANK2
* P - physical copy - this is the default
*
#include "fatmen/faust.inc"
#include "fatmen/fatupd.inc"
#include "fatmen/fatpara.inc"
#include "fatmen/fatbank.inc"
#include "fatmen/fatstg.inc"
#include "fatmen/fattyp.inc"
#if defined(CERNLIB_CRAY)
CHARACTER*255 CHFIN,CHFOUT
#endif
CHARACTER*(*) CHOPT
INTEGER SYSTEMF,FMNODE,FMHOST,FMUSER
CHARACTER*8 DDNAM1,DDNAM2
CHARACTER*4 CHOPE,CHOPI,CHOPO,CHOPTF
CHARACTER*20 FN1,FN2
CHARACTER*(*) GENAM1,GENAM2
CHARACTER*80 COMAND
CHARACTER*6 VSN1,VID1,FSEQ1,VSN2,VID2,FSEQ2
CHARACTER*15 XVID1,XVID2
CHARACTER*8 VIP1,VIP2
CHARACTER*6 VAXLAB,CHRECL,CHBLK
CHARACTER*256 DSN1,DSN2
CHARACTER*4 DEV1,DEV2,LAB1,LAB2
CHARACTER*8 USER1,ADDR1,USER2,ADDR2
CHARACTER*8 HOST1,HOST2
CHARACTER*40 DCB1,DCB2
CHARACTER*4 RECFM1,RECFM2
CHARACTER*4 FFORM1,FFORM2
CHARACTER*6 CDEN1,CDEN2
CHARACTER*8 LIB1,LIB2
CHARACTER*8 CHUSER,CHHOST,CHTYPE,CHSYS
DIMENSION BUFFER(8172)
PARAMETER (LKEYFA=10)
DIMENSION KEYS1(LKEYFA),KEYS2(LKEYFA)
#include "fatmen/tmsdef0.inc"
#include "fatmen/fatvid0.inc"
#include "fatmen/fatoptd.inc"
#include "fatmen/fatvid1.inc"
#include "fatmen/tmsdef1.inc"
#include "fatmen/fatoptc.inc"
NFCOPY = NFCOPY + 1
IRC = 0
LGN1 = LENOCC(GENAM1)
LGN2 = LENOCC(GENAM2)
IF(IDEBFA.GE.0) THEN
PRINT *,'FMCOPY. enter for ',GENAM1(1:LGN1),
+ ' options = ',CHOPT
IF(GENAM2(1:LGN2).NE.GENAM1(1:LGN1)) PRINT *,'FMCOPY. ',
+ 'output generic name is ',GENAM2(1:LGN2)
IF(LBANK1.NE.0) PRINT *,'FMCOPY. user-supplied bank for ',
+ 'input generic name'
IF(LBANK2.NE.0) PRINT *,'FMCOPY. user-supplied bank for ',
+ 'output generic name'
ENDIF
*
* Check authorisation
*
IC = FMUSER(CHUSER)
IC = FMHOST(CHHOST,CHTYPE,CHSYS)
CALL CLTOU(CHUSER)
CALL CLTOU(CHHOST)
CALL FMACL(CHUSER,CHHOST,GENAM2(1:LGN2),'COPY','A',IRC)
IF(IRC.NE.0) THEN
NVIOL = NVIOL + 1
IF(NVIOL.GT.MAXVIO) CALL ZFATAM
+ ('Maximum number of security violations exceeded')
PRINT *,'FMCOPY. you are not authorised to copy to ',
+ GENAM2(1:LGN2)
RETURN
ENDIF
IF(IOPTC.NE.0) IOPTS = 1
*
* Save bank addresses in link area
*
IF(LBANK1.NE.0) LOLDFA = LBANK1
IF(LBANK2.NE.0) LNEWFA = LBANK2
LTDSFA = 0
IRC = 0
IF(LBANK1.EQ.0) THEN
CALL FMGETK(GENAM1,LBANK1,KEYS1,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.2)
+ PRINT *,'FMCOPY. Return code ',IRC,' from FMGETK'
IRC = 1
RETURN
ELSE
LOLDFA = LBANK1
LTDSFA = 0
ENDIF
ENDIF
IF(LBANK2.EQ.0) THEN
CALL FMGETK(GENAM2,LBANK2,KEYS2,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.2)
+ PRINT *,'FMCOPY. Return code ',IRC,' from FMGETK'
IRC = 1
RETURN
ELSE
LNEWFA = LBANK2
ENDIF
ENDIF
LBANK1 = LOLDFA
*
* Update KEYS vectors from BANKs
*
CALL FMUPKY(GENAM1,LBANK1,KEYS1,IRC)
CALL FMUPKY(GENAM2,LBANK2,KEYS2,IRC)
*
* Check that TARGET ^= SOURCE
*
CALL FMCOMP(GENAM1,LBANK1,KEYS1,GENAM2,LBANK2,KEYS2,IRC)
IF(IRC.EQ.0) THEN
IF(IDEBFA.GT.-3)
+ PRINT *,'FMCOPY. Error - output and input are identical'
IRC = 1
RETURN
ELSE
IRC = 0
ENDIF
*
IF(IDEBFA.GE.0) THEN
CALL FMSHOW(GENAM1,LBANK1,KEYS1,'A',IRET)
CALL FMSHOW(GENAM2,LBANK2,KEYS2,'A',IRET)
ENDIF
FATMBC = FATMBC + Q(LBANK1+KOFUFA+MFSZFA)
*
* Queue to CHEOPS?
*
IF(IOPTK.NE.0) THEN
*
* File size and DCB must be specified
*
CALL UHTOC(IQ(LBANK1+KOFUFA+MRFMFA),4,RECFM1,4)
CALL UHTOC(IQ(LBANK2+KOFUFA+MRFMFA),4,RECFM2,4)
IF(IQ(LBANK1+KOFUFA+MFSZFA).LE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the input file size',
+ ' must be set to perform a copy via CHEOPS'
IRC = -1
ENDIF
IF(IQ(LBANK1+KOFUFA+MRLNFA).LE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the input record length',
+ ' must be set to perform a copy via CHEOPS'
IRC = -1
ENDIF
IF(IQ(LBANK1+KOFUFA+MBLNFA).LE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the input block length',
+ ' must be set to perform a copy via CHEOPS'
IRC = -1
ENDIF
IF(RECFM1(1:1).EQ.' ') THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the input record format',
+ ' must be set to perform a copy via CHEOPS'
IRC = -1
ENDIF
IF(IQ(LBANK2+KOFUFA+MFSZFA).LE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the output file size',
+ ' must be set to perform a copy via CHEOPS'
IRC = -2
ENDIF
IF(IQ(LBANK2+KOFUFA+MRLNFA).LE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the output record length',
+ ' must be set to perform a copy via CHEOPS'
IRC = -2
ENDIF
IF(IQ(LBANK2+KOFUFA+MBLNFA).LE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the output block length',
+ ' must be set to perform a copy via CHEOPS'
IRC = -2
ENDIF
IF(RECFM2(1:1).EQ.' ') THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. the output record format',
+ ' must be set to perform a copy via CHEOPS'
IRC = -2
ENDIF
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. please correct the above',
+ ' problems, e.g. using the shell MODIFY command'
RETURN
ENDIF
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. your request will be ',
+ 'queued to CHEOPS'
CALL FMCOPQ(GENAM1,LBANK1,KEYS1,GENAM2,LBANK2,KEYS2,
+ CHOPT,IRC)
RETURN
ENDIF
*
* Get host information
*
CALL UHTOC(IQ(LBANK1+KOFUFA+MHSNFA),4,HOST1,8)
CALL UHTOC(IQ(LBANK2+KOFUFA+MHSNFA),4,HOST2,8)
LHOST1 = LENOCC(HOST1)
LHOST2 = LENOCC(HOST2)
CALL CLTOU(HOST1(1:LHOST1))
CALL CLTOU(HOST2(1:LHOST2))
*
* Get input and output DSNs
*
CALL FMGDSN(LBANK1,DSN1,LDSN1,IRC)
CALL FMGDSN(LBANK2,DSN2,LDSN2,IRC)
*
* Do we need to perform a remote copy?
*
IF(KEYS1(MKMTFA).EQ.1.AND.KEYS2(MKMTFA).EQ.1) THEN
IF(FMNODE(HOST1(1:LHOST1))+FMNODE(HOST2(1:LHOST2)).NE.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. a remote copy is required'
CALL FMRCOP(GENAM1,LBANK1,KEYS1,GENAM2,LBANK2,KEYS2,CHOPT,
+ IRC)
IF(IRC.NE.0) GOTO 40
GOTO 30
#if defined(CERNLIB_UNIX)||defined(CERNLIB_VAXVMS)
ELSEIF(IOPTF.EQ.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. a local disk copy is '
+ //'required'
CALL FMLCOP(DSN1(1:LDSN1),DSN2(1:LDSN2),' ',IRC)
IF(IRC.NE.0) GOTO 40
GOTO 30
#endif
ENDIF
ENDIF
*
* Determine whether IOPTF (FMFZCP) should be turned on
* N.B. This will not work when FPACK files are supported!
*
CALL UHTOC(IQ(LBANK1+KOFUFA+MFLFFA),4,FFORM1,4)
CALL UHTOC(IQ(LBANK2+KOFUFA+MFLFFA),4,FFORM2,4)
IF((FFORM1.NE.FFORM2).AND.(FFORM1(1:1).EQ.'F')
+ .AND.(FFORM2(1:1).EQ.'F')) THEN
IOPTF = 1
ENDIF
*
* Copy using STAGE CHANGE (stagewrt, WRTAPE)
*
IF((IOPTC.NE.0).AND.
+ (KEYS1(MKMTFA).GT.1).AND.(KEYS2(MKMTFA).GT.1)) THEN
#if defined(CERNLIB_IBMVM)
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. copy will be performed using '
+ //'STAGE CHANGE'
#endif
#if defined(CERNLIB_CRAY)
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. copy will be performed using '
+ //'stagewrt'
#endif
#if defined(CERNLIB_VAXVMS)
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. copy will be performed using '
+ //'WRTAPE'
#endif
*
* Get DCB information
*
CALL UHTOC(IQ(LBANK1+KOFUFA+MRFMFA),4,RECFM1,4)
LRECL1 = IQ(LBANK1+KOFUFA+MRLNFA)*4
LBLCK1 = IQ(LBANK1+KOFUFA+MBLNFA)*4
WRITE(DCB1,9001) RECFM1,LRECL1,LBLCK1
CALL UHTOC(IQ(LBANK2+KOFUFA+MRFMFA),4,RECFM2,4)
LRECL2 = IQ(LBANK2+KOFUFA+MRLNFA)*4
LBLCK2 = IQ(LBANK2+KOFUFA+MBLNFA)*4
WRITE(DCB2,9001) RECFM2,LRECL2,LBLCK2
9001 FORMAT(' RECFM ',A4,' LRECL ',I5,' BLOCK ',I5)
CALL UHTOC(IQ(LBANK1+KOFUFA+MVSNFA),4,VSN1,6)
LVSN1 = LENOCC(VSN1)
CALL CLTOU(VSN1)
CALL UHTOC(IQ(LBANK1+KOFUFA+MVIDFA),4,VID1,6)
LVID1 = LENOCC(VID1)
CALL CLTOU(VID1)
WRITE(FSEQ1,9002) IQ(LBANK1+KOFUFA+MFSQFA)
9002 FORMAT(I6)
JFSEQ1 = INDEXB(FSEQ1,' ') + 1
CDEN1 = CHMDEN(IQ(LBANK1+KOFUFA+MMTPFA))
*
* Generate eXtended VID - with VID prefix
*
JP = IQ(LBANK1+KOFUFA+MVIPFA)
IF(JP.NE.0) THEN
LVIP1 = LENOCC(PREVID(JP))
VIP1 = PREVID(JP)(1:LVIP1)
XVID1 = PREVID(JP)(1:LENOCC(PREVID(JP))) // '.' // VID1(1:
+ LVID1)
LXVID1 = LENOCC(XVID1)
ELSE
XVID1 = VID1
LXVID1 = LVID1
LVIP1 = 0
ENDIF
#if defined(CERNLIB_PREFIX)
VID1 = XVID1
LVID1 = LXVID1
#endif
*
* Set IQUEST(11) to media type in case volume unknown or
* TMS option not installed.
*
IQUEST(11) = IQ(LBANK1+KOFUFA+MMTPFA)
CALL FMQTMS(VID1(1:LVID1),LIB1,MODEL,DENS,MNTTYP,LAB1,IC)
*
* Believe density from TMS if tape is known
*
IF(IC.NE.0) CDEN1 = DENS
CALL CLTOU(LAB1)
LLAB1 = LENOCC(LAB1)
CALL UHTOC(IQ(LBANK2+KOFUFA+MVSNFA),4,VSN2,6)
LVSN2 = LENOCC(VSN2)
CALL CLTOU(VSN2)
CALL UHTOC(IQ(LBANK2+KOFUFA+MVIDFA),4,VID2,6)
LVID2 = LENOCC(VID2)
CALL CLTOU(VID2)
WRITE(FSEQ2,9002) IQ(LBANK2+KOFUFA+MFSQFA)
JFSEQ2 = INDEXB(FSEQ2,' ') + 1
CDEN2 = CHMDEN(IQ(LBANK2+KOFUFA+MMTPFA))
*
* Generate eXtended VID - with VID prefix
*
JP = IQ(LBANK2+KOFUFA+MVIPFA)
IF(JP.NE.0) THEN
LVIP2 = LENOCC(PREVID(JP))
VIP2 = PREVID(JP)(1:LVIP2)
XVID2 = PREVID(JP)(1:LENOCC(PREVID(JP))) // '.' // VID2(1:
+ LVID2)
LXVID2 = LENOCC(XVID2)
ELSE
XVID2 = VID2
LXVID2 = LVID2
LVIP2 = 0
ENDIF
#if defined(CERNLIB_PREFIX)
VID2 = XVID2
LVID2 = LXVID2
#endif
*
* Set IQUEST(11) to media type in case volume unknown or
* TMS option not installed.
*
IQUEST(11) = IQ(LBANK2+KOFUFA+MMTPFA)
CALL FMQTMS(VID2(1:LVID2),LIB2,MODEL,DENS,MNTTYP,LAB2,IC)
*
* Believe density from TMS if tape is known
*
IF(IC.NE.0) CDEN2 = DENS
CALL CLTOU(LAB2)
LLAB2 = LENOCC(LAB2)
*
* Ensure that input file is STAGEd
*
IF(IOPTA.EQ.0) THEN
CHOPE = 'RU'
#if defined(CERNLIB_IBMVM)
LURZFA = IQ(LTOPFA+KOFUFA+MLUNFA)
WRITE(DDNAM1,9004) LURZFA
IF(DDNAM1(3:3).EQ.' ') DDNAM1(3:3) = '0'
CALL FMOPEN(GENAM1,DDNAM1,LBANK1,CHOPE,IRC)
#endif
#if defined(CERNLIB_CRAY)||defined(CERNLIB_VAXVMS)
WRITE(DDNAM1,'(I2.2)') LUFZFA
CALL FMOPEN(GENAM1,DDNAM1,LBANK1,CHOPE,IRC)
#endif
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. Return code ',IRC,' '
+ //'from FMOPEN for GENAM1'
GOTO 40
ENDIF
ENDIF
*
* Build STAGE Change command
*
#if defined(CERNLIB_PREFIX)
IF(LVIP1.NE.0) THEN
VID1 = VID1(1:LVID1) // '.' // VIP1(1:LVIP1)
LVID1 = LVID1 + LVIP1 + 1
ENDIF
IF(LVIP2.NE.0) THEN
VID2 = VID2(1:LVID2) // '.' // VIP2(1:LVIP2)
LVID2 = LVID2 + LVIP2 + 1
ENDIF
#endif
#if defined(CERNLIB_CRAY)
*
* Set IQUEST(11) to media type in case volume unknown or
* TMS option not installed.
*
IQUEST(11) = IQ(LBANK2+KOFUFA+MMTPFA)
CALL FMQTMS(VID2(1:LVID2),LIB,MODEL,DENS,MNTTYP,LABTYP,IC)
IF(IDEBFA.GE.3) THEN
PRINT *,'FMCOPY. return from FMQTMS with ',
+ VID2,'/',LIB,'/',MODEL,'/',DENS,'/',MNTTYP,'/',
+ LABTYP,'/',IC
ENDIF
*
* Believe density from TMS if tape is known
*
IF(IC.NE.0) CDEN2 = DENS
CALL CUTOL(LABTYP)
LLAB = LENOCC(LABTYP)
DDNAM2 = 'fort. '
IF(LUFZFA.LT.10) THEN
WRITE(DDNAM2(6:6),'(I1)') LUFZFA
ELSE
WRITE(DDNAM2(6:7),'(I2)') LUFZFA
ENDIF
WRITE(FSEQ2,9002) IQ(LBANK2+KOFUFA+MFSQFA)
* "stagein fort.lun -v vsn -V vid -l sl|nl|al|blp
* -g TAPE|CART|SMCF -d 6250|1600"
COMAND = 'stagewrt '//DDNAM2 // ' -v '//VSN2(1:LVSN2)// ' -V '
+ //VID2(1:LVID2)//' -l '//LABTYP//' -g '//MODEL // ' -q ' //
+ FSEQ2 // ' -K -S sbin'
LENCOM = LENOCC(COMAND)
*
* Add DSN if IOPTN not specified
*
IF(IOPTN.EQ.0) THEN
COMAND = COMAND(1:LENCOM) // ' -f '//DSN2(1:LDSN2)
LENCOM = LENOCC(COMAND)
ENDIF
*
* Add DCB information
*
WRITE(DCB2,9003) RECFM2(1:1),LRECL2,LBLCK2
9003 FORMAT(' -F ',A1,' -L ',I5,' -b ',I5)
COMAND = COMAND(1:LENOCC(COMAND)) // DCB2
LENCOM = LENOCC(COMAND)
IF(IDEBFA.GE.0) PRINT *,COMAND(1:LENCOM)
IC = SYSTEMF(COMAND(1:LENCOM))
#endif
#if defined(CERNLIB_IBMVM)
CALL FMGDSN(LBANK2,DSN2,LDSN2,IRC)
COMAND = ' '
COMAND = 'EXEC STAGE CHANGE '
+ // VSN1(1:LVSN1) // '.'
+ // FSEQ1(JFSEQ1:LEN(FSEQ1))
+ // '.' // LAB1(1:LLAB1) // '.' // VID1(1:LVID1) // ' '
+ // VSN2(1:LVSN2) // '.'
+ // FSEQ2(JFSEQ2:LEN(FSEQ2))
+ // '.' // LAB2(1:LLAB2) // '.' // VID2(1:LVID2)
+ // ' (STAGEOUT DSN ' // DSN2(1:LDSN2)
IF(IOPTW.NE.0) THEN
COMAND = COMAND(1:LENOCC(COMAND)) // ' WAIT'
ENDIF
#endif
#if (defined(CERNLIB_IBMVM))&&(!defined(CERNLIB_TMS))
COMAND = COMAND(1:LENOCC(COMAND)) // ' DEVTYPE '//MODEL
#endif
#if (defined(CERNLIB_IBMVM))&&(!defined(CERNLIB_CERN))&&(defined(CERNLIB_TMS))
COMAND = COMAND(1:LENOCC(COMAND)) // ' DEVTYPE '//MODEL
#endif
#if defined(CERNLIB_IBMVM)
LENCOM = LENOCC(COMAND)
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. running ',COMAND(1:LENCOM)
CALL VMCMS(COMAND(1:LENCOM),IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0)
+ PRINT *,'FMCOPY. Return code ',IRC,' from STAGE'
RETURN
ENDIF
#endif
#if defined(CERNLIB_VAXVMS)
VAXLAB = 'EBCDIC'
IF(LAB2(1:LLAB2).EQ.'AL') THEN
VAXLAB = 'ASCII'
ELSEIF(LAB2(1:LLAB2).EQ.'NL') THEN
VAXLAB = 'NONE'
ENDIF
COMAND = ' '
WRITE(CHRECL,'(I6.6)') LRECL2
WRITE(CHBLK, '(I6.6)') LBLCK2
COMAND = '$WRTAPE '//VSN2(1:LVSN2)//' '//VID2(1:LVID2)//
+ ' /NAME='//DSN2(1:LDSN2)//'/NUMBER='//
+ FSEQ2(JFSEQ2:LEN(FSEQ2))//'/INFILE='//DDNAM1
+ //'/LABEL='//VAXLAB
+ //'/GENERIC='//MODEL
IF(LRECL2.GT.0) COMAND = COMAND(1:LENOCC(COMAND)) //
+ '/RECORDSIZE='//CHRECL
IF(LBLCK2.GT.0) COMAND = COMAND(1:LENOCC(COMAND)) //
+ '/BLOCKSIZE='//CHBLK
IF(INDEX(RECFM2,'F').NE.0) THEN
COMAND = COMAND(1:LENOCC(COMAND)) // '/FIXED'
ELSEIF(INDEX(RECFM2,'V').NE.0) THEN
COMAND = COMAND(1:LENOCC(COMAND)) // '/VARIABLE'
ENDIF
*
LENCOM = LENOCC(COMAND)
IF(IDEBFA.GE.0) PRINT *,COMAND(1:LENCOM)
ISTAT = LIB$SPAWN(COMAND(1:LENCOM))
#include "fatmen/fatvaxrc.inc"
#endif
ELSEIF(IOPTF.NE.0) THEN
*
* Perform copy using FZIN/FZOUT
*
CALL FMGLUN(LUNI,IRC)
IF(IRC.NE.0) THEN
PRINT *,'FMCOPY. unable to allocate input unit for copy'
GOTO 40
ENDIF
CALL FMGLUN(LUNO,IRC)
IF(IRC.NE.0) THEN
PRINT *,'FMCOPY. unable to allocate input unit for copy'
GOTO 40
ENDIF
CALL FMDDNM(LUNI,DDNAM1,IRC)
CALL FMDDNM(LUNO,DDNAM2,IRC)
CHOPI = 'FR'
IF(KEYS1(MKMTFA).GT.1) THEN
IF(KEYS2(MKMTFA).GT.1) THEN
CHOPI = 'FRT'
ELSE
CHOPI = 'FRTE'
ENDIF
ELSE
CHOPI = 'RU'
ENDIF
CALL FMOPEN(GENAM1,DDNAM1,LBANK1,CHOPI,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0)
+ PRINT *,'FMCOPY. Return code ',IRC,' from FMOPEN for GENAM1'
GOTO 40
ENDIF
CHOPO = 'FW'
IF(KEYS2(MKMTFA).GT.1) CHOPO = 'TFWE'
CALL FMOPEN(GENAM2,DDNAM2,LBANK2,CHOPO,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0)
+ PRINT *,'FMCOPY. Return code ',IRC,' from FMOPEN for GENAM2'
GOTO 40
ENDIF
CHOPTF = ' '
IF(IOPTR.NE.0) CHOPTF = 'R'
CALL FMFZCP(LUNI,LUNO,CHOPTF,IRC)
CALL FMFLUN(LUNI,IC)
CALL FMFLUN(LUNO,IC)
CHOPI = 'E'
CALL FMCLOS(GENAM1,DDNAM1,LBANK1,CHOPI,IC)
CHOPO = 'EFP'
CALL FMCLOS(GENAM2,DDNAM2,LBANK2,CHOPO,IC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. Return code ',IRC,' from '
+ //'FMFZCP'
GOTO 40
ENDIF
ELSE
#if !defined(CERNLIB_IBMVM)
*
* Perform physical copy - switch IOPTS & IOPTZ on
*
IOPTS = 1
IOPTZ = 1
CALL FMGLUN(LUNI,IRC)
IF(IRC.NE.0) THEN
PRINT *,'FMCOPY. unable to allocate input unit for copy'
GOTO 40
ENDIF
CALL FMGLUN(LUNO,IRC)
IF(IRC.NE.0) THEN
PRINT *,'FMCOPY. unable to allocate input unit for copy'
GOTO 40
ENDIF
CALL FMDDNM(LUNI,DDNAM1,IRC)
CALL FMDDNM(LUNO,DDNAM2,IRC)
*
* Set FMOPEN options
*
CHOPI = 'RU'
IF(IOPTS.EQ.0.AND.KEYS1(MKMTFA).GT.1) THEN
IF(KEYS2(MKMTFA).GT.1) THEN
CHOPI = 'RTU'
ELSE
CHOPI = 'RTEU'
ENDIF
ELSE
CHOPI = 'RU'
ENDIF
IF(IDEBFA.GE.3) PRINT *,'FMCOPY. call FMOPEN for input'
CALL FMOPEN(GENAM1,DDNAM1,LBANK1,CHOPI,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0)
+ PRINT *,'FMCOPY. Return code ',IRC,' from FMOPEN for GENAM1'
GOTO 40
ENDIF
CHOPO = 'WU'
IF(IOPTZ.EQ.0.AND.KEYS2(MKMTFA).GT.1) CHOPO = 'WTEU'
IF(IDEBFA.GE.3) PRINT *,'FMCOPY. call FMOPEN for output'
CALL FMOPEN(GENAM2,DDNAM2,LBANK2,CHOPO,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0)
+ PRINT *,'FMCOPY. Return code ',IRC,' from FMOPEN for GENAM2'
GOTO 40
ENDIF
#endif
#if (!defined(CERNLIB_IBMVM))&&(defined(CERNLIB_CRAY))
*
* Find the real file name(s)
*
CALL FMASSN(DDNAM1,CHFIN,'G',IRC)
CALL FMASSN(DDNAM2,CHFOUT,'G',IRC)
LCHFIN = LENOCC(CHFIN)
LCHFOU = LENOCC(CHFOUT)
*
* Now do the copy
*
CALL FMLCOP(CHFIN(1:LCHFIN),CHFOUT(1:LCHFOU),'C',IRC)
#endif
#if (!defined(CERNLIB_IBMVM))&&(!defined(CERNLIB_CRAY))
*
* Now do the copy
*
CALL FMLCOP(DDNAM1,DDNAM2,' ',IRC)
#endif
#if !defined(CERNLIB_IBMVM)
*
* Free logical units
*
CALL FMFLUN(LUNI,IC)
CALL FMFLUN(LUNO,IC)
CHOPI = 'N'
CALL FMCLOS(GENAM1,DDNAM1,LBANK1,CHOPI,IC)
CHOPO = 'N'
IF(KEYS2(MKMTFA).GT.1) CHOPO = 'NP'
CALL FMCLOS(GENAM2,DDNAM2,LBANK2,CHOPO,IC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. Return code ',IRC,' from '
+ //'FMLCOP'
GOTO 40
ENDIF
#endif
#if defined(CERNLIB_IBMVM)
CHOPE = 'RU'
IF((KEYS1(MKMTFA).GT.1).AND.(IOPTS.EQ.0)) THEN
IF(KEYS2(MKMTFA).GT.1) THEN
CHOPE = 'RTU'
ELSE
CHOPE = 'RTUE'
ENDIF
ELSE
CHOPE = 'RU'
ENDIF
LURZFA = IQ(LTOPFA+KOFUFA+MLUNFA)
WRITE(DDNAM1,9004) LURZFA
9004 FORMAT('VM',I2,'F001')
IF(DDNAM1(3:3).EQ.' ') DDNAM1(3:3) = '0'
CALL FMOPEN(GENAM1,DDNAM1,LBANK1,CHOPE,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. Return code ',IRC,' from '
+ //'FMOPEN for GENAM1'
GOTO 40
ENDIF
CHOPE = 'UW'
IF(KEYS2(MKMTFA).GT.1) CHOPE = 'TUWE'
IF(IOPTZ.NE.0) CHOPE = 'UW'
WRITE(DDNAM2,9004) LUFZFA
IF(DDNAM2(3:3).EQ.' ') DDNAM2(3:3) = '0'
CALL FMOPEN(GENAM2,DDNAM2,LBANK2,CHOPE,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. Return code ',IRC,' from '
+ //'FMOPEN for GENAM2'
GOTO 40
ENDIF
*
* Get DCB information
*
CALL UHTOC(IQ(LBANK1+KOFUFA+MRFMFA),4,RECFM1,4)
LRECL1 = IQ(LBANK1+KOFUFA+MRLNFA)*4
LBLCK1 = IQ(LBANK1+KOFUFA+MBLNFA)*4
CALL UHTOC(IQ(LBANK2+KOFUFA+MRFMFA),4,RECFM2,4)
LRECL2 = IQ(LBANK2+KOFUFA+MRLNFA)*4
LBLCK2 = IQ(LBANK2+KOFUFA+MBLNFA)*4
CALL VMINIT
FN1 = ' '
LREC1 = LRECL1
LBLK1 = LBLCK1
IF(IDEBFA.GE.2) PRINT *,
+ 'FMCOPY. call VMOPEN for input dataset on unit ',LURZFA,
+ ' with DCB ',RECFM1,LREC1,LBLK1
CALL VMOPEN(LURZFA,FN1,'R',RECFM1,LREC1,LBLK1,IRC,INFO)
IF(IDEBFA.GE.2) PRINT *,
+ 'FMCOPY. return from VMOPEN ',
+ ' with DCB ',RECFM1,LREC1,LBLK1
IF(IABS(IRC).GT.1) THEN
PRINT *,'FMCOPY. return code ',IRC,
+ ' from VMOPEN for input file, INFO = ',INFO
CALL VMEND
CALL FMCLOS(GENAM1,DDNAM1,LBANK1,'C',IRET)
GOTO 40
ENDIF
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. Opened input unit'
FN2 = ' '
LREC2 = LRECL2
LBLK2 = LBLCK2
IF(IDEBFA.GE.2) PRINT *,
+ 'FMCOPY. call VMOPEN for output dataset on unit ',LUFZFA,
+ ' with DCB ',RECFM2,LREC2,LBLK2
CALL VMOPEN(LUFZFA,FN2,'W',RECFM2,LREC2,LBLK2,IRC,INFO)
IF(IDEBFA.GE.2) PRINT *,
+ 'FMCOPY. return from VMOPEN ',
+ ' with DCB ',RECFM2,LREC2,LBLK2
IF(IABS(IRC).GT.1) THEN
PRINT *,'FMCOPY. return code ',IRC,
+ ' from VMOPEN for output file, INFO = ',INFO
CALL VMEND
CALL FMCLOS(GENAM1,DDNAM1,LBANK1,'C',IRET)
CALL FMCLOS(GENAM2,DDNAM2,LBANK2,'C',IRET)
GOTO 40
ENDIF
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. Opened output unit'
NRECS = 0
NLONG = 0
NSHORT = 32768
NREAD = LREC1
IF(LREC1.EQ.0) NREAD = LBLK1
IF(NREAD.EQ.0) THEN
IF(IDEBFA.GT.-3) PRINT *,
+ 'FMCOPY. record length and blocksize of input dataset are ',
+ 'both zero - cannot perform copy'
CALL VMEND
IRC = 1
GOTO 40
ENDIF
10 CONTINUE
LDAT = 32768
CALL VMREAD(LURZFA,BUFFER,NREAD,LDAT,IRC,INFO)
IF(IABS(IRC).EQ.1) GOTO 20
IF(IABS(IRC).GT.1) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. return code ',IRC,
+ ' from VMREAD'
IF(IABS(IRC).GT.4) THEN
CALL VMEND
GOTO 40
ENDIF
ENDIF
IF(LDAT.GT.NLONG) NLONG = LDAT
IF(LDAT.LT.NSHORT) NSHORT = LDAT
CALL VMRITE(LUFZFA,BUFFER,LDAT,IRC,INFO)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. return code ',IRC,
+ ' from VMRITE'
CALL VMEND
GOTO 40
ENDIF
NRECS = NRECS + 1
GOTO 10
20 CONTINUE
IF(IDEBFA.GE.0) PRINT *,'FMCOPY. ',NRECS,
+ ' records written, shortest/longest = ',NSHORT,NLONG
*
* Options for FMCLOS
*
IF(IOPTS.NE.0) THEN
CHOPE = 'D'
ELSE
CHOPE = ' '
ENDIF
CALL FMCLOS(GENAM1,DDNAM1,LBANK1,CHOPE,IRC)
CHOPE = 'DU'
IF(IOPTZ.NE.0) THEN
IF(IOPTW.EQ.0) THEN
CHOPE = 'DUP'
ELSE
CHOPE = 'DUPW'
ENDIF
ENDIF
CALL FMCLOS(GENAM2,DDNAM2,LBANK2,CHOPE,IRC)
IF(IRC.NE.0) THEN
IF(IDEBFA.GE.-3) PRINT *,'FMCOPY. return code ',IRC,
+ ' from FMCLOS. Entry will not be added to catalogue'
GOTO 40
ENDIF
CALL VMEND
#endif
ENDIF
30 CALL FMPUT(GENAM2,LBANK2,IRC)
40 RETURN
END