* * $Id: fmfzo.F,v 1.5 1996/06/26 12:34:40 jamie Exp $ * * $Log: fmfzo.F,v $ * Revision 1.5 1996/06/26 12:34:40 jamie * save lenf * * Revision 1.4 1996/04/12 07:55:40 cernlib * new handling of title string * * Revision 1.3 1996/03/29 11:29:53 jamie * qftitlch * * Revision 1.2 1996/03/28 10:28:53 jamie * update idatqq/itimqq and remove check on old version in fminit * * Revision 1.1.1.1 1996/03/07 15:18:04 mclareni * Fatmen * * #include "fatmen/pilot.h" SUBROUTINE FMFZO(COMM,GNAME,LENTRY,KEYS,IRC) * * Send update via FZOUT to local database server * Input is unit for FZ file, Command, Generic name and bank address * Command can be 'PUT, DEL, MDIR or DDIR' * LENTRY must be non zero for all operations except MDIR/DDIR * * User header of FZ file: * IUHEAD(1) = command * IUHEAD(2-70) = generic name * IUHEAD(71-80) = keys vector * * Monitoring information: * IUHEAD(81) = IHOWFA * IUHEAD(82) = ITIMFA * * IUHEAD(91-155) = CHFNFA * #include "fatmen/faust.inc" #include "fatmen/fausto.inc" #include "fatmen/fatmon.inc" #include "fatmen/fatbank.inc" #include "fatmen/fatpara.inc" #include "fatmen/fatsys.inc" #include "fatmen/fatupd.inc" DIMENSION LENTRY(1) CHARACTER*80 CHFORM #if defined(CERNLIB_IBMMVS) DIMENSION DISP(3) DIMENSION SPACE(4) #include "fatmen/fattyp.inc" #endif CHARACTER*(*) COMM, GNAME CHARACTER*20 FNAME CHARACTER*64 FUNAM CHARACTER*80 FILEDEF CHARACTER*132 FILEN,FILEM CHARACTER*1 OPT CHARACTER*2 FMODE CHARACTER*8 CHHOST,CHTYPE,CHSYS #if defined(CERNLIB_UNIX) INTEGER SYSTEMF #endif #if defined(CERNLIB_VAXVMS) CHARACTER*12 CHUSER INTEGER FMVUSR #endif #if !defined(CERNLIB_VAXVMS) CHARACTER*8 CHUSER #endif PARAMETER (NW=80) PARAMETER (MHEAD=200) INTEGER FMHOST,FMUSER PARAMETER (LKEYFA=10) DIMENSION KEYS(LKEYFA) DIMENSION IUHEAD(MHEAD),HEAD(MHEAD),IOCH(NW) DIMENSION IQSAVE(100) LOGICAL IEXIST,IOPEN EQUIVALENCE (IUHEAD(1),HEAD(1)) SAVE NENTRY,NSEND,NBATCH,CHHOST,CHTYPE,CHSYS,CHUSER SAVE FILEN,LENF DATA IEV/1/ DATA NSEND/0/ DATA NBATCH/0/ DATA NENTRY/0/ IF(NENTRY.EQ.0) THEN NENTRY = 1 IC = FMHOST(CHHOST,CHTYPE,CHSYS) #if defined(CERNLIB_VAXVMS) IC = FMVUSR(CHUSER) #endif #if !defined(CERNLIB_VAXVMS) IC = FMUSER(CHUSER) #endif CALL CLTOU(CHHOST) CALL CLTOU(CHUSER) ENDIF IF(LUFZFA.EQ.0) + CALL ZFATAM('FATMEN database is R/O - check call to FMINIT') NCH = LENOCC(GNAME) * * Replace operation from FMOPEN or FMCLOS? * IOPTC = 0 IOPTO = 0 IF(COMM(1:3).EQ.'MOD') THEN IF(COMM(4:4).EQ.'O') THEN IOPTO = 1 CALL FMACL(CHUSER,CHHOST,GNAME(1:NCH),COMM,'U',IUP) IF(IUP.NE.0) THEN IF(IDEBFA.GE.2) WRITE(LPRTFA,9001) GNAME(1:NCH) 9001 FORMAT(' FMFZO. updates turned off for path ',A) GOTO 999 ENDIF ENDIF IF(COMM(4:4).EQ.'C') IOPTC = 1 COMM(4:4) = ' ' ENDIF IF(IDEBFA.GE.1) WRITE(LPRTFA,9002) COMM,GNAME(1:NCH) 9002 FORMAT(' FMFZO. enter for ',A,1X,A) IF(IDEBFA.GE.3.AND.COMM.NE.'LOG'.AND. + INDEX(COMM,'DIR').EQ.0) THEN WRITE(LPRTFA,9003) 9003 FORMAT(' FMFZO. output bank...') CALL FMSHOW(GNAME,LENTRY,KEYS,'A',IRC) ENDIF * * Security * IF(IOPTC+IOPTO.EQ.0.AND.COMM.NE.'LOG') THEN CALL FMACL(CHUSER,CHHOST,GNAME(1:NCH),COMM,'A',IRC) IF(IRC.NE.0) THEN NVIOL = NVIOL + 1 IF(NVIOL.GT.MAXVIO) CALL ZFATAM + ('Maximum number of security violations exceeded') WRITE(LPRTFA,9004) COMM,GNAME(1:NCH) 9004 FORMAT(' FMFZO. you are not authorised to issue ',A,1X,A) GOTO 999 ENDIF ENDIF * * Update protection * NUPDT = NUPDT + 1 IF(NUPDT.EQ.MAXUPD) THEN IF(IDEBFA.GE.0) WRITE(LPRTFA,9005) 9005 FORMAT(' FMFZO. !!! warning - program will ', + 'crash if another FATMEN update is made !!!') ENDIF IF(NUPDT.GT.MAXUPD) CALL ZFATAM + ('Maximum number of updates exceeded') * * Header or header + bank? * OPT = 'S' IF(COMM.EQ.'LOG'.OR.INDEX(COMM,'DIR').NE.0) OPT = 'Z' * * Check generic name and build id of local service machine * IF((NCH.LT.3).OR.(GNAME(1:2).NE.'//').OR. + (GNAME(NCH:NCH).EQ.'/')) THEN WRITE (6, 9007) GNAME(1:NCH) IRC = 1 GOTO 999 ENDIF IFIRST = INDEX(GNAME(3:NCH),'/') IF(IFIRST.EQ.0) THEN WRITE(6,9007)GNAME(1:NCH) IRC = 1 GOTO 999 ENDIF IF(COMM.NE.'LOG') THEN ISEC = INDEX(GNAME(3+IFIRST:NCH),'/') IF (ISEC.EQ.0) THEN WRITE (6,9007) GNAME(1:NCH) IRC = 1 GOTO 999 ENDIF SERNAM = 'FM'//GNAME(3+IFIRST:1+IFIRST+ISEC) ELSE SERNAM = 'FM'//GNAME(3+IFIRST:) ENDIF LSN = LENOCC(SERNAM) * * Fill header vector * CALL UCTOH(COMM,IUHEAD,4,4) * * Logging * IF(COMM.EQ.'LOG') THEN * * Set I/O characteristic of header and fill * NHEAD = KLHOLL + KLREAL + KLDATE + KLCMOD + + KLFILE + KLTMS + KLCFAT WRITE(CHFORM,8001) KLHOLL,KLREAL,KLINT 8001 FORMAT(I2,'H',1X,I2,'F',1X,I3,'I') CALL MZIOCH(IOCH,NW,CHFORM) CALL VBLANK(IUHEAD(2),KLHOLL-1) CALL VZERO(IUHEAD(KOREAL),KLREAL+KLINT) * * FATMEN system and group * CALL UCTOH(GNAME(3:),IUHEAD(KFMSYS),4,IFIRST-1) CALL UCTOH(GNAME(3+IFIRST:),IUHEAD(KFMGRP),4,NCH-IFIRST-2) * * PAM file title * #include "fatmen/qftitlch.inc" CALL UCTOH( + FatmenTitleFortranString + ,IUHEAD(KFMTIT),4,62) * * Username, node, type, OS * CALL UCTOH(CHUSER,IUHEAD(KFMUSR),4,LENOCC(CHUSER)) CALL UCTOH(CHHOST,IUHEAD(KFMHST),4,LENOCC(CHHOST)) CALL UCTOH(CHTYPE,IUHEAD(KFMTYP),4,LENOCC(CHTYPE)) CALL UCTOH(CHSYS ,IUHEAD(KFMOS ),4,LENOCC(CHSYS )) * * MB read/written * HEAD(KFMMBR) = FATMBR HEAD(KFMMBW) = FATMBW HEAD(KFZMBR) = FATMZR HEAD(KFZMBW) = FATMZW * * MB copied * HEAD(KFMMBC) = FATMBC HEAD(KFMMBN) = FATMBN HEAD(KFMMBQ) = FATMBQ * * Time stamps * IDATQQ = 960328 ITIMQQ = 1100 CALL FMPKTM(IDATQQ,ITIMQQ,IUHEAD(KFMIDQ),IRC) CALL DATIME(IDEND,ITEND) CALL FMPKTM(NFSTAD,NFSTAT,IUHEAD(KFMIDS),IRC) CALL FMPKTM(IDEND ,ITEND ,IUHEAD(KFMIDE),IRC) * * All the other stuff * IUHEAD(KFMADD) = NFADDD IUHEAD(KFMADL) = NFADDL IUHEAD(KFMADT) = NFADDT IUHEAD(KFMMDR) = NFMDIR IUHEAD(KFMRDR) = NFRDIR IUHEAD(KFMRLN) = NFRLNK IUHEAD(KFMRTR) = NFRTRE IUHEAD(KFMRMF) = NFRMFL IUHEAD(KFMCPF) = NFCPFL IUHEAD(KFMMVF) = NFMVFL IUHEAD(KFMMOD) = NFMODI IUHEAD(KFMTCH) = NFTOUC IUHEAD(KFMOPN) = NFOPEN IUHEAD(KFMCLS) = NFCLOS IUHEAD(KFMCPY) = NFCOPY IUHEAD(KFMCPQ) = NFCOPQ IUHEAD(KFMCPN) = NFCOPR IUHEAD(KFMSRQ) = NFSREQ IUHEAD(KFMQVL) = NFQVOL IUHEAD(KFMAVL) = NFAVOL IUHEAD(KFMASP) = NFASPC IUHEAD(KFMPOL) = NFPOOL IUHEAD(KFMLCK) = NFLOCK IUHEAD(KFMULK) = NFULOK IUHEAD(KFMDTG) = NFDTAG IUHEAD(KFMGTG) = NFGTAG IUHEAD(KFMSTG) = NFSTAG IUHEAD(KFMBNK) = NFBANK IUHEAD(KFMGET) = NFGET IUHEAD(KFMGTK) = NFGETK IUHEAD(KFMSHW) = NFSHOW IUHEAD(KFMSCN) = NFSCAN IUHEAD(KFMLOP) = NFLOOP IUHEAD(KFMLDR) = NFLDIR IUHEAD(KFMLFL) = NFLFIL IUHEAD(KFMSRT) = NFSORT IUHEAD(KFMRNK) = NFRANK IUHEAD(KFMSLK) = NFSELK IUHEAD(KFMMTC) = NFMTCH IF(IDEBFA.GE.3) CALL FMPLOG(LPRTFA,IUHEAD,NHEAD,IRC) ELSE * * Fill with blanks for safety * CALL VBLANK(IUHEAD(2),69) CALL UCTOH(GNAME,IUHEAD(2),4,NCH) * * Keys * LEND = INDEXB(GNAME,'/') + 1 FNAME = GNAME(LEND:NCH) IUHEAD(71) = KEYS(1) IUHEAD(77) = IQ(LENTRY(1)+MCPLFA+KOFUFA) IUHEAD(78) = IQ(LENTRY(1)+MMTPFA+KOFUFA) IUHEAD(79) = IQ(LENTRY(1)+MLOCFA+KOFUFA) IUHEAD(80) = LKEYFA LENFN = NCH-LEND+1 * * IUHEAD 71-80 contains the keys, which includes the filename * FNAME(LENFN+1:) = ' ' CALL UCTOH(FNAME,IUHEAD(72),4,20) * * Set up descriptor of header vector * IF(IOPTO.EQ.0) THEN CALL MZIOCH(IOCH,NW,'70H 1I 5H 4I') NHEAD = 80 ELSE CALL MZIOCH(IOCH,NW,'70H 1I 5H 4I 1B 9I 64H') * * Monitoring information * NHEAD = 155 IUHEAD(81) = IHOWFA IUHEAD(82) = ITIMFA CALL VZERO(IUHEAD(83),8) CALL VBLANK(IUHEAD(91),64) LNFNFA = LENOCC(CHFNFA) CHFNFA(LNFNFA+1:) = ' ' CALL UCTOH(CHFNFA,IUHEAD(91),4,LNFNFA) IF(IDEBFA.GE.3) WRITE(LPRTFA,9006) IHOWFA,ITIMFA, + CHFNFA(1:LNFNFA) 9006 FORMAT(' FMFZO. IHOWFA: ',Z8,' ITIMFA: ',I6,' CHFNFA: ',A) ENDIF ENDIF 9007 FORMAT(' FMFZO - illegal generic name ',A) #if defined(CERNLIB_CZ) GOTO 20 #endif * * Is the output file already open? * LUNFZ = IABS(LUFZFA) INQUIRE(LUNFZ,OPENED=IOPEN) IF(.NOT.IOPEN) THEN * * Get a unique file name * 10 CONTINUE #if defined(CERNLIB_IBMVM) IF(FATNOD.EQ.' '.AND.LUFZFA.GT.0) THEN * * Use spool * IF(INDEX(CHHOST,'CERNVMB').EQ.0) THEN IF(IDEBFA.GE.2) WRITE(LPRTFA,9008) SERNAM(1:LSN) 9008 FORMAT(' FMFZO. issuing CP SPOOL PUNCH TO ',A) CALL VMCMS('CP SPOOL PUNCH TO '//SERNAM(1:LSN),IRC) ELSE IF(IDEBFA.GE.2) WRITE(LPRTFA,9008) 'RSCS' CALL VMCMS('CP SPOOL PUNCH TO RSCS',IRC) IF(IDEBFA.GE.2) WRITE(LPRTFA,9009) SERNAM(1:LSN) 9009 FORMAT(' FMFZO. issuing CP TAG DEV PUNCH CERNVM ',A) CALL VMCMS('CP TAG DEV PUNCH CERNVM ' //SERNAM(1:LSN), + IRC) ENDIF IF(IRC.NE.0) THEN WRITE(LPRTFA,*) 'FMFZO - Error from VMCMS, RC=',IRC GOTO 999 ENDIF WRITE(FILEDEF,9010) LUFZFA 9010 FORMAT('FILEDEF ',I3,' PUNCH') IF(IDEBFA.GE.2) WRITE(LPRTFA,9011) FILEDEF 9011 FORMAT(' FMFZO. issuing ',A) CALL VMCMS(FILEDEF,IRC) OPEN(LUFZFA,STATUS='NEW') GOTO 20 ENDIF CALL FMFNME(FUNAM) FILEN = FUNAM // ' ' // LOCALQ(1:1) IDOT = INDEX(FILEN,'.') IF(IDOT.NE.0) FILEN(IDOT:IDOT) = ' ' #endif #if !defined(CERNLIB_IBMVM) CALL FMJOUR(FUNAM) FILEN = LOCALQ(1:LENOCC(LOCALQ)) // FUNAM LENF = LENOCC(FILEN) #endif #if defined(CERNLIB_UNIX) CALL CUTOL(FILEN(1:LENF)) #endif * * Does file already exist? * #if !defined(CERNLIB_IBM) INQUIRE(FILE=FILEN(1:LENF),EXIST=IEXIST) #endif #if defined(CERNLIB_IBM) INQUIRE(FILE='/'//FILEN(1:LENF),EXIST=IEXIST) #endif IF(IEXIST) THEN CALL SLEEPF(1) GOTO 10 ENDIF * * Open output file * #if defined(CERNLIB_IBMMVS) * * Create new CARD file * LUNIT = LENOCC(CHMGEN(1)) CALL FILEINF(ISTAT,'DEVICE',CHMGEN(1)(1:LUNIT),'TRK',1, + 'SECOND',1,'DIR',0, 'RECFM','FB','LRECL',80,'BLKSIZE',9040) #endif #if defined(CERNLIB_IBM) OPEN(LUNFZ,ERR=30 ,STATUS='NEW',ACCESS='SEQUENTIAL', FILE='/' + //FILEN(1:LENF), FORM='FORMATTED',ACTION='READWRITE') #endif #if defined(CERNLIB_VAXVMS) IF(STRMLF) THEN * * Required to write over NFS from VMS to Unix systems * OPEN(LUNFZ,STATUS='NEW',FILE=FILEN(1:LENF),ERR=30 , + RECORDTYPE='STREAM_LF', FORM='FORMATTED') ELSE OPEN(LUNFZ,STATUS='NEW',FILE=FILEN(1:LENF),ERR=30 ) ENDIF #endif #if defined(CERNLIB_UNIX) OPEN(LUNFZ,STATUS='NEW',FILE=FILEN(1:LENF),ERR=30 ) #endif ENDIF NSEND = NSEND + 1 20 CONTINUE * * Write update * #if !defined(CERNLIB_CZ) CALL FZFILE(LUNFZ,0,'AO') CALL FZLOGL(LUNFZ,MAX(IDEBFA-2,-3)) IF(IDEBFA.GE.2) WRITE(LPRTFA,9012) COMM,OPT 9012 FORMAT(' FMFZO. call FZOUT for ',A,' opt ',A) CALL FZOUT(LUNFZ,IDIVFA,LENTRY(1),IEV,OPT,IOCH,NHEAD,IUHEAD) CALL FZENDO(LUNFZ,'T') #endif #if defined(CERNLIB_CZ) * * Send command to remote server * CALL CZPUTA('MESS :OU',ISTAT) IF(IDEBFA.GE.2) WRITE(LPRTFA,9012) COMM,OPT CALL FZOUT(998,IDIVFA,LENTRY(1),IEV,OPT,IOCH,NHEAD,IUHEAD) GOTO 999 #endif * * Send file? * IF(IDEBFA.GE.0) WRITE(LPRTFA,9013) COMM,GNAME(1:NCH) 9013 FORMAT(' FMFZO - update queued for processing (',A,1X,A,')') IF(NSEND.EQ.NGROUP.OR.NGROUP.EQ.0) THEN CLOSE(LUFZFA) NSEND = 0 NBATCH = NBATCH + 1 IF(IDEBFA.GE.0.AND.NGROUP.GT.1) WRITE(LPRTFA,9014) NBATCH 9014 FORMAT(' FMFZO. sending batch ',I6,' of updates to server') * * Send/rename/mv/XZPUTA,XZMV,XZLRM * CALL FMSEND(FILEN(1:LENF),IRC) ENDIF GOTO 999 30 CONTINUE WRITE(LPRTFA,9015) FILEN(1:LENF) 9015 FORMAT(' FMFZO - error opening temporary file, name=',A) 999 END