[u/mrichter/AliRoot.git] / MINICERN / packlib / zebra / rz / rzclos.F

*
* $Id$
*
* $Log$
* Revision 1.5  1998/08/06 17:17:06  mclareni
* For multiple files, LUN has to be set in the common RZCLUN before it is used by RZFREE
*
* Revision 1.4  1997/07/04 15:26:01  couet
* - the error message printing previously added was wrong
*
* Revision 1.3  1997/07/03 09:21:15  couet
* - CHPATH is converted is uppercase before being compared to CHNAME
*
* Revision 1.2  1996/04/24 17:26:42  mclareni
* Extend the include file cleanup to dzebra, rz and tq, and also add
* dependencies in some cases.
*
* Revision 1.1.1.1  1996/03/06 10:47:23  mclareni
* Zebra
*
*
#include "zebra/pilot.h"
      SUBROUTINE RZCLOS(CHPATH,CHOPT)
*
************************************************************************
*
*        To close all transactions with file CHPATH
*          Corresponding directories are dropped
*        A FORTRAN or CFCLOS is also issued for all associated files
* Input:
*   CHPATH  Character variable specifying the name of the top directory
*   CHOPT   Character variable specifying the options required
*       'A' Close all files currently open
*
* Called by <USER>
*
*  Author  : J. Shiers
*  Written : 11.11.91
*  Last mod: 11.11.91
*
************************************************************************
      CHARACTER*(*)     CHPATH,CHOPT
      CHARACTER*16      CHNAME,CHPATU
      DIMENSION         IHDIR(4)
#include "zebra/rzcl.inc"
#include "zebra/rzclun.inc"
#include "zebra/zunit.inc"
#include "zebra/q_jbit.inc"
#include "zebra/q_jbyt.inc"

      LP = LENOCC(CHPATH)
      LC = LENOCC(CHOPT)
      IOPTA = 0
      IF(LC.GT.0) IOPTA = INDEX(CHOPT(1:LC),'A')
 
      IF(LQRS.EQ.0) RETURN
      LRZ=LQRS
  10  IF(LRZ.EQ.0)  RETURN
      LUN = IQ(KQSP+LRZ-5)
      IF(LUN.NE.0) THEN
         LOGLV = JBYT(IQ(KQSP+LRZ),15,3)-3
         CALL ZITOH(IQ(KQSP+LRZ+1),IHDIR,4)
         CALL UHTOC(IHDIR,4,CHNAME,16)
         LN  = LENOCC(CHNAME)
*
*     Check top directory name unless IOPTA
*
         IF(IOPTA.EQ.0) THEN
            CHPATU = CHPATH(1:LP)
            CALL CLTOU(CHPATU)
            IF(CHPATU(1:LP).NE.CHNAME(1:LN)) GOTO 20
         ENDIF
         CALL RZEND(CHNAME(1:LN))
*
*    Close
*
         IF(LUN.GT.0) THEN
            IF(JBIT(IQ(KQSP+LRZ),5).EQ.0) THEN
               IF(LOGLV.GT.0) WRITE(IQLOG,*) 'RZCLOS. close unit ',LUN,
     +            ' (FORTRAN)'
               CLOSE(LUN)
            ELSE
#if defined(CERNLIB_QMIBM)
               IF(LOGLV.GT.0) WRITE(IQLOG,*) 'RZCLOS. C I/O not ',
     +            'supported on this system'
#endif
#if !defined(CERNLIB_QMIBM)
               IF(LOGLV.GT.0) WRITE(IQLOG,*) 'RZCLOS. close unit ',LUN,
     +            ' (C)'
               CALL CFCLOS(LUN-1000,0)
