* * $Id: suprlay.F,v 1.1.1.1 1996/04/01 15:03:18 mclareni Exp $ * * $Log: suprlay.F,v $ * Revision 1.1.1.1 1996/04/01 15:03:18 mclareni * Mathlib gen * * #include "sys/CERNLIB_machine.h" #include "_gen/pilot.h" SUBROUTINE SUPRLAY(NFIC,NIV1,NIV2,NRECL,KEEP) C-- SUPRLAY VERSION WITH AUTOMATIC SCM AND LCM ALLOCATION. C-- AUTHOR H.GROTE / CERN - DD 2ND MODIFIED VERSION 1.10.80 C-- THIS VERSION ALLOWS FOR LOADER TABLES TYPE 53B (43) AND 54B (44). C-- INPUT VARIABLES C NFIC = LOGICAL FILE NAME OF FILE CONTAINING ABSOLUTE BINARY. C NIV1 = OVERLAY LEVEL C NIV2 = NUMBER INSIDE OVERLAY LEVEL C NREC(OPTIONAL)= RECALL PARAMETER C KEEP(OPTIONAL)= KEEP PARAMETER(RESTORED ON LCM OR DISK AFTER EX.) C-- ACTION. C A CALL TO SUPRLAY LOADS THE CORRESPONDING OVERLAY (NIV1,NIV2) FROM C LCM OR DISK AND EXECUTES IT. THE BINARY( WHICH MAY HAVE CHANGED C DURING EXECUTION) IS KEPT IN CASE OF THE KEEP PARAMETER AND WILL C THEREFORE BE RESTORED AT THE NEXT CALL TO THIS OVERLAY. C-- THE COMMON /DEBUT/ IS PLACED AT THE START OF THE ROUTINE TO HAVE C ACCESS TO THE RETURN ADDRESS, WHICH UNDER THE CURRENT LOADER AND C COMPILER VERSION IS STORED AT NENTRY(IEEL=4). C THIS IS NECESSARY BECAUSE SUPRLAY MAY BE CALLED FROM INSIDE THE C OVERLAY IT HAS STARTED. COMMON/AUXBST/LSTBST,LBLBST,LB2BST,MAXBST,NLMBST,LFRBST,LOWBST COMMON/DEBUT/NENTRY(1) EQUIVALENCE(NENTRY,NENT) DIMENSION ID(30),LENTRY(30),LADR(30),NWD(30),NADB(30) 1 ,INDEX(31),IBUF(5),KIPLST(2),IRET(2),NOVLST(3) 2 ,MESSG1(5),MESSG2(7),MESSG3(4),MESSG4(4),MESSG5(4),NARG(2) DIMENSION NFORM(10,2) #if defined(CERNLIB_NOSBE) DIMENSION UDUMMY(20) EQUIVALENCE (UDUMMY(16),ICODE),(UDUMMY(16),IBUF(1)) #endif #if !defined(CERNLIB_F4) DIMENSION MESSG6(5),MESSG7(5) #endif C-- NFORM CONTAINS FORMAT CONTROL INFORMATION, FOR 1 (53B) AND 2 (54B) C "POSITION" HERE MEANS 10000*WORD+100*UPPERBIT+LOWERBIT, C WORDS COUNTED FROM 1 IN IBUF, BITS RIGHT TO LEFT, 0 TO 59 . C WORD NO. MEANING C 1 NO. OF HEADER RECORDS (EXCEPT FIRST = DUMMY ) C 2 WORDS / HEADER RECORD 1 C 3 WORDS / HEADER RECORD 2 C 4 POSITION OF OVERLAY IDENTIFIER C 5 POSITION OF SCM IMAGE START C 6 SHIFT OF SCM IMAFGE START (FORMAT 2, LOAD HEADER) C 7 POSITION OF ENTRY POINT C 8 LENGTH OF LCM IMAGE (MUST BE ZERO FOR SUPRLAY) C 9 LENGTH OF SCM IMAGE C 10 SCM MINIMUM LENGTH FOR THIS OVERLAY DATA MESSG1/10HSUPRLAY VE,10HRS. 2.1 IN,10HIT FILE - ,2*0/ DATA MESSG4/10HSUPRLAY-PL,10HEASE REMOV,10HE RFL CARD,0/ #if defined(CERNLIB_F4) DATA MESSG3/3*10H++++++++++,5L+++++/ DATA MESSG5/10HSUPRLAY-UN,10HKNOWN LOAD,10HER FORMAT,,5L EXIT/ DATA MDISK/4LDISK/ #endif #if !defined(CERNLIB_F4) DATA MESSG3/3*"++++++++++",L"+++++"/ DATA MESSG5/"SUPRLAY-UN","KNOWN LOAD","ER FORMAT,"," EXIT"/ DATA MESSG6/10HFILE IS EM,10HPTY-PROBAB,10HLY NOT DEC,5HLARED,0/ DATA MESSG7/10HSUPRLAY-SE,10HRIOUS ERRO,10HR (SEE OUT, 1 10HPUT), STOP,0/ C-- FLAG FOR FIRST ENTRY, AND NO. OF NAME SEARCH LOCATIONS DATA IFIRST/0/, NLOOK/50/ DATA MASK18/O"177777"/, NAMSUPR/L"SUPRLAY"/ DATA MDISK/L"DISK"/ #endif DATA NFORM/ 1 2, 2, 1, 14736, 13518, 1, 11600, 22300, 31700, 33518, 2 1, 5, 0, 14736, 13518, 5, 51700, 32300, 25942, 21700/ #if defined(CERNLIB_F4) DATA KBL/1R / DATA IEEL/5/ #endif #if !defined(CERNLIB_F4) DATA KBL/R" "/ #endif C-- FLAGS AND COUNTERS DATA NENTRY,IFDISK,NOVLST,NOVL/6*0/ DATA NSCM/0/, IFORM/0/ C-- PLACE OF RETURN ADDRESS C-- CODES DATA KKEEP,KREC/4HKEEP,6HRECALL/ C-- FLAG FOR SCM INCREASE REQUEST DATA IRSCM/0/ C--- MAX. NO. OF OVERLAYS ALLOWED = DIMENSION OF ID, LENTRY, C LADR,NWD,NADB, AND INDEX (+1) DATA MAXOV/30/ C--- C-- SUBROUTINE SUPRLAY(NFIC,NIV1,NIV2,NRECL,KEEP) C-- #if !defined(CERNLIB_F4) C--- LOOK FOR PLACE OF RETURN ADDRESS IF FIRST ENTRY IF(IFIRST.NE.0) GOTO 10 IFIRST=1 DO 1 I=1,NLOOK IF(AND(MASK(42),NENTRY(I)).EQ.NAMSUPR) GOTO 5 1 CONTINUE CALL REMARK(MESSG3) CALL REMARK(MESSG4) CALL REMARK(MESSG3) WRITE(6,2001)NLOOK 2001 FORMAT(//,' +++++++++++++++++++++++++++++++++++++++++++++++++',// 1 ,' SUPRLAY FATAL ERROR - ENTRY NOT FOUND IN NENTRY(1..',I3,'),', 2 ' STOP',//) GOTO 201 5 CONTINUE C--- ABSOLUTE ENTRY ADDRESS IEEL=AND(MASK18,NENTRY(I)) C--- RELATIVE TO NENTRY IEEL=IEEL-LOCF(NENTRY)+1 10 CONTINUE #endif C-- IDENTIFICATION OF REQUESTED OVERLAY IDENT=OR(SHIFT(NIV1,6),NIV2) DO 11 NOV=1,NOVL IF(IDENT.EQ.ID(NOV)) GOTO 12 11 CONTINUE GOTO 111 12 CONTINUE #if defined(CERNLIB_F4) IF(IRSCM.GT.0) GOTO 17 IRSCM=1 C-- SCM NOT INCREASED BY SUPRLAY - PRINT MESSAGE CALL REMARK(MESSG3) CALL REMARK(MESSG3) CALL REMARK(MESSG4) CALL REMARK(MESSG3) CALL REMARK(MESSG3) 17 CONTINUE #endif NENT=NENT+1 IF(NENT.GT.2) GOTO 112 KIPLST(NENT)=0 CALL NOARG(NARG(NENT)) IF(NARG(NENT).GT.4) KIPLST(NENT)=KEEP IRET(NENT)=NENTRY(IEEL) C-- CHECK WHETHER RECALL PAR., AND OVERLAY IN MEMORY KRECL=0 IF(NARG(NENT).GE.4) KRECL=NRECL IF(KRECL.NE.KREC) GOTO 13 IF(NOV.EQ.NOVLST(NENT)) GOTO 14 IF(NOV.EQ.NOVLST(NENT+1)) GOTO 14 13 CONTINUE C-- OVERLAY HAS TO BE RELOADED - THEREFORE THE RECALL C-- PARAMETER FOR THE NEXT HIGHER OVERLAY HAS TO BE DISABLED. NOVLST(NENT+1)=0 C-- READ FROM LCM (LEC.GE.0) OR DISK(LEC.LT.0) ISTART=LADR(NOV) LEC=NADB(NOV) IF(LEC.GE.0) CALL GETBST(LEC,1,LADR(ISTART),LDUM) IF(LEC.LT.0) CALL READMS(MDISK,LADR(ISTART),NWD(NOV),NOV) C-- EXECUTE OVERLAY JUST LOADED 14 CONTINUE NOVLST(NENT)=NOV CALL OVLATAK(LENTRY(NOV)) C-- RESTORE ARGUMENTS AND RETURN ADDRESS NOV=NOVLST(NENT) NENTRY(IEEL)=IRET(NENT) C-- CHECK FOR KEEP PARAMETER IF(KIPLST(NENT).NE.KKEEP) GOTO 16 C-- YES - RESTORE ON LCM OR DISK ISTART=LADR(NOV) IF(NADB(NOV).LT.0) GOTO 15 C-- LCM - FREE SPACE OF OLD COPY FIRST CALL GETBST(NADB(NOV),-1,LDUM,LDUM) CALL PUTBST(LADR(ISTART),NWD(NOV),NADB(NOV)) GOTO 16 15 CALL WRITMS(MDISK,LADR(ISTART),NWD(NOV),NOV) 16 NENT=NENT-1 RETURN C-- SUBROUTINES PUTLCM(NFIC) AND PUTDISK(NFIC) #if defined(CERNLIB_F4) ENTRY PUTDISK #endif #if !defined(CERNLIB_F4) ENTRY PUTDISK (NFIC) #endif C-- FLAG FOR DISK STORAGE MED=0 IF(IFDISK.EQ.0) CALL OPENMS(MDISK,INDEX,MAXOV+1,0) IFDISK=1 GOTO 20 #if defined(CERNLIB_F4) ENTRY PUTLCM ENTRY PUTECS #endif #if !defined(CERNLIB_F4) ENTRY PUTLCM (NFIC) ENTRY PUTECS (NFIC) #endif MED=1 20 CONTINUE C-- CHANGE FILE NAME TO L FORMAT NFICC=AND(NFIC,MASK(42)) DO 21 I=1,10 NFICC=SHIFT(NFICC,6) IF(JBYT(NFICC,1,6).NE.KBL) GOTO 21 NFICC=AND(NFICC,MASK(54)) 21 CONTINUE #if (defined(CERNLIB_NOSBE))&&(defined(CERNLIB_F4)) CALL SUOPEN (NFICC,0,0) #endif #if (defined(CERNLIB_NOSBE))&&(!defined(CERNLIB_F4)) OPEN(UNIT=NFICC,IOSTAT=IOERR,STATUS='OLD',FORM='UNFORMATTED' +, BUFL=513) #endif REWIND NFICC MESSG1(4)=NFICC IFAC=0 CALL REMARK(MESSG1) C-- DETECT LOADER TABLE FORMAT, CHECK VALIDITY C-- SKIP 16 WORDS #if !defined(CERNLIB_F4) READ(NFICC,IOSTAT=IOERR) UDUMMY #endif #if defined(CERNLIB_F4) READ(NFICC) UDUMMY #endif IF(EOF(NFICC).NE.0.) GOTO 100 #if (!defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) READ(NFICC,IOSTAT=IOERR) ICODE #endif #if (defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) READ(NFICC) ICODE #endif #if !defined(CERNLIB_NOSBE) IF(EOF(NFICC).NE.0.) GOTO 113 #endif ITABLE=JBYT(ICODE,55,6) IF(ITABLE.EQ.43) IFORM=1 IF(ITABLE.EQ.44) IFORM=2 REWIND NFICC IF(IFORM.NE.0) GOTO 30 C-- WRONG LOADER TABLE FORMAT - PRINT DAYFILE MESSAGE AND EXIT CALL REMARK(MESSG5) GOTO 201 C-- MAIN LOOP 30 CONTINUE C-- SKIP 16 WORDS WITHOUT RELEVANT INF. #if !defined(CERNLIB_F4) READ(NFICC,IOSTAT=IOERR) UDUMMY #endif #if defined(CERNLIB_F4) READ(NFICC) UDUMMY #endif IF(EOF(NFICC).NE.0.) GOTO 100 IFAC=1 #if !defined(CERNLIB_NOSBE) C-- READ HEADER IUP=NFORM(1,IFORM) IU=0 DO 301 I=1,IUP IL=IU+1 IU=IU+NFORM(I+1,IFORM) #endif #if (!defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) READ(NFICC,IOSTAT=IOERR) (IBUF(J),J=IL,IU) #endif #if (defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) READ(NFICC) (IBUF(J),J=IL,IU) #endif #if !defined(CERNLIB_NOSBE) 301 CONTINUE #endif C-- CHECK FOR (ILLEGAL FOR SUPRLAY) LCM DECLARATION THIS OVERLAY IF(IPOSUP(IBUF,NFORM(8,IFORM)).NE.0) GOTO 117 C-- COUNT NO. OF OVERLAYS READ NOVL=NOVL+1 IDENT=IPOSUP(IBUF,NFORM(4,IFORM)) IF(NOVL.GT.MAXOV) GOTO 110 ID(NOVL)=IDENT LADR(NOVL)=IPOSUP(IBUF,NFORM(5,IFORM)) C-- LENGTH OF SCM IMAGE + SHIFT OF START POSITION NWD(NOVL)=IPOSUP(IBUF,NFORM(9,IFORM))+NFORM(6,IFORM) C-- LENGTH OF SCM NECESSARY FOR THIS OVERLAY IABL=IPOSUP(IBUF,NFORM(10,IFORM)) C-- REQUEST 10 WORDS MORE THAN NEEDED FOR SAFETY. IABL=IABL+10 C--- ENTRY POINT OF THIS OVERLAY LENTRY(NOVL)=IPOSUP(IBUF,NFORM(7,IFORM)) #if !defined(CERNLIB_F4)||defined(CERNLIB_NOSBE) IF(NSCM.EQ.0) CALL MEMORC(0,NSCM,IERR) #endif #if (defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) IF(NSCM.EQ.0) CALL MEMORY(0,NSCM,IERR) #endif C-- CHECK FOR OVERWRITING CURRENT OVERLAY C-- LOADER TAKES MEMORY IN CHUNKS OF 100 OCTAL. IF(LADR(NOVL)+64.GE.NSCM) GOTO 32 IF(NOVL.GT.1) GOTO 32 CALL MSPREP(MESSG2,9,IDENT,IERR,IERR) CALL REMARK(MESSG2) 32 CONTINUE IF(IABL.LE.NSCM) GOTO 31 C-- INCREASE SCM BY NECESSARY AMOUNT IRSCM=IRSCM+1 #if !defined(CERNLIB_F4)||defined(CERNLIB_NOSBE) CALL MEMORC(IABL-NSCM,NSCM,IERR) #endif #if (defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) CALL MEMORY(IABL-NSCM,NSCM,IERR) #endif IERR=ABS(IERR) IF(IERR.GT.0) GOTO 114 31 CONTINUE C-- SET THE(ABSOLUTE) STARTING ADDRESS RELATIVE TO START OF LADR LADR(NOVL)=LADR(NOVL)-LOCF(LADR(1))+1 C-- READ IN THE OVERLAY AND STORE IT AWAY ISTART=LADR(NOVL) IEND=ISTART+NWD(NOVL)-1 C-- COPY HEADER IF FORMAT 2 (54B) IF(IFORM.EQ.2) CALL UCOPY(IBUF,LADR(ISTART),5) ISTS1=ISTART+NFORM(6,IFORM) #if (!defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) READ(NFICC,IOSTAT=IOERR) (LADR(IIII),IIII=ISTS1,IEND) #endif #if (defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) READ(NFICC) (LADR(IIII),IIII=ISTS1,IEND) #endif #if (!defined(CERNLIB_F4))&&(defined(CERNLIB_NOSBE)) BACKSPACE NFICC READ(NFICC,IOSTAT=IOERR) UDUMMY,(LADR(IIII),IIII=ISTS1,IEND) #endif #if (defined(CERNLIB_F4))&&(defined(CERNLIB_NOSBE)) BACKSPACE NFICC READ(NFICC) UDUMMY,(LADR(IIII),IIII=ISTS1,IEND) #endif IF(EOF(NFICC).NE.0.) GOTO 113 IF(MED.EQ.0) GOTO 40 C-- STORE IN LCM CALL PUTBST(LADR(ISTART),NWD(NOVL),NADB(NOVL)) IF(NADB(NOVL).EQ.0) GOTO 116 IERR=ABS(NADB(NOVL)) IF(NADB(NOVL).LT.0) GOTO 115 GOTO 50 40 CONTINUE C-- STORE ON DISK NADB(NOVL)=-1 CALL WRITMS(MDISK,LADR(ISTART),NWD(NOVL),NOVL) 50 CONTINUE C-- PREPARE DAYFILE MESSAGE AND PUT IT INTO DAYFILE CALL MSPREP(MESSG2,MED,IDENT,NSCM,LSTBST) CALL REMARK(MESSG2) #if (!defined(CERNLIB_F4))&&(!defined(CERNLIB_NOSBE)) C--- SKIP EOS/EOP ON ABS. LGO FILE READ(NFICC,IOSTAT=IOERR) UDUMMY IF(EOF(NFICC).NE.0) GOTO 100 #endif C-- LOOP UNTIL E.O.F. GOTO 30 100 CONTINUE IF(IFAC.EQ.0) #if defined(CERNLIB_F4) 1 CALL REMARK(35HFILE IS EMPTY-PROBABLY NOT DECLARED) #endif #if !defined(CERNLIB_F4) 1 CALL REMARK(MESSG6) #endif #if (defined(CERNLIB_NOSBE))&&(!defined(CERNLIB_F4)) CLOSE (UNIT=NFICC,IOSTAT=IOERR) #endif RETURN C-- TO RESTART FROM A HIGHER LEVEL OVERLAY (RECOVERY) #if defined(CERNLIB_F4) ENTRY SUPKLIR #endif #if !defined(CERNLIB_F4) ENTRY SUPKLIR (NFIC) #endif NENT=NFIC RETURN C-- ERRORS - EXIT CALLED IN ALL CASES 110 CONTINUE C-- MORE THAN 20 OVERLAYS - OVERFLOW MED=2 GOTO 200 111 CONTINUE C-- UNKNOWN OVERLAY REFERENCED FOR LOADING MED=3 GOTO 200 112 CONTINUE C-- BAD STRUCTURE (MORE THAN 2 OVERLAY LEVELS) MED=4 GOTO 200 113 CONTINUE C-- E.O.F. WHILE READING ABSOLUTE BINARY MED=5 GOTO 200 114 CONTINUE C-- SCM OVERFLOW MED=6 GOTO 200 115 CONTINUE C-- LCM OVERFLOW MED=7 GOTO 200 116 CONTINUE C-- ERROR IN LCM DYNAMIC MEMORY MANAGEMENT MED=8 GOTO 200 117 CONTINUE C-- USER DEFINES LCM IN THIS OVERLAY - ILLEGAL MED=10 200 CONTINUE CALL MSPREP(MESSG2,MED,IDENT,IERR,IERR) CALL REMARK(MESSG2) 201 STOP END