NTFILL.FOR - A fortran subroutine to help you creating Ntuples. It will do both booking and filling automatically. So, creating a Ntuple becomes no more difficult than creating a histogram. Inserting and reordering of Ntuple variables become easy, too. Example) DO I = 1, N READ(5,*) PX, PY, PZ CALL NTFILL(IDN,CHTITL,CHRZPA,'PX',PX) CALL NTFILL(IDN,CHTITL,CHRZPA,'PY',PY) CALL NTFILL(IDN,CHTITL,CHRZPA,'PZ',PZ) CALL NTFILL(IDN,CHTITL,CHRZPA,'EOD',DUMMY) ENDDO where IDN : Ntuple ID CHTITL : Ntuple Title CHRZPA : Directory name for RZ file 'PX', 'PY', 'PZ': Names of Ntuple variables 'EOD' : The string 'EOD' has a special meaning. NTFILL stores the arguments passed in each call until it encounters 'EOD'. When 'EOD' is encountered for the first time, NTFILL does both booking and filling of a new Ntuple. In subsequent calls, NTFILL just fills the existing Ntuple. PX, PY, PZ : Values for 'PX', 'PY', and 'PZ' NTDUMP.EXE - A program to convert Ntuples into ASCII format. Similar to NTUPLE/SCAN in PAW. NTMAKE.EXE - A program to create ASCII format data into Ntuples. Similar to NTUPLE/READ in PAW. Outputs from NTDUMP utility can be used without any modifications. The source files of above two programs have .CDF extension. To convert them to .FOR (or .f) files, you have to edit them by hand (look for $$ directive). They use functions and subroutines in the CERN library. I tested them on VAX/VMS, Alpha/VMS, and SGI. ----------------------------- NTFILL.FOR --------------------------------------- C======================================================================= C SUBROUTINE NTFILL(ID, CHTITL, CHRZPA, CHTAG, X) C C This routine does booking and filling of Ntuples automatically. C C Input Arguments: C C ID (Integer) : Ntuple ID C If ID=0, all ID's are initialized. C If ID<0, |ID| is initialized. C C CHTITL (Character*(*)) : Ntuple 'Title' C (Up to 80 chars) C C CHRZPA (Character*(*)) : Directory name for RZ file C (Up to 80 chars) ( default '//CHTOP' ) C C CHTAG (Character*(*)) : Name of Ntuple variable C (Up to 8 chars) NTFILL stores the ID, CHTITL, C CHRZPA, CHTAG, and X vaule of C each call until it encounters C 'EOD' as a CHTAG. C (Ntuple variable name) C When 'EOD' is encountered, C NTFILL does both booking and C filling of a new Ntuple for C the first time, or just fill C the existing Ntuple in subsequent C calls. C C X (Real) : Value for the Ntuple variable C C C NOTE: Each Ntuple must be uniquely identified by its ID and title. C If there is an existing Ntuple which has the same ID and a C different CHTITL on memory, it will be deleted from memory. C If both ID and CHTITL match to an existing Ntuple on memory, C the Ntuple will be updated. C C C Author N.Uemura C C Version 1.0 Dec. 11th, 1992 C Version 1.1 Jan. 7th, 1993 C Version 1.2 May. 11th, 1993 C Version 1.3 Oct. 21th, 1993 C Version 1.4 Oct. 18th, 1994 check if variable names start with C an alphabetic character or contain C tabs. C C======================================================================= IMPLICIT NONE INTEGER ID CHARACTER*(*) CHTITL CHARACTER*(*) CHRZPA CHARACTER*(*) CHTAG REAL X INTEGER IPRIME, NPRIME INTEGER NID ! Current Maximum number of Ntuples INTEGER MAXNT ! Maximum number of Ntuples INTEGER MAXVAR ! Maximum number of Variables in a Ntuple PARAMETER ( MAXNT = 10, MAXVAR = 512 ) INTEGER IDLIST(MAXNT) ! Ntuple ID's INTEGER IVAR(MAXNT) ! Ntuple variable counter for booking CHARACTER*80 TITLES(MAXNT) ! CHTITL's CHARACTER*80 RZDIRS(MAXNT) ! CHRZPA's CHARACTER*8 TAGS(MAXVAR,MAXNT) ! TAG's CHARACTER*(MAXVAR) MODFID(MAXNT) ! modified ? CHARACTER*80 TITLE CHARACTER*80 RZDIR CHARACTER*8 TAG CHARACTER*(MAXVAR) YES, NO CHARACTER*1 YES1(MAXVAR), NO1(MAXVAR) CHARACTER*81 CTEMP REAL XX(MAXVAR,MAXNT) ! Values REAL RLOW(MAXVAR), RHIGH(MAXVAR) ! Dummy variables INTEGER I, J, K, N, IDABS CHARACTER*52 ALPHA PARAMETER & (ALPHA = 'abcdefghigklmnopqrstuvwxyzABCDEFGHIGKLMNOPQRSTUVWXYZ') C... External Function INTEGER LENOCC LOGICAL HEXIST C... Common Block INTEGER IQUEST COMMON /QUEST/ IQUEST(100) C... Save Statement SAVE IDLIST, IVAR, MODFID, NID, TAGS, TITLES, RZDIRS, & XX, NPRIME, YES, NO C... Equivalence Statement EQUIVALENCE (YES, YES1), (NO, NO1) C... Data Statement DATA NID, NPRIME / 0 , 10000 / DATA IDLIST / MAXNT * 0 / DATA YES1 / MAXVAR * 'Y' / DATA NO1 / MAXVAR * 'N' / C----------------------------------------------------------------------- IF(ID.LE.0) THEN IF(ID.EQ.0) THEN NID = 0 CALL VZERO(IDLIST,MAXNT) WRITE(6,*) '%NTFILL-I-INITIALIZED, Initialized!' ELSE IDABS = ABS(ID) N = 0 DO 50 I = 1, NID IF(IDABS.NE.IDLIST(I)) THEN N = N + 1 IDLIST(N) = IDLIST(I) GOTO 50 ENDIF WRITE(6,*) '%NTFILL-I-INITIALIZED, Ntuple ID ', IDABS, & ' initialized!' 50 CONTINUE IF(NID.EQ.N) THEN WRITE(6,*) '%NTFILL-F-INVID, Invalid ID ', IDABS, & ' specified!' GOTO 999 ENDIF NID = N ENDIF GOTO 500 ENDIF K = 0 TITLE = CHTITL CTEMP = CHRZPA IF(CTEMP(1:2).NE.'//') CTEMP = '//'//CTEMP RZDIR = CTEMP TAG = CHTAG CALL CTRANS(CHAR(9),' ',TAG,1,8) ! To remove tabs DO 100 I = 1, NID IF(ID.NE.IDLIST(I)) GOTO 100 IF(TITLE.NE.TITLES(I)) GOTO 100 K = I IF(HEXIST(ID)) GOTO 200 100 CONTINUE IF(LENOCC(CHTITL).GT.80) & WRITE(6,*) '%NTFILL-W-CHTITLTRUNC, '// & 'Title truncated to 80 characters!' IF(LENOCC(CTEMP).GT.80) & WRITE(6,*) '%NTFILL-W-CHRZPATRUNC, '// & 'Directory name for RZ file truncated to 80 characters!' IF(LENOCC(CHTAG).GT.8) & WRITE(6,1000) CHTAG(1:LENOCC(CHTAG)), TAG 1000 FORMAT(1H ,'%NTFILL-W-VALNAMTRUNC, Variable name ''',A, & ''' truncated to ''',A,'''') IF(K.EQ.0) THEN NID = NID + 1 IF(NID.GT.MAXNT) THEN WRITE(6,*) '%NTFILL-F-TOOMANYENT, Too many ntuple entries!' GOTO 999 ENDIF K = NID IDLIST(K) = ID RZDIRS(K) = RZDIR IF(HEXIST(ID)) THEN IVAR(K) = MAXVAR CALL HGIVEN(ID,TITLES(K),IVAR(K),TAGS(1,K),RLOW,RHIGH) IF(TITLE.EQ.TITLES(K)) THEN WRITE(6,1001) ID 1001 FORMAT(1H ,'%NTFILL-I-DELETE, Ntuple with ID ', I6, & ' will be updated!') GOTO 200 ENDIF CALL HDELET(ID) WRITE(6,1002) ID 1002 FORMAT(1H ,'%NTFILL-W-DELETE, Histogram or Ntuple with ID ', & I6, ' deleted from memory!') ENDIF TITLES(K) = TITLE J = 0 ELSE J = IVAR(K) IF(TAG.EQ.'EOD ') GOTO 300 DO I = 1, J IF(TAG.EQ.TAGS(I,K)) THEN WRITE(6,*)'%NTFILL-F-DUPVARNAM, Duplicated variable name!' & // ' --> ''', TAG, '''' GOTO 999 ENDIF IF(INDEX(ALPHA,TAG(1:1)).EQ.0) THEN WRITE(6,*)'%NTFILL-W-VARNOALPHA, Variable name not start' & // ' with an alphabetic character!' WRITE(6,*)' --> ''', TAG, '''' ENDIF ENDDO ENDIF J = J + 1 IF(J.GT.MAXVAR) THEN WRITE(6,*) '%NTFILL-F-TOOMANYVAR, Too many ntuple variables!' GOTO 999 ENDIF TAGS(J,K) = TAG XX(J,K) = X IVAR(K) = J GOTO 500 200 IF(RZDIR.NE.RZDIRS(I)) THEN WRITE(6,*) '%NTFILL-F-CHRZPAMISMATCH, '// & 'Directory name for RZ file mismatch!' WRITE(6,*) RZDIRS(I), ' (booked) <--> ', RZDIR, ' (new)' GOTO 999 ENDIF IF(TAG.EQ.'EOD ') THEN IF(MODFID(K)(1:IVAR(K)).EQ.YES(1:IVAR(K))) GOTO 400 WRITE(6,*) '%NTFILL-W-INCOMPLETEFILL, Incomplete filling!' GOTO 400 ENDIF J = 0 DO I = 1, IVAR(K) IF(TAG.EQ.TAGS(I,K)) J = I ENDDO IF(J.EQ.0) THEN WRITE(6,*) '%NTFILL-F-UNDEFVAR, Undefined ntuple variable!' & // ' --> ''', TAG, '''' GOTO 999 ENDIF IF(MODFID(K)(J:J).EQ.'Y') THEN WRITE(6,*) '%NTFILL-F-DBLFILL, Variable already modified!' & // ' --> ''', TAG, '''' WRITE(6,*) '* You modified the same variable more than once ' & // 'before an actual HFN call.' GOTO 999 ELSE MODFID(K)(J:J) = 'Y' ENDIF XX(J,K) = X GOTO 500 300 IF(RZDIR.EQ.' ') RZDIR = 'CHTOP' CALL HBOOKN(ID,TITLE,J,RZDIR,NPRIME,TAGS(1,K)) Write(6,*) '%NTFILL-I-BOOKED, Ntuple ID ', ID, ' booked!' 400 CALL HFN(ID,XX(1,K)) MODFID(K) = NO C... Return to Caller 500 RETURN C... Error occured 999 CALL EXIT ENTRY NTFINI(IPRIME) NPRIME = IPRIME IF(NPRIME.LE.0) NPRIME = 10000 END ----------------------------- NTDUMP.CDF --------------------------------------- C Program NTDUMP C C Author: N. Uemura Dec. 1993 C C Version 1.0 C C You can use NTFILT.FOR ( ntfilt.f on U*ix ) for filtering. C NTFILT.FOR can be created with UWFUNC command in PAW. C (ex. UWFUNC 1 NTFILT.FOR ) Put NTFILT.FOR in the directory C where you use this program. C Implicit None Character LINE*80, COFILE*80, PROMPT*80, CDIRID*80 Character C*12, CHOICE(2)*4 Integer IERR Integer N$A Integer MAXVAR Parameter ( MAXVAR = 512 ) Integer IV(MAXVAR), NV Integer I, II, IE, IS, J, K, L, L1, L2, L3, L4, L5 Integer LC, N, ND, NUM, NTOT Integer ICYCLE, IBCYCL, ISTART, IENT, ISEL Integer LUNOUT Parameter ( LUNOUT = 2 ) Character*8 TAGS(MAXVAR) Real XX(MAXVAR) Real DUMMY Parameter ( DUMMY = 0. ) Logical LEXIST, LNTMAK, LOPEN $$If FILTER Logical LFILTR $$Endif $$If VAX Integer PAGE, WIDTH, WIDSAV Logical LFORM $$Endif C... Contstants & Variables for HRFILE Integer LUNPAW Parameter ( LUNPAW = 1 ) Character*80 CHFILE Character*8 CHTOP Parameter ( CHTOP = 'NTDUMP' ) Character*1 CHOPT Parameter ( CHOPT = ' ' ) Integer LREC C... Contstants & Variables for NTUPLE Integer ID, NVAR Character*80 CHTITL, CHDIR Character*8 CHTAG(MAXVAR), CUTAG(MAXVAR) Real RLOW(MAXVAR), RHIGH(MAXVAR) Integer NENT Real X(MAXVAR) C... Common Blocks /PAWC/ /PAWIDN/ for PAW Integer NWPAW Parameter ( NWPAW = 500000 ) Real H,VIDN1,VIDN2,VIDN3,VIDN Integer IDNEVT, IQUEST Common /PAWC/ H(NWPAW) Common /PAWIDN/IDNEVT,VIDN1,VIDN2,VIDN3,VIDN(10),X Common /QUEST/ IQUEST(100) C... External Function Integer ICDECI, ICFIND, ICFNBL, ICNTHU, LENOCC Real CSRFUN Logical HEXIST C... Data Statements Data ISTART, IBCYCL / 1 , 999 / Data L1, L2, L3 / 1 , 1 , 1 / Data CHFILE, COFILE, CDIRID / ' ' , '*' , '1' / Data CHOICE / 'Y*ES' , 'N*O' / Data LNTMAK / .TRUE. / $$If FILTER Data LFILTR / .FALSE. / $$Endif C-------------------- C... Start of Code C-------------------- C... HLIMIT must be called Call HLIMIT( NWPAW ) $$If FILTER C... COMIS initialization Call CSINIT( 2000 ) Call CSCOM('PAWIDN#',IDNEVT,N$A,N$A,N$A,N$A,N$A,N$A,N$A,N$A,N$A) $$Endif $$If VAX C... Get Terminal Width & Height Call GTERM(PAGE, WIDTH, LFORM) WIDSAV = WIDTH $$Endif C------------- C... HROPEN C------------- 100 Write(PROMPT,'(3A)') 'Ntuple File Name? [', CHFILE(1:L1), '] :' Call GET_LINE(LINE, PROMPT) L = LENOCC(LINE) If(L.EQ.0) Then If(LENOCC(CHFILE).EQ.0) Goto 100 LINE = CHFILE L = L1 Else Call CLEFT(LINE,1,L) L = LENOCC(LINE) Endif Inquire(File=LINE(1:L), Exist=LEXIST) If(.NOT.LEXIST) Then Write(6,*) '%NTDUMP-W-FILENOTFOUND, File not found!' ISEL = 1 Goto 800 Endif Inquire(Unit=LUNPAW, Opened=LOPEN) If(LOPEN) Then If(CHFILE.EQ.LINE) Goto 200 Call HREND( CHTOP ) Close( LUNPAW ) Endif CHFILE = LINE L1 = L $$If VAX Call CLTOU(CHFILE(1:L1)) $$Endif Open ( Unit=LUNPAW, & File=CHFILE(1:L1), & Form='UNFORMATTED', & Status='OLD', & ReadOnly ) Close( LUNPAW ) LREC = 0 120 Call HROPEN(LUNPAW, CHTOP, CHFILE(1:L1), CHOPT, LREC, IERR) If(IERR.NE.0) Then Write(6,*) '%NTDUMP-W-ERRINHROPEN, Error occured in HROPEN!' Write(6,*) '-NTDUMP-I-ERRCORD, Error Cord = ', IERR ISEL = 1 Goto 800 Endif ICYCLE = IBCYCL C------------------ C... Output File C------------------ 200 If(COFILE(1:L2).EQ.'*') Then Write(PROMPT,'(A)') 'Output File Name? [display=''*''] :' Else Write(PROMPT,'(3A)') 'Output File Name? [',COFILE(1:L2),'] :' Endif Call GET_LINE(LINE, PROMPT) L = LENOCC(LINE) If(L.EQ.0) Then LINE = COFILE L = L2 Else Call CLEFT(LINE,1,L) L = LENOCC(LINE) $$If VAX Call CLTOU(LINE(1:L)) $$Endif Endif Inquire(Unit=LUNOUT, Opened=LOPEN) If(LOPEN) Then If(COFILE.EQ.LINE) Goto 300 Close( LUNOUT ) Endif If(LINE(1:L).EQ.'*') Then Open (Unit=LUNOUT, $$If VAX & File='SYS$OUTPUT', $$Else & File='/dev/tty', $$Endif & Form='FORMATTED', & Status='OLD', & Recl=MAX(MAXVAR*15+5,80), & CarriageControl='LIST') LNTMAK = .FALSE. Else Open (Unit=LUNOUT, & File=LINE(1:L), & Form='FORMATTED', & Status='NEW', & Recl=MAX(MAXVAR*15+5,80), & CarriageControl='LIST', & Iostat=IERR) If(IERR.NE.0) Then Write(6,*) & '%NTDUMP-W-CANTOPENFILE, Can''t open output file!' ISEL = 2 Goto 800 Endif LNTMAK = .TRUE. Endif COFILE = LINE L2 = L C----------- C... HRIN C----------- 300 Write(PROMPT,'(3A)') 'Ntuple ID? [', CDIRID(1:L3), '] :' Call GET_LINE(LINE, PROMPT) L = LENOCC(LINE) If(L.EQ.0) Then LINE = '//' // CHTOP // '/' // CDIRID L = L3 Endif Call CLEFT(LINE,1,L) L = LENOCC(LINE) Call CLTOU(LINE(1:L)) N = 0 Do I = 1,L If(LINE(I:I).EQ.'/') N = I Enddo If(N.EQ.L) Goto 310 If(N.GT.1) Then Call HCDIR(LINE(1:N-1),' ') If(IQUEST(1).NE.0) Goto 300 Endif ID = ICDECI(LINE,N+1,L) If(ID.GT.0) Goto 320 310 Write(6,1000) Goto 300 320 If(HEXIST(ID)) Call HDELET(ID) Call HRIN(ID,IBCYCL,0) If(.NOT.HEXIST(ID)) Then Write(6,*) '%NTDUMP-W-UNKNOWNID, Unknown ID specified!' Write(6,*) '-NTDUMP-I-MESSAGE, ', & 'Known Ntuple ID''s are listed below.' Call HLDIR('//'//CHTOP, 'NT') ISEL = 3 Goto 800 Endif Call HDELET(ID) Call HLDIR(' ','NR') Write(6,*) 330 Call ITOA(ICYCLE,C,LC) Write(PROMPT,'(3A)') 'Cycle (0<=Cycle)? [', C(1:LC), '] :' Call GET_LINE(LINE, PROMPT) L = LENOCC(LINE) If(L.EQ.0) Goto 340 I = ICDECI(LINE,1,L) If(I.LT.0) Goto 330 ICYCLE = I 340 Call HRIN(ID,ICYCLE,0) Call HCDIR(CHDIR,'R') L4 = LENOCC(CHDIR) NVAR = MAXVAR Call HGIVEN(ID, CHTITL, NVAR, CHTAG, RLOW, RHIGH) If(NVAR.EQ.0) Then Write(6,*) & '%NTDUMP-F-NOTNTUPLE, Specified ID is not a Ntuple!' ISEL = 3 Goto 800 Endif Call HNOENT(ID, NENT) If(NENT.EQ.0) Then Write(6,*) '%NTDUMP-F-NOENT, No entry in Ntuple!' ISEL = 3 Goto 800 Endif L5 = LENOCC(CHTITL) IENT = NENT ND = NVAR If(COFILE(1:L2).EQ.'*') Then $$If VAX IENT = MIN(IENT,PAGE-11) ND = MIN(ND,(WIDTH-5)/15) $$Else IENT = MIN(IENT,13) ND = MIN(ND,5) $$Endif Endif Call ITOA(ID,C,LC) If(L4.EQ.LENOCC(CHTOP)+2) Then CDIRID = C(1:LC) Else CDIRID = CHDIR(LENOCC(CHTOP)+4:L4) // '/' // C(1:LC) Endif L3 = LENOCC(CDIRID) Call HGNPAR(ID,'NTDUMP') C---------------------------- C... Select Ntuple Variables C---------------------------- C C Ntuple variables can be specified with variable names and numbers. C For example, 'Px_jet,3,5-8,11-' C Do I = 1,NVAR CUTAG(I) = CHTAG(I) Call CLTOU(CUTAG(I)) Enddo 400 Call ITOA(ND, C, LC) Write(6,'(1H ,A,I3,3A)') & 'Variable names or #''s (comma list, up to ', MAXVAR, & ' variables)? [1-', C(1:LC), ']' Call GET_LINE(LINE, '->') L = LENOCC(LINE) If(L.EQ.0) Then LINE = '1-' // C(1:LC) L = LC + 2 Endif Call CLEFT(LINE,1,L) L = LENOCC(LINE) Call CSQMCH('-',LINE,1,L) If(LENOCC(LINE).NE.L) Goto 420 L = L + 1 LINE(L:L) = ',' N = 0 I = 0 Do 410 II = 1,L If(LINE(II:II).NE.',') Goto 410 If(I+1.EQ.II) Goto 420 J = ICFIND('-',LINE,I+2,II-1) If(J.NE.II) Then IS = ICDECI(LINE,I+1,J-1) If(IS.EQ.0.AND.LINE(I+1:J-1).NE.'0') Goto 420 If(J.NE.II-1) Then IE = ICDECI(LINE,J+1,II-1) If(IE.EQ.0.AND.LINE(J+1:II-1).NE.'0') Goto 420 If(IE.GT.NVAR) Then Write(6,1004) NVAR IE = NVAR Endif Else IE = NVAR Endif If(IS.GT.IE) Goto 420 If(IS.LE.0) Goto 430 If(IS.GT.NVAR) Goto 440 Do NUM = IS,IE N = N + 1 If(N.GT.MAXVAR) Goto 450 IV(N) = NUM Enddo Else NUM = ICNTHU(LINE(I+1:II-1),CUTAG,NVAR) If(NUM.EQ.0) NUM = ICDECI(LINE,I+1,II-1) If(NUM.EQ.0.AND.LINE(I+1:II-1).NE.'0') Goto 420 If(NUM.LE.0) Goto 430 If(NUM.GT.NVAR) Goto 440 N = N + 1 If(N.GT.MAXVAR) Goto 450 IV(N) = NUM Endif I = II 410 Continue Goto 490 420 Write(6,1000) Goto 400 430 Write(6,1001) NUM Goto 400 440 Write(6,1002) NVAR, NUM Goto 400 450 Write(6,1003) MAXVAR N = MAXVAR 490 NV = N 500 CONTINUE $$If FILTER $$If VAX Inquire(File='SYS$DISK:[]NTFILT.FOR', Exist=LEXIST) $$Else Inquire(File='./ntfilt.f', Exist=LEXIST) $$Endif If(LEXIST) Then If(LFILTR) Then C Call CSEXEC('!REMOVE NTFILT') Write(PROMPT,'(A)')'Do you want to use NTFILT filter? [Y] :' Else Write(PROMPT,'(A)')'Do you want to use NTFILT filter? [N] :' Endif Call GET_LINE(LINE, PROMPT) II = LENOCC(LINE) If(II.GT.0) Then I = ICFNBL(LINE,1,II) N = ICNTHU(LINE(I:II),CHOICE,2) If(N.EQ.0) Goto 500 If(N.EQ.1) Then LFILTR = .TRUE. Else LFILTR = .FALSE. Endif Endif If(LFILTR) Then $$If VAX Call CSEXEC('!FILE SYS$DISK:[]NTFILT.FOR',IERR) $$Else Call CSEXEC('!FILE ./ntfilt.f',IERR) $$Endif Endif Endif $$Endif 510 If(COFILE(1:L2).EQ.'*') Goto 520 If(LNTMAK) Then Write(PROMPT,'(A)') & 'Do you prefer the format readable by NTMAKE? [Y] :' Else Write(PROMPT,'(A)') & 'Do you prefer the format readable by NTMAKE? [N] :' Endif Call GET_LINE(LINE, PROMPT) II = LENOCC(LINE) If(II.GT.0) Then I = ICFNBL(LINE,1,II) N = ICNTHU(LINE(I:II),CHOICE,2) If(N.EQ.0) Goto 510 If(N.EQ.1) Then LNTMAK = .TRUE. Else LNTMAK = .FALSE. Endif Endif 520 NTOT = 0 Call ITOA(ISTART,C,LC) Write(PROMPT,'(3A)') 'Start Entry #? [', C(1:LC), '] :' Call GET_LINE(LINE, PROMPT) L = LENOCC(LINE) If(L.EQ.0) Goto 600 I = ICDECI(LINE,1,L) If(I.LE.0) Goto 520 ISTART = I 600 Call ITOA(IENT,C,LC) Write(PROMPT,'(3A)') '# of Entries ? [', C(1:LC), '] :' Call GET_LINE(LINE, PROMPT) L = LENOCC(LINE) If(L.GT.0) Then I = ICDECI(LINE,1,L) If(I.LE.0) Goto 600 IENT = I Endif $$If VAX If(COFILE(1:L2).EQ.'*' .AND. NV.GT.ND) Then WIDTH = MIN(132, NV*15 + 5) Call STERM(PAGE, WIDTH, LFORM) Endif $$Endif Write(LUNOUT,*) If(LNTMAK) Then Write(LUNOUT,'(2A)') '!File ', CHFILE(1:L1) Write(LUNOUT,*) Write(LUNOUT,'(2A)') 'ID ', CDIRID(1:L3) Write(LUNOUT,'(2A)') 'TITLE ', CHTITL(1:L5) Do J = 1,NV TAGS(J) = CHTAG(IV(J)) Enddo Write(LUNOUT,'(A,I3,512(1X,A))') & 'NTUPLE ', NV, & (TAGS(K)(1:LENOCC(TAGS(K))),K=1,NV) Call ITOA(NENT,C,LC) Write(LUNOUT,'(2A)') 'DATA ', C(1:LC) Else Write(LUNOUT,'(2A)') 'Ntuple File : ', CHFILE(1:L1) Write(LUNOUT,'(2A)') 'Ntuple Directory : ', CHDIR(1:L4) Write(LUNOUT,'(A,I)') 'Ntuple ID : ', ID Write(LUNOUT,'(2A)') 'Ntuple Title : ', CHTITL(1:L5) Write(LUNOUT,'(A,I)') 'Number of Entries : ', NENT Write(LUNOUT,*) Do J = 1,NV TAGS(J) = CHTAG(IV(J)) Enddo Write(LUNOUT,'(5X,512(2X,A13))') (TAGS(K),K=1,NV) Endif N = 0 I = ISTART - 1 700 DO WHILE(N.LT.IENT .AND. I.LT.NENT) I = I + 1 Call HGNF(ID,I,X,IERR) $$If FILTER If(LFILTR)THEN If(CSRFUN('NTFILT(R)',DUMMY).EQ.0.) Goto 700 Endif $$Endif N = N + 1 Do J = 1,NV XX(J) = X(IV(J)) Enddo Write(LUNOUT,'(I5,512G15.7)') MOD(I,100000), (XX(K),K=1,NV) ENDDO If(LNTMAK) Write(LUNOUT,'(A)') 'END' Write(LUNOUT,*) NTOT = NTOT + N Write(6,*) 'OK ', NTOT, ' entries have been dumped.' ISEL = 0 If(I.GE.NENT) Goto 800 ISTART = I + 1 710 Write(PROMPT,'(A)') 'More? [Y] :' Call GET_LINE(LINE, PROMPT) II = LENOCC(LINE) If(II.EQ.0) Goto 600 I = ICFNBL(LINE,1,II) N = ICNTHU(LINE(I:II),CHOICE,2) If(N.EQ.0) Goto 710 If(N.EQ.1) Goto 600 800 ISTART = 1 Write(PROMPT,'(A)') 'Want to exit? [N] :' Call GET_LINE(LINE, PROMPT) II = LENOCC(LINE) If(II.GT.0) Then I = ICFNBL(LINE,1,II) N = ICNTHU(LINE(I:II),CHOICE,2) If(N.EQ.0) Goto 800 If(N.EQ.1) Goto 999 Endif Goto (100, 200, 300) ISEL Write(6,*) Write(6,'(1H ,A)') '1. Open another PAW file' Write(6,'(1H ,A)') '2. Open another output file' Write(6,'(1H ,A)') '3. Select another Ntuple' Write(6,'(1H ,A)') '4. Select Ntuple variables' Write(6,'(1H ,A)') '5. Dump data from the beginning or ...' Write(6,'(1H ,A)') '6. Quit this program '// & '(You changed your mind?)' Write(6,*) 900 Write(PROMPT,'(A)') 'Select a number from above list :' Call GET_LINE(LINE, PROMPT) L = LENOCC(LINE) If(L.EQ.0) Goto 900 N = ICDECI(LINE,1,L) If(N.LT.1 .OR. N.GT.6) Goto 900 Goto (100, 200, 300, 400, 500) N C------------ C... HREND C------------ 999 Inquire(Unit=LUNPAW, Opened=LOPEN) If(LOPEN) Close( LUNPAW ) Inquire(Unit=LUNOUT, Opened=LOPEN) If(LOPEN) Close( LUNOUT ) $$If VAX If(WIDTH.NE.WIDSAV) Call STERM(PAGE,WIDSAV,LFORM) $$Endif Call EXIT 1000 Format(1H ,'%NTDUMP-W-SYNTAXERROR, Syntax Error!') 1001 Format(1H ,'%NTDUMP-W-OUTOFRANGE, Variable number ', & 'must be larger than zero.'/1H ,'-->',I) 1002 Format(1H ,'%NTDUMP-W-OUTOFRANGE, Variable number ', & 'must be equal or less than',I4,'.'/1H ,'-->',I) 1003 Format(1H ,'%NTDUMP-I-TOTVARTRUNC, The total number of ', & 'variables has been truncated to ',I3,' !') 1004 Format(1H ,'%NTDUMP-I-MAXVARTRUNC, The maximum variable number ' & ,'has been truncated to',I4,' !') End Subroutine GET_LINE(LINE,PROMPT) Integer L Character*(*) LINE, PROMPT L = LENOCC(PROMPT) $$If VAX If(L.EQ.0) Then Call NU$GET_INPUT(LINE) Else Call NU$GET_INPUT(LINE, PROMPT(1:L)//' ') Endif $$Else If(L.GT.0) Write(6,'(1H ,2A$)') PROMPT(1:L),' ' Read(5,'(A)') LINE $$Endif End Subroutine ITOA(I,C,L) Integer I, L, LENOCC Character*(*) C Write(C,'(I)') I L = LENOCC(C) Call CLEFT(C,1,L) L = LENOCC(C) End $$If VAX c ========== INTEGER FUNCTION NU$GET_INPUT(BUFFER, PROMPT, BUFLEN) c ========== c c NU$GET_INPUT BUFFER [,PROMPT] [,BUFLEN] c c INPUT: BUFFER CHARACTER*(*) c PROMPT CHARACTER*(*) [optional] c BUFLEN INTEGER*4 [optional] c implicit none c------------------------------------------------------------------------------- include '($rmsdef)' include '($ssdef)' include '($smgdef)' external SMG$_EOF ! in $smgmsgdef c------------------------------------------------------------------------------- character*(*) buffer, prompt integer*4 buflen integer*2 buff_len, status integer*4 narg integer*4 key_id, key_table_id logical first c------------------------------------------------------------------------------- integer*4 iargcount integer*2 smg$read_composed_line c------------------------------------------------------------------------------- save key_id, key_table_id, first data first / .true. / c------------------------------------------------------------------------------- if (first) then first = .false. call smg$create_virtual_keyboard (key_id,,,,) call smg$create_key_table (key_table_id) endif narg = iargcount() if (narg.eq.1) then status = smg$read_composed_line(key_id, key_table_id, + buffer,,,,,,,,,) else status = smg$read_composed_line(key_id, key_table_id, + buffer, prompt, buff_len,,,,,,,) if (narg.eq.3) buflen = buff_len endif if (status .eq. %loc(SMG$_EOF)) then ! Check for nu$get_input = RMS$_EOF else nu$get_input = status endif end c====================================================================== subroutine gterm(page,screen,form) ! ! Subroutine to determine and change terminal characteristics ! ! ! PROGRAMMER: T. G. Worlton ! Argonne National Lab ! Version 1.0 3/21/84 ! implicit integer*4 (a-z) logical form character local*2,chn_buf*64 byte chn_buf_byte(64),rest_byte(30),ddi_byte(4), 1 class,type,page_len integer*2 buf_size,unit_no,name_off, 1 vol_pro,err_cnt,label_off integer*2 loc_chan,iosb(4) equivalence (chn_buf,chn_buf_byte), 1 (chn_buf_byte,dev_char) equivalence (dev_dep_info,ddi_byte), 1 (ddi_byte(4),page_len) common /pribuf/ dev_char, 1 class,type,buf_size, 1 dev_dep_info, 1 unit_no,name_off, 1 pid, 1 uic, 1 vol_pro,err_cnt, 1 op_cnt, 1 label_off,rest_byte external io$_setmode, 1 tt$m _wrap,tt$m_ttsync,tt$m_mechtab, 1 tt$m_mechform data local/'TT'/ data ifg/0/ ! ! Assign channel number if(ifg .ne. 1) then status=sys$assign(local,loc_chan,,) if (.not.status) call lib$stop(%val(status)) ifg = 1 end if ! ! get terminal characteristics status=sys$getchn(%val(loc_chan),,chn_buf,,) if (.not.status) call lib$stop(%val(status)) page = page_len screen = buf_size iform = dev_dep_info .and. %loc(tt$m_mechform) if(iform .eq. 0) then form = .false. else form = .true. end if return entry sterm(page,screen,form) if(ifg .ne. 1) then status=sys$assign(local,loc_chan,,) if (.not.status) call lib$stop(%val(status)) status=sys$getchn(%val(loc_chan),,chn_buf,,) if (.not.status) call lib$stop(%val(status)) ifg = 1 end if page_len = page buf_size = screen if(form) then dev_dep_info = dev_dep_info 1 .or. %loc(tt$m_mechform) else dev_dep_info = dev_dep_info 1 .xor. %loc(tt$m_mechform) end if status = sys$qiow(,%val(loc_chan),io$_setmode,iosb,,, 1 class,,,,,) return end $$Endif ----------------------------- NTMAKE.CDF --------------------------------------- Program NTMAKE C C ASCII DATA -> Ntuple conversion C C Data file format: C C ------------------------------------- C ! COMMENT C [ID [subdir/][id]] C [TITLE [title]] C NTUPLE nvar [var-name1 var-name2 ...] C DATA C data data data ... C data ... C ... C END C ------------------------------------- C (default values) C id = 1 C title = 'NTMAKE' C variable names = VAR1 VAR2 ... C C C Author: N. Uemura Mar. 1994 C C Version 1.0 C Implicit None Integer I, II, J, L, L1, L2, N Integer ISEL Character ANS*1, FMT*6, CHOICE(2)*4, LINE*80, PROMPT*80 Character STRING*12 Logical LOPEN, LUPD C... Contstants & Variables for HRFILE Integer LUN1 Parameter ( LUN1 = 1 ) Character*2 CHOPT Character*80 CHFILE Character*8 CHTOP Parameter ( CHTOP = 'NTMAKE' ) Integer LREC, ISTAT C... Contstants & Variables for HRIN Integer ICYCLE C... Contstants & Variables for HRDIR Integer MAXDIR, NDIR Parameter ( MAXDIR = 50 ) Character*80 CHDIR(MAXDIR) C... Contstants & Variables for NTUPLE Integer NID Character*80 CHTITL, CHRZPA Integer MAXVAR Parameter ( MAXVAR = 512 ) Real X(MAXVAR) Character*8 CHTAG(MAXVAR) C... Contstants & Variables for HGIVEN Integer NVAR0 Real RLOW(MAXVAR), RHIGH(MAXVAR) Character*80 CHTTL0 Character*8 CHTAG0(MAXVAR) C... Contstants & Variables for Reading DATA File Integer LUN2 Parameter ( LUN2 = 2 ) $$If VAX Integer RECL $$Endif Character*80 CIFILE Character*(5+MAXVAR*15) DLINE Integer IERR Integer LENGTH, LOC Integer IENT, NENT, NSKIP, NFILL, NTOT, NVAR C... Common Blocks /PAWC/ for PAW Integer NWPAW, RECORD Parameter ( NWPAW = 500000 , RECORD = 65000 ) Real H Integer IQUEST Common /PAWC/ H(NWPAW) Common /QUEST/ IQUEST(100) C... External Functions Integer ICDECI, ICFIND, ICFNBL, ICNTHU, LENOCC Logical HEXIST C... Common Block for CKRACK Integer ND,NE,NF,NG,NUM(2) Real ANUM(2),DUMMY(34) Equivalence ( ANUM(1), NUM(1) ) Common /SLATE/ ND,NE,NF,NG,NUM,DUMMY C... DATA Statement Data L1, L2 / 1, 1 / Data LUPD / .FALSE. / Data ANS, CHFILE, CIFILE / 'N', ' ' , ' ' / Data CHOICE / 'Y*ES' , 'N*O' / C-------------------- C... Start of Code C-------------------- C... HLIMIT must be called Call HLIMIT( NWPAW ) C... Request Maximum Record Size IQUEST(10) = RECORD C------------- C... HROPEN C------------- 100 IF(LUPD) THEN Write(PROMPT,'(A)') 'Update an existing file? [Y] :' ELSE Write(PROMPT,'(A)') 'Update an existing file? [N] :' ENDIF Call GETLIN(LINE, PROMPT) II = LENOCC(LINE) If(II.GT.0) Then I = ICFNBL(LINE,1,II) N = ICNTHU(LINE(I:II),CHOICE,2) If(N.EQ.0) Goto 100 If(N.EQ.1) THEN LUPD = .TRUE. ELSE LUPD = .FALSE. ENDIF Endif IF(LUPD) THEN CHOPT = 'U' LREC = 0 ELSE CHOPT = 'NQ' LREC = 1024 ENDIF 105 Write(PROMPT,'(3A)') 'Ntuple File Name? [', CHFILE(1:L1), '] :' Call GETLIN(LINE, PROMPT) L = LENOCC(LINE) IF(L.EQ.0) Then IF(LENOCC(CHFILE).EQ.0) Goto 105 LINE = CHFILE L = L1 ELSE Call CLEFT(LINE,1,L) L = LENOCC(LINE) $$If VAX Call CLTOU(LINE(1:L)) $$Endif Endif Inquire(Unit=LUN1, Opened=LOPEN) IF(LOPEN) THEN IF(LINE(1:L).EQ.CHFILE(1:L1)) GOTO 110 Call HREND( CHTOP ) Close( LUN1 ) ENDIF Call HROPEN(LUN1, CHTOP, LINE(1:L), CHOPT, LREC, ISTAT) If(ISTAT.NE.0) Then Write(6,*)'%RUNINFO-F-ERRINHROPEN, Error in HROPEN!' ISEL = 1 GOTO 160 Endif CHFILE = LINE L1 = L IF(LUPD) THEN ICYCLE = 999 CALL HRIN(0,ICYCLE,0) ENDIF C--------------------- C... Read DATA File C--------------------- 110 Write(PROMPT,'(3A)') 'Data File Name? [',CIFILE(1:L2),'] :' Call GETLIN(LINE, PROMPT) L = LENOCC(LINE) IF(L.EQ.0) Then IF(LENOCC(CIFILE).EQ.0) Goto 110 LINE = CIFILE L = L2 Else Call CLEFT(LINE,1,L) L = LENOCC(LINE) Endif $$If VAX Inquire(File=LINE(1:L), Recl=RECL) IF(RECL.LE.0) RECL = MAX(5+15*MAXVAR,80) $$Endif Open(LUN2, File=LINE(1:L), & Form='FORMATTED', & Status='OLD', & Iostat=IERR, $$If VAX & Recl=RECL, $$Endif & CarriageControl='LIST', & Readonly) If(IERR.NE.0) Then Write(6,*) 'Error in opening data file!' ISEL = 2 Goto 160 Endif CIFILE = LINE L2 = L 120 Write(PROMPT,'(3A)') 'Ignore first 5 columns? [', ANS, '] :' Call GETLIN(LINE, PROMPT) II = LENOCC(LINE) If(II.GT.0) Then I = ICFNBL(LINE,1,II) N = ICNTHU(LINE(I:II),CHOICE,2) If(N.EQ.0) Goto 120 If(N.EQ.1) THEN ANS = 'Y' ELSE ANS = 'N' ENDIF Endif IF(ANS.EQ.'Y') THEN FMT = '(5X,A)' ELSE FMT = '(A)' ENDIF NID = 1 CHTITL = 'NTMAKE' CALL GETNENT(LUN2, NENT) $$If VAX 130 Read(LUN2,'(A)',END=190) DLINE(1:RECL) CALL COLLAPSE(DLINE(1:RECL),LENGTH) $$Else 130 Read(LUN2,'(A)',END=190) DLINE CALL COLLAPSE(DLINE,LENGTH) $$Endif IF(LENGTH.LE.0) GOTO 130 IF(DLINE(1:1).EQ.'!') GOTO 130 STRING(1:7) = DLINE(1:7) CALL CLTOU(STRING(1:7)) IF(STRING(1:3).EQ.'ID ') THEN IF(LENGTH.LE.3) GOTO 130 DLINE(1:LENGTH) = DLINE(4:LENGTH) LENGTH = LENGTH - 3 CALL CLTOU(DLINE(1:LENGTH)) N = LEN(LINE) I = 1 DO 138 II = 1,LENGTH IF(DLINE(II:II).NE.'/') GOTO 138 IF(II.EQ.LENGTH) GOTO 200 IF(II-I.LE.0) GOTO 200 CALL HRDIR(MAXDIR,CHDIR,NDIR) DO J = 1,NDIR LINE = CHDIR(J) L = ICFIND(' ',LINE,1,N) - 1 IF(DLINE(I:II-1).EQ.LINE(1:L)) GOTO 135 ENDDO CALL HMDIR(DLINE(I:II-1),' ') 135 CALL HCDIR(DLINE(I:II-1),' ') IF(IQUEST(1).NE.0) GOTO 200 I = II + 1 138 CONTINUE NID = ICDECI(DLINE,I,LENGTH) ELSE IF(STRING(1:6).EQ.'TITLE ') THEN IF(LENGTH.GT.6) CHTITL = DLINE(7:LENGTH) ELSE IF(STRING(1:7).EQ.'NTUPLE ') THEN IF(LENGTH.LE.7) THEN PRINT *, 'Error! Nunber of variables required.' ISEL = 2 GOTO 160 ENDIF NVAR = ICDECI(DLINE,8,LENGTH) IF(NVAR.LE.0 .OR. NVAR.GT.MAXVAR) THEN PRINT *, 'Error in the number of variables. NVAR=', NVAR ISEL = 2 GOTO 160 ENDIF IF(LENGTH.GT.NE) DLINE(1:LENGTH) = DLINE(NE+1:LENGTH) LENGTH = LENGTH - NE DO I = 1, NVAR IF(LENGTH.GT.0) THEN LOC = ICFIND(' ', DLINE, 1, LENGTH) - 1 IF(LOC.GT.8) & PRINT *,'Warning! Variable name truncated.' CHTAG(I) = DLINE(1:LOC) IF(LENGTH.GT.LOC) DLINE(1:LENGTH) = DLINE(LOC+2:LENGTH) LENGTH = LENGTH - LOC - 1 ELSE CALL ITOA(I,STRING,L) CHTAG(I) = 'VAR' // STRING ENDIF ENDDO ELSE IF(STRING(1:5).EQ.'DATA ') THEN IF(LENGTH.GT.5) THEN N = ICDECI(DLINE,6,LENGTH) IF(N.GT.0) NENT = MIN(N,NENT) ENDIF C--------------------- C... NTUPLE BOOKING C--------------------- IF(NVAR.LE.0) THEN PRINT *, 'Error! NTUPLE directive required.' ISEL = 2 GOTO 160 ENDIF IF(NID.LE.0) NID = 1 IF(LENOCC(CHTITL).LE.0) CHTITL = 'NTMAKE' IF(HEXIST(NID)) THEN NVAR0 = MAXVAR CALL HGIVEN(NID, CHTTL0, NVAR0, CHTAG0, RLOW, RHIGH) IF(NVAR.NE.NVAR0) GOTO 139 DO I = 1, NVAR IF(CHTAG(I).NE.CHTAG0(I)) GOTO 139 ENDDO CALL HNOENT(NID, NTOT) GOTO 140 139 CALL HDELET(NID) ENDIF CALL HCDIR(CHRZPA,'R') CALL HBOOKN(NID, CHTITL, NVAR, CHRZPA, 1000, CHTAG) NTOT = 0 GOTO 140 ELSE GOTO 200 ENDIF GOTO 130 140 NSKIP = 0 DO IENT = 1, NENT $$If VAX Read(LUN2,FMT,END=190) DLINE(1:RECL) CALL COLLAPSE(DLINE(1:RECL),LENGTH) $$Else Read(LUN2,FMT,END=190) DLINE CALL COLLAPSE(DLINE,LENGTH) $$Endif IF(LENGTH.GT.0) THEN DO I = 1, NVAR IF(LENGTH.GT.0) THEN CALL CKRACK(DLINE,1,LENGTH,-1) IF(NG.NE.0) GOTO 200 IF(NF.EQ.2) THEN X(I) = REAL(NUM(1)) ELSE IF(NF.EQ.3 .OR. NF.EQ.4) THEN X(I) = ANUM(1) ELSE GOTO 200 ENDIF IF(LENGTH.GT.NE) DLINE(1:LENGTH) = DLINE(NE+1:LENGTH) LENGTH = LENGTH - NE ELSE CALL ITOA(IENT,STRING,L) PRINT *, 'Insufficient number of data -- 0.0 filled ' & , 'for ''', CHTAG(I)(1:LENOCC(CHTAG(I))) & , ''' of entry ', STRING(1:L) X(I) = 0.0 ENDIF ENDDO C--------------------- C... FILL NTUPLE C--------------------- CALL HFN(NID, X) ELSE NSKIP = NSKIP + 1 CALL ITOA(IENT,STRING,L) PRINT *, 'Blank line skipped! (entry: ', STRING(1:L), ')' ENDIF ENDDO NFILL = NENT - NSKIP NTOT = NTOT + NFILL PRINT *, NFILL, ' events filled.' IF(NTOT.NE.NFILL) PRINT *, NTOT, ' events filled in total.' Close( LUN2 ) C------------ C... HROUT C------------ Call HROUT(NID, ICYCLE, ' ') CALL RZPURG(1) Call HCDIR('//'//CHTOP,' ') ISEL = 3 160 Write(PROMPT,'(A)') 'Want to exit? [N] :' Call GETLIN(LINE, PROMPT) II = LENOCC(LINE) If(II.GT.0) Then I = ICFNBL(LINE,1,II) N = ICNTHU(LINE(I:II),CHOICE,2) If(N.EQ.0) Goto 160 If(N.EQ.1) Goto 210 Endif Goto (100, 110) ISEL 170 Print * Print *, '1. Open a PAW file' Print *, '2. Open a data file' Print *, '3. Quit this program (Changed your mind?)' Print * 180 Write(PROMPT,'(A)') 'Select a number from above list :' Call GETLIN(LINE, PROMPT) L = LENOCC(LINE) If(L.EQ.0) Goto 180 N = ICDECI(LINE,1,L) GOTO (100, 110, 210) N GOTO 180 190 PRINT *, 'ERROR! End of file detected.' GOTO 210 200 PRINT *, 'Syntax Error!' PRINT *, '/' //DLINE(1:LENGTH)// '/' C------------ C... HREND C------------ 210 Inquire(Unit=LUN2, Opened=LOPEN) IF(LOPEN) Close( LUN2 ) Inquire(Unit=LUN1, Opened=LOPEN) IF(LOPEN) THEN Call HREND( CHTOP ) Close( LUN1 ) Endif END Subroutine GETLIN(LINE,PROMPT) Integer L, LENOCC Character*(*) LINE, PROMPT L = LENOCC(PROMPT) $$If VAX If(L.EQ.0) Then Call NU$GET_INPUT(LINE) Else Call NU$GET_INPUT(LINE, PROMPT(1:L)//' ') Endif $$Else If(L.GT.0) Write(6,'(1H ,2A$)') PROMPT(1:L),' ' Read(5,'(A)') LINE $$Endif End SUBROUTINE GETNENT(LUN,NENT) IMPLICIT NONE INTEGER LUN, NENT CHARACTER*80 LINE NENT = 0 100 READ(LUN,'(A)',END=120) LINE CALL CLEFT(LINE,1,80) CALL CLTOU(LINE(1:4)) IF (LINE(1:4).NE.'DATA') GO TO 100 110 READ(LUN,'(A)',END=120) LINE CALL CLEFT(LINE,1,80) CALL CLTOU(LINE(1:3)) IF (LINE(1:3).EQ.'END') GO TO 120 NENT = NENT + 1 GOTO 110 120 REWIND(LUN) END SUBROUTINE ITOA(N,C,L) INTEGER N, L, LENOCC CHARACTER*(*) C WRITE(C,'(I)') N L = LENOCC(C) CALL CLEFT(C,1,L) L = LENOCC(C) END SUBROUTINE COLLAPSE(LINE,L) CHARACTER*(*) LINE INTEGER L, LENOCC INTEGER ICLUNS, CSQMBL, CTRANS COMMON /SLATE/ ND, NE, NF, NG, NUM(2), DUMMY(34) L = LENOCC(LINE) IF(L.LE.0) RETURN IF(ICLUNS(LINE,1,L).GT.0) THEN CALL CTRANS(CHAR(9),' ',LINE,1,L) L = LENOCC(LINE) IF(L.LE.0) RETURN ENDIF CALL CSQMBL(LINE,1,L) L = ND IF(LINE(1:1).EQ.' ') THEN LINE(1:L) = LINE(2:L) L = L - 1 ENDIF END $$If VAX c ========== INTEGER FUNCTION NU$GET_INPUT(BUFFER, PROMPT, BUFLEN) c ========== c c NU$GET_INPUT BUFFER [,PROMPT] [,BUFLEN] c c INPUT: BUFFER CHARACTER*(*) c PROMPT CHARACTER*(*) [optional] c BUFLEN INTEGER*4 [optional] c implicit none c------------------------------------------------------------------------------- include '($rmsdef)' include '($ssdef)' include '($smgdef)' external SMG$_EOF ! in $smgmsgdef c------------------------------------------------------------------------------- character*(*) buffer, prompt integer*4 buflen integer*2 buff_len, status integer*4 narg integer*4 key_id, key_table_id logical first c------------------------------------------------------------------------------- integer*4 iargcount integer*2 smg$read_composed_line c------------------------------------------------------------------------------- save key_id, key_table_id, first data first / .true. / c------------------------------------------------------------------------------- if (first) then first = .false. call smg$create_virtual_keyboard (key_id,,,,) call smg$create_key_table (key_table_id) endif narg = iargcount() if (narg.eq.1) then status = smg$read_composed_line(key_id, key_table_id, + buffer,,,,,,,,,) else status = smg$read_composed_line(key_id, key_table_id, + buffer, prompt, buff_len,,,,,,,) if (narg.eq.3) buflen = buff_len endif if (status .eq. %loc(SMG$_EOF)) then ! Check for nu$get_input = RMS$_EOF else nu$get_input = status endif end $$Endif