#endif
            ENDIF
         ENDIF
      ENDIF
  20  CONTINUE
      LRZ=LQ(KQSP+LRZ)
      GO TO 10
      END
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.5 1998/08/06 17:17:06 mclareni
	6	* For multiple files, LUN has to be set in the common RZCLUN before it is used by RZFREE
	7	*
	8	* Revision 1.4 1997/07/04 15:26:01 couet
	9	* - the error message printing previously added was wrong
	10	*
	11	* Revision 1.3 1997/07/03 09:21:15 couet
	12	* - CHPATH is converted is uppercase before being compared to CHNAME
	13	*
	14	* Revision 1.2 1996/04/24 17:26:42 mclareni
	15	* Extend the include file cleanup to dzebra, rz and tq, and also add
	16	* dependencies in some cases.
	17	*
	18	* Revision 1.1.1.1 1996/03/06 10:47:23 mclareni
	19	* Zebra
	20	*
	21	*
	22	#include "zebra/pilot.h"
	23	SUBROUTINE RZCLOS(CHPATH,CHOPT)
	24	*
	25	************************************************************************
	26	*
	27	* To close all transactions with file CHPATH
	28	* Corresponding directories are dropped
	29	* A FORTRAN or CFCLOS is also issued for all associated files
	30	* Input:
	31	* CHPATH Character variable specifying the name of the top directory
	32	* CHOPT Character variable specifying the options required
	33	* 'A' Close all files currently open
	34	*
	35	* Called by <USER>
	36	*
	37	* Author : J. Shiers
	38	* Written : 11.11.91
	39	* Last mod: 11.11.91
	40	*
	41	************************************************************************
	42	CHARACTER() CHPATH,CHOPT
	43	CHARACTER*16 CHNAME,CHPATU
	44	DIMENSION IHDIR(4)
	45	#include "zebra/rzcl.inc"
	46	#include "zebra/rzclun.inc"
	47	#include "zebra/zunit.inc"
	48	#include "zebra/q_jbit.inc"
	49	#include "zebra/q_jbyt.inc"
	50
	51	LP = LENOCC(CHPATH)
	52	LC = LENOCC(CHOPT)
	53	IOPTA = 0
	54	IF(LC.GT.0) IOPTA = INDEX(CHOPT(1:LC),'A')
	55
	56	IF(LQRS.EQ.0) RETURN
	57	LRZ=LQRS
	58	10 IF(LRZ.EQ.0) RETURN
	59	LUN = IQ(KQSP+LRZ-5)
	60	IF(LUN.NE.0) THEN
	61	LOGLV = JBYT(IQ(KQSP+LRZ),15,3)-3
	62	CALL ZITOH(IQ(KQSP+LRZ+1),IHDIR,4)
	63	CALL UHTOC(IHDIR,4,CHNAME,16)
	64	LN = LENOCC(CHNAME)
65	*
66	* Check top directory name unless IOPTA
67	*
68	IF(IOPTA.EQ.0) THEN
69	CHPATU = CHPATH(1:LP)
70	CALL CLTOU(CHPATU)
71	IF(CHPATU(1:LP).NE.CHNAME(1:LN)) GOTO 20
72	ENDIF
73	CALL RZEND(CHNAME(1:LN))
74	*
75	* Close
76	*
77	IF(LUN.GT.0) THEN
78	IF(JBIT(IQ(KQSP+LRZ),5).EQ.0) THEN
79	IF(LOGLV.GT.0) WRITE(IQLOG,*) 'RZCLOS. close unit ',LUN,
80	+ ' (FORTRAN)'
81	CLOSE(LUN)
82	ELSE
83	#if defined(CERNLIB_QMIBM)
84	IF(LOGLV.GT.0) WRITE(IQLOG,*) 'RZCLOS. C I/O not ',
85	+ 'supported on this system'
86	#endif
87	#if !defined(CERNLIB_QMIBM)
88	IF(LOGLV.GT.0) WRITE(IQLOG,*) 'RZCLOS. close unit ',LUN,
89	+ ' (C)'
90	CALL CFCLOS(LUN-1000,0)
91	#endif
92	ENDIF
93	ENDIF
94	ENDIF
95	20 CONTINUE
96	LRZ=LQ(KQSP+LRZ)
97	GO TO 10
98	END