* * $Id: pawuwf.F,v 1.4 1998/09/02 09:52:44 couet Exp $ * * $Log: pawuwf.F,v $ * Revision 1.4 1998/09/02 09:52:44 couet * - Bug fixed in case of option P. The previous version was not working properly. * * Revision 1.3 1997/05/13 11:54:17 couet * - call csinc1 * * Revision 1.2 1996/09/11 14:59:35 couet * - Hgetnt and Hgetn2 (old qp routines) are now replaced by hntld * * Revision 1.1.1.1 1996/03/01 11:38:44 mclareni * Paw * * #include "paw/pilot.h" *CMZ : 13/02/96 16.02.40 by O.Couet *-- Author : Rene Brun 03/01/89 SUBROUTINE PAWUWF * * Generates skeleton for a user selection function * #include "hbook/hcbook.inc" #include "paw/pawcom.inc" #include "paw/pcchar.inc" #include "paw/quest.inc" #include "paw/pcslas.inc" #include "paw/pntold.inc" #include "paw/pawlun.inc" DIMENSION IOPT(3) EQUIVALENCE (IOPTE,IOPT(1)),(IOPTP,IOPT(2)),(IOPTT,IOPT(3)) CHARACTER*11 CHTAGS(6) CHARACTER*9 CHVAR(6) CHARACTER*8 CHVART,CHOPT,CHVAR1 CHARACTER*1 CHS,QUOTE LOGICAL NTNEW * SAVE QUOTE DATA QUOTE /''''/ * * called by UWFUNC * ================ IF(IQUEST(99).NE.-1)THEN CALL KUGETC(CHID,N) CALL HNTLD(CHID) IF(IQUEST(1).LT.0)GO TO 99 IF(ID.NE.0.AND.LCID.LE.0)GO TO 99 CALL KUGETF(CHTITL,NCH) IF(NCH.LE.0)GO TO 99 CALL KUGETC(CHOPT,N) ELSE * * called by COMIS * =============== CALL CSINC1(CHTITL) NCH=LENOCC(CHTITL) CHOPT=' ' ENDIF CALL UOPTC(CHOPT,'EPT',IOPT) NTNEW = .NOT.NTOLD IF (NTNEW) THEN IF (IOPTP .NE. 0) + PRINT *,' UWFUNC: option P not valid for new Ntuple.' IF (IOPTT .NE. 0) + PRINT *,' UWFUNC: option T not valid for new Ntuple.' IOPTP = 0 IOPTT = 0 ITRUNC = 0 ENDIF * * Check for . * IOPTI=0 IP=INDEX(CHTITL,'.') IF(IP.GT.0)THEN IF(IP.EQ.NCH)THEN NCH=NCH+1 CHTITL(NCH:NCH)='F' ENDIF IF(CHTITL(IP+1:IP+1).NE.'F'.AND.CHTITL(IP+1:IP+1).NE.'f')THEN IOPTI=1 IOPTP = 0 IOPTT = 0 ITRUNC = 0 ENDIF CHFILE=CHTITL CHTEMP=CHTITL(1:IP-1)//'()' NCHF=IP-1 ELSE #if defined(CERNLIB_UNIX) CHFILE=CHTITL(1:NCH)//'.F' #endif #if defined(CERNLIB_APOLLO) CHFILE=CHTITL(1:NCH)//'.FTN' #endif #if defined(CERNLIB_VAX) CHFILE=CHTITL(1:NCH)//'.FOR' #endif #if defined(CERNLIB_IBM) CHFILE=CHTITL(1:NCH)//'.FORTRAN' #endif CHTEMP=CHTITL(1:NCH)//'()' NCHF=NCH ENDIF * CALL PALUNF(70,3,LUN) IF(LUN.EQ.0)GO TO 99 #if defined(CERNLIB_APOLLO)||defined(CERNLIB_UNIX) * CALL CUTOL(CHFILE) #endif * CALL KUOPEN(LUN,CHFILE,'UNKNOWN',ISTAT) IF(ISTAT.NE.0)GO TO 99 LUNIT(LUN)=9 * IF (NTNEW) THEN CHOPT='P' IF(IOPTI.NE.0)CHOPT='PI' CALL HUWFUN(LUN, ID, CHTEMP(1:NCHF), ITRUNC,CHOPT) GOTO 30 ENDIF * NCH=LENOCC(CHTEMP) IF(IOPTI.EQ.0)THEN WRITE(LUN,1000)CHTEMP(1:NCH) ELSE WRITE(LUN,1001) ENDIF NVAR=IQ(LCID+2) ITAG1=IQ(LCID+10) KLOOP=2 IF(IOPTP.NE.0.OR.IOPTT.NE.0)THEN KLOOP=3 ENDIF DO 20 K=1,KLOOP DO 10 I=1,NVAR,6 IF(I+5.GT.NVAR)THEN JMAX=MOD(NVAR,6) ELSE JMAX=6 ENDIF DO 5 J=1,JMAX IVAR=I+J-1 J1=2*I+2*J-4 CALL UHTOC(IQ(LCID+ITAG1+J1),4,CHVART,8) IF(CHVART.EQ.' ')THEN IF(IVAR.LT.10)THEN WRITE(CHVART,5100)IVAR ELSEIF(IVAR.LT.100)THEN WRITE(CHVART,5200)IVAR ELSE WRITE(CHVART,5300)IVAR ENDIF ENDIF IF (J1.EQ.0) CHVAR1=CHVART IF(K.EQ.3)THEN IF(IVAR.LT.NVAR)THEN CHTAGS(J)=QUOTE//CHVART//QUOTE//',' ELSE CHTAGS(J)=QUOTE//CHVART//QUOTE//'/' ENDIF ENDIF IF(IVAR.LT.NVAR)THEN CHVAR(J)=CHVART//',' ELSE CHVAR(J)=CHVART ENDIF DO 2 L=1,8 CHS=CHVAR(J)(L:L) IF( CHS.EQ.'('.OR.CHS.EQ.')' + .OR.CHS.EQ.'/'.OR.CHS.EQ.BSLASH + .OR.CHS.EQ.'+'.OR.CHS.EQ.'-' + .OR.CHS.EQ.'*'.OR.CHS.EQ.'.')THEN IF(L.EQ.8)THEN CHVAR(J)(L:L)=' ' ELSE CHVAR(J)(L:L)='x' ENDIF ENDIF 2 CONTINUE 5 CONTINUE * IF(K.NE.3)THEN WRITE(LUN,2000)(CHVAR(L),L=1,JMAX) ELSE WRITE(LUN,2000)(CHTAGS(L),L=1,JMAX) ENDIF 10 CONTINUE IF(K.EQ.1) THEN WRITE(LUN,2500) WRITE(LUN,3000) ENDIF IF(K.EQ.2.AND.KLOOP.EQ.3)THEN WRITE(LUN,3010)NVAR,CHVAR1,NVAR ENDIF 20 CONTINUE * IF(IOPTP.NE.0)THEN WRITE(LUN,3500)CHTEMP(1:NCHF),NVAR ELSE IF(IOPTI.EQ.0)WRITE(LUN,4000)CHTEMP(1:NCHF) ENDIF * 30 CALL PACLOS(LUN) LUNIT(LUN)=0 * * Edit file if option 'E' * IF(IOPTE.NE.0)CALL KUEDIT(CHFILE,ISTAT) * 1000 FORMAT(6X,'REAL FUNCTION ',A,/,6X,'REAL') 1001 FORMAT(6X,'REAL') 2000 FORMAT(5X,'+',6(A)) 2500 FORMAT( + '*',/, + ' LOGICAL CHAIN',/, + ' CHARACTER*128 CFILE',/, + '*',/, + ' COMMON /PAWCHN/ CHAIN, NCHEVT, ICHEVT',/, + ' COMMON /PAWCHC/ CFILE',/, + '*') 3000 FORMAT(6X,'COMMON/PAWIDN/IDNEVT,OBS(13),') 3010 FORMAT(6X,'DIMENSION XDUMMY(',I3,')',/, +6X,'EQUIVALENCE (XDUMMY(1),',A,')',/, +6X,'CHARACTER*8 CHTAGS(',I3,')',/,6X,'DATA CHTAGS/') 3500 FORMAT('*',/,6X,A,'=1.',/, +6X,'PRINT 1000,IDNEVT',/, +6X,'DO 10 I=1,',I3,/, +9X,'PRINT 2000,I,CHTAGS(I),XDUMMY(I)',/, +' 10 CONTINUE',/,'*',/, +' 1000 FORMAT(8H IDNEVT=,I5)',/, +' 2000 FORMAT(5X,I3,5X,A,1H=,G14.7)',/, +6X,'END') 4000 FORMAT('*',/,6X,A,'=1.',/,6X,'END') 5100 FORMAT('V_',I1,5X) 5200 FORMAT('V_',I2,4X) 5300 FORMAT('V_',I3,3X) 99 END