%%%%%%%%%%%%%%%%%% INSTALLATION %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% Installation instructions - 1. Assemble the two assembler routines using the IBM H assembler: global maclib cmslib dmssp osmacro hasm jumpxa hasm rtimer 2. Compile two of the Fortran routines with the IBM PF compiler: pfpcomp sched (par(lang) opt(3)) pfpcomp gsched (par(lang) opt(3)) NOTE: The LIBOPN FORTRAN and GLIBOPN FORTRAN routines are compiled under the covers from the SCHLINK exec, so they do not need to be compiled; they only have to be available to the exec. The SCHLINK exec inserts the user common names so that they can be shared with the originated PF tasks which will be doing the work. %%%%%%%%%%%%%%%%%% HELP FILES FOR EXECS %%%%%%%%%%%%%%%%%%%%%%%%%% The Schedule Package, developed at Argonne National Lab by Dongarra and Sorensen, is an environment which allows a programmer to implement a parallel algorithm in a Fortran setting, in a manner that will lend itself to transporting the resulting program across a wide variety of parallel machines. This is done by allowing existing Fortran subroutines to be called through Schedule, without modification, thereby permitting users access to a wide body of existing library software in a parallel setting. Machine-specific intrinsics are invoked within the Schedule package; the user of Schedule is thus relieved of the burden of modifying each code he desires to transport from one machine to another. Presently, versions of the Schedule package are available for Alliant, Sequent, Encore, Vax, Sun, Cray 2, Flex, and NCube machines. Each time the package is ported to another machine, it must be tailored to utilize that machine's flavor of parallelism. In the case of porting to the IBM 3090, the Schedule package was written in IBM Parallel Fortran (PF). The user, however, does not need to know IBM PF, or any other machine- specific parallel language. S/he simply writes a Fortran program, inserting calls to the Schedule library of routines to implement the desired parallelism. An added feature of the Schedule package is the inclusion of a graphics trace facility for viewing the flow of execution of a Schedule program. During the SCHLINK step of the Schedule environment, the user can link to the trace version of the Schedule package. When the code is executed, a trace file, with a file identifier of "FILE GRAPH A", will be produced. This file can be downloaded to any Sun workstation on which the trace facility has been installed (the source code for the trace facility is available from the CNSF and is easily installed on any Sun workstation which has SUNTOOLS. Contact a consultant for information about obtaining a copy.) The trace facility can then be used to view an animation of flow of execution, a feature useful for understanding performance issues and some programming errors. Once the parallel Fortran program has been developed via insertion of calls to Schedule routines, the following execs are used to run the program in the Schedule environment: SCHCOMP SCHGLOB SCHLINK SCHEXEC Separate help files are available which explain the use of each one of these execs. ************************* SCHCOMP ******************************** SCHCOMP - Pre-processes the source code to determine all named commons. All named commons will automatically be specified as dynamic when the source is compiled. The names will be stored in an output file for later use in the SCHLINK step. The Parallel Fortran compiler is then invoked to compile the source. Syntax: SCHCOMP filename SCHCOMP filename ( options filename - name of the source file to be compiled. options - all the normal VS Fortran options, with the exception of the FREE option. Files produced: filename TEXT - normal text file. filename LISTING - normal listing file. filename COMMONS - contains the list of common block names; later used in the SCHLINK step. All output files will be given the same filemode as the source. Example: SCHCOMP MAIN (VEC(LEV(3))) This example compiles a FORTRAN source file called MAIN with a vectorization level of 3. Three output files are produced: MAIN TEXT, MAIN LISTING, and MAIN COMMONS; all will have the same filemode as MAIN FORTRAN. ************************* SCHGLOB ******************************** SCHGLOB - Identifies a list of text libraries, both systems and user- provided, to be searched to resolve external references while linking a Schedule program with the SCHLINK EXEC. This list remains in effect until overridden by another SCHGLOB or until it is made null by a CMS IPL. Syntax: SCHGLOB textlib1 textlib2 ... textlib(n) - the filename of a CMS text library, with filetype of "TXTLIB". Example: SCHGLOB FORTAUX This example allows the user to call system routines stored in FORTAUX TXTLIB. ************************* SCHLINK ******************************** SCHLINK - Creates an executable load library by linking all the user- specified text files together with the Schedule library. NOTE: Execution of the SCHLINK exec clears all user-defined FILEDEF's that were not specified with the PERM option. Thus, any FILEDEF's should be issued AFTER the SCHLINK step to be in effect during program execution via the SCHEXEC step. Syntax: SCHLINK loadlib intext1 intext2 ... SCHLINK loadlib intext1 intext2 ... ( TRACE loadlib - the filename of the CMS load library that will be created. This output file will be given a filemode of "A". intext(n) - a CMS text file the user wishes to include in the resulting loadlib. A filemode of "*" will be assigned; thus all user disks will be searched for the file in the normal order. TRACE - Use of this option links the trace version of the Schedule package, which produces a trace file to be used by the Schedule graphics trace facility. Files produced: loadlib LOADLIB - an executable load library. NOTE: This step also produces 5 intermediate files - $SCHTEMP FILE, $LIBOPN FORTRAN, $LIBOPN LISTING, $LIBOPN TEXT, and $loadlib TEXT, all of which are written to the user's A disk. These files are erased if the SCHLINK EXEC successfully completes; however, any one of them may be left on the A disk if an error occurs. Example: SCHLINK MAIN MAIN SUB1 SUB2 This statement links MAIN TEXT, SUB1 TEXT, SUB2 TEXT, and the Schedule TEXT files together to create an executable loadlib file with the file identifier of "MAIN LOADLIB A". Since the TRACE option was not specified, no trace file will be produced upon execution of the resulting loadlib. ************************* SCHEXEC ******************************** SCHEXEC - Executes a parallel Schedule program prepared with SCHLINK. Syntax: SCHEXEC loadlib SCHEXEC loadlib procs SCHEXEC loadlib ( options loadlib - name of the load library to be executed. procs - number of Fortran processors to use. The default is 1, the maximum allowable is 6. This number MUST MATCH the value assigned to the first argument in the call to the SCHED subroutine. options - normal VS Fortran runtime options plus a new PARALLEL option. The PARALLEL option governs parallel execution. This option works the same for Schedule as for IBM Parallel Fortran, with the exception that the Schedule package only allows a maximum of 6 Fortran processors to be defined, rather than the 63 allowable by IBM PF. Thus, the following suboptions can be specified: PROCS(n) - number of Fortran processors to use. Again, the maximum allowable is 6. TRACE - control for IBM PF trace data. TRACE suboptions are described in the Parallel Fortran Language and Library Reference Manual. NOTE: Specification of the TRACE option on the SCHEXEC statement invokes the use of the IBM Parallel Fortran Trace Facility, NOT the Schedule package graphics trace facility. If the TRACE option is specified on the SCHLINK statement, while the IBM PF TRACE option is specified on the SCHEXEC statement, then both a Schedule trace file (FILE GRAPH A) and IBM PF trace files (FILE S000xT00 A) will be produced. Here are the Fortran files: %%%%%%%%%%%%%%%%%%%%%%%%%%%% SCHED FORTRAN %%%%%%%%%%%%%%%%%%%%%%%%% @PROCESS DC(QDATA) DC(QSYNC) subroutine chekin(jobtag) cpsu An Alliant directive CVD$R NOCONCUR integer jobtag c*********************************************************************** c c this subroutine reports unit of computation labeled by c jobtag has completed to all dependent nodes. these nodes are c recorded in parmq(i,jobtag) where 6 .le. i .le. nchks+5 c checkin consists of decrementing the value in each of these c locations by 1. each of these is done in a critical section c protected by qlock(ichek) c c if the value in parmq(2,ichek) is 0 where ichek is a process c dependent upon this one then ichek is placed on the readyq c by entering the critical section protected by rtlock. the c pointer rtail to the tail of the readyq is incremented c unless task done is to be recorded. task done is placed on c the ready q and the pointer rtail left in place if nchks .eq. 0 c is found. c c see the common block description in libopn for more detail. c c*********************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock c cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c a complete common block description is given in the routine libopn c c**************************************************************************** c c check to see if this process has completed. if not do not checkin c c first ask if any kids spawned by jobtag c if (parmq(4,jobtag) .ne. 0 .or. parmq(5,jobtag) .ne. 0 ) then c c either kids have been spawned or ientry has been referenced c indicating reentry is required c c c find out how many are waiting to complete c if (parmq(4,jobtag) .ne. 0) then call lockon(qlock(jobtag)) parmq(2,jobtag) = parmq(2,jobtag) - parmq(4,jobtag) call lockof(qlock(jobtag)) endif c c reset number of kids c parmq(4,jobtag) = 0 c c update the number of times this procedure has been c entered c parmq(1,jobtag) = parmq(1,jobtag) + 1 c c return without checkin if all the kids have not c checked in to jobtag yet or if a reentry is required. c process jobtag is not done in either case. c if (parmq(2,jobtag) .ne. 0 ) return c c if ientry has been called but jobtag is not waiting c on any kids then jobtag is placed back on the readyq c if ( parmq(5,jobtag) .ne. 0) then iwrkr = mod(jobtag,mxces) + 1 call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = jobtag rtail(iwrkr) = rtail(iwrkr) + 1 call lockof(trlock(iwrkr)) return endif endif c c the process has completed so chekin proceeds c cgraph call lockon(qlock(mxprcs)) cgraph if (endgrf .gt. nbuffr) call dump(endgrf,igraph) cgraph insrt = endgrf cgraph endgrf = endgrf + 1 cgraph call lockof(qlock(mxprcs)) cgraph if (jobtag .ge. intspn) then cgraph igraph(1,insrt) = 5 cgraph igraph(2,insrt) = parmq(6,jobtag) cgraph igraph(3,insrt) = jobtag cgraph igraph(4,insrt) = second(foo) cgraph else cgraph igraph(1,insrt) = 2 cgraph igraph(2,insrt) = jobtag cgraph igraph(3,insrt) = second(foo) cgraph endif c nchks = parmq(3,jobtag) c c if this is the final process (indicated by nchks .eq. 0) then c record task done. do not advance the tail so task done sequence c is set. all subsequent gtprb queries will leave rhead .eq. rtail c with readyq(rhead) .eq. done. c if (nchks .eq. 0) then do 20 iwrkr = 1,mxces call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = done call lockof(trlock(iwrkr)) return 20 continue endif do 50 j = 6,nchks+5 mychek = parmq(j,jobtag) c c get unique access to the checkin node mychek c and checkin by decrementing the appropriate counter c mchkgo = 1 call lockon(qlock(mychek)) parmq(2,mychek) = parmq(2,mychek) - 1 mchkgo = parmq(2,mychek) call lockof(qlock(mychek)) c c place mychek on readyq if parmq(2,mychek) is 0 c if (mchkgo .eq. 0 ) then iwrkr = mod(mychek,mxces) + 1 call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = mychek rtail(iwrkr) = rtail(iwrkr) + 1 call lockof(trlock(iwrkr)) endif 50 continue return c c last card of chekin c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) subroutine dep(jobtag,icango,nchks,mychkn) cpsu An Alliant directive CVD$R NOCONCUR integer jobtag,icango,nchks,mychkn(*) c************************************************************************* c c warning - this routine may only be used by driver in a static definition c of the data dependencies in the task. c c c usage c subroutine xxx() c external yyy c . c . c . c call dep(jobtag,icango,nchks,mychkn) c call putq(jobtag,yyy,) c . c . c . c c this subroutine puts data dependencies for problem on the queue. c no synchronization is necessary because each index of a column of c parmq is associated with a jobtag specified by the user and c associated with a unique unit of computation. the arguments of c dep specify a the data dependencies associated with the unit of c computation labeled by jobtag and are placed in a column of parmq c to the menue specified below. c c jobtag is an integer specifying a unique schedulable process c c c icango is a positive integer specifying how many processes must check in c to this process before it can be placed on the readyq. c c nchks is the number of processes that depend upon the completion of c this process. c c mychkn is an integer array specifying the jobtags of the processes c which depend upon completion of this process. c c************************************************************************* c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c for a complete common block description see the subroutine libopn c c c place process jobtag on the problem queue c no synchronization required to update qtail since c only one program work executes this code. c if ((jobtag .le. 0 .or. jobtag .gt. mxprcs) .or. & icango .lt. 0 .or. nchks .lt. 0) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' incorrect specification of dependencies ' write(6,*) ' all DEP parameters must be non-negative' write(6,*) ' input was ' write(6,*) ' jobtag ',jobtag ,'.... must be postitive ' write(6,*) ' but less than ',mxprcs write(6,*) ' icango ',icango write(6,*) ' nchks ',nchks write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop c endif qtail = qtail + 1 next = jobtag parmq(1,next) = 1 parmq(2,next) = icango parmq(3,next) = nchks parmq(4,next) = 0 c c check to see that exactly one node has ncheks set to 0 c if (nchks .eq. 0 .and. done .eq. 0) then done = -2 else if (nchks .eq. 0) done = 0 endif c c specify identifiers of processes which depend on this one c if there are too many abort c if (nchks .gt. nslots - 5) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' attempt to place too many dependencies ' write(6,*) ' on chekin list during call to dep ' write(6,*) ' with jobtag ',jobtag write(6,*) ' ' write(6,*) ' user tried to place ',nchks ,' dependencies ' write(6,*) ' the maximum number is ',nslots - 5 write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop c endif do 50 j = 1,nchks parmq(j+5,next) = mychkn(j) c if (mychkn(j) .le. 0) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' incorrect specification of dependencies ' write(6,*) ' all mychkn entries must be positive' write(6,*) ' input was ' write(6,*) ' mychkn(',j,') = ',mychkn(j) write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop endif c 50 continue cgraph call lockon(qlock(mxprcs)) cgraph if (endgrf .gt. nbuffr) call dump(endgrf,igraph) cgraph insrt = endgrf cgraph endgrf = endgrf + 1 cgraph call lockof(qlock(mxprcs)) cgraph igraph(1,insrt) = 0 cgraph igraph(2,insrt) = jobtag cgraph igraph(3,insrt) = icango cgraph igraph(4,insrt) = nchks cgraph do 9001 jnsrt = 6,nchks + 5 cgraph igraph(jnsrt-1,insrt) = parmq(jnsrt,next) cgraph 9001 continue c return c c last card of dep c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) integer function gtprb(id,jobtag) cpsu An Alliant directive CVD$R NOCONCUR c************************************************************************** c c this function gets unique access to the head of the readyq c pointed to by id and then claims the pointer to the next c schedulable process if there is one and returns with a nonzero c value when there is a process to schedule. if there are no entries c in the readyq indexed by id then the remaning ready ques are c polled in a round robin manner until schedulable process is found c or task done is recorded. if task done has been recorded the value c zero is returned in gtprb. if a nonzero value is returned in gtprb, c the integer jobtag will contain the identifier of the unit of c computation that is to be executed. c c input parameter c c id an integer specifying which readyq to access first c for work to do. c c output parameters c c jobtag an integer containing the next process to be executed c c gtprb the return value of this integer function is: c c 0 if task done has been posted c c nonzero if a schedulable process has been claimed. c c c*************************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c common block description: c c for a complete common block description see the routine libopn c c nspins = 0 cpsu Does this do anything? fsave = second(foo) iwrkr = id 10 continue mhead = -1 call lockon(hrlock(iwrkr)) c c gain access to head of readyq. if task done has not been recorded c then increment the head of the readyq. otherwise the head pointer c is left fixed so the next active process will receive task done. c if (rhead(iwrkr) .lt. rtail(iwrkr)) then mhead = rhead(iwrkr) rhead(iwrkr) = rhead(iwrkr) + 1 endif call lockof(hrlock(iwrkr)) if (mhead .gt. 0) then c c there was a work unit on the readyq c jobtag = readyq(mhead,iwrkr) cgraph call lockon(qlock(mxprcs)) cgraph if (endgrf .gt. nbuffr) call dump(endgrf,igraph) cgraph insrt = endgrf cgraph endgrf = endgrf + 1 cgraph call lockof(qlock(mxprcs)) cgraph if (jobtag .ge. intspn) then cgraph igraph(1,insrt) = 4 cgraph igraph(2,insrt) = parmq(6,jobtag) cgraph igraph(3,insrt) = jobtag cgraph igraph(4,insrt) = second(foo) cgraph else cgraph igraph(1,insrt) = 1 cgraph igraph(2,insrt) = jobtag cgraph igraph(3,insrt) = second(foo) cgraph endif c if (jobtag .ne. done) then c c record the subroutine call identifier in gtprb and return c the process identifier in jobtag. c gtprb = parmq(1,jobtag) if (gtprb .gt. 1 .and. parmq(5,jobtag) .eq. 0) gtprb = -1 c else c c task done has been indicated. request a return from subroutine work c by returning the value 0 in gtprb. c gtprb = 0 c endif else c jobtag = readyq(rhead(iwrkr),iwrkr) if (jobtag .eq. done) then c c task done has been posted c gtprb = 0 c else c c there was not any work on the readyq c iwrkr = mod((iwrkr+1),mxces) if (iwrkr .eq. 0) iwrkr = mxces nspins = nspins + 1 if (mod(nspins,mxces) .eq. 0) call nops go to 10 c endif endif return c c last card of gtprb c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) subroutine start2 c c this routine allows parallel processing to start after user supplied c driver has completed by unlocking the head of the readyq c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskik,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,TASKID(MXPRCS),JS(MXCES) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock logical nostrt cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c for common block description see subroutine libopn. c if (done .ne. 0) then write(6,*) '*************SCHED USER ERROR********************' if (done .eq. -1 ) then write(6,*) ' no process has set nchks equal to 0 ' else write(6,*) ' more than one process has set nchks to 0 ' endif write(6,*) ' SCHEDULE will not be able to terminate job' write(6,*) ' correctly ' write(6,*) ' ' write(6,*) ' check subroutine passed to initial call to' write(6,*) ' to see that at exactly one call to DEP has ' write(6,*) ' set nchks = 0 ' write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop endif c nostrt = .true. do 100 iwrkr = 1,mxces if (rhead(iwrkr) .ne. rtail(iwrkr)) nostrt = .false. 100 continue if (nostrt) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' no process had an intitial icango of 0 ' write(6,*) ' SCHEDULE could not begin ' write(6,*) ' ' write(6,*) ' check subroutine passed to initial call to' write(6,*) ' to see that at least one call to DEP has ' write(6,*) ' set icango = 0 ' write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop endif intspn = qtail c do 200 iwrkr = 1,mxces call lockof(hrlock(iwrkr)) 200 continue c return c c last card of start2 c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) subroutine place(jobtag) cpsu An Alliant directive CVD$R NOCONCUR integer jobtag c************************************************************************* c c c this subroutine places a problem on the readyq c c jobtag is an integer specifying a unique schedulable process c c c icango is a positive integer specifying how many processes must check in c to this process before it can be placed on the readyq. c c nchks is the number of processes that depend upon the completion of c this process. c c mchkin is an integer array specifying the jobtags of the processes c which depend upon completion of this process. c c************************************************************************* c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c for a complete common block description see the subroutine libopn c c c c place this process on readyq if icango is 0 c when icango .eq. 0 this process does not depend on any c others. c icango = parmq(2,jobtag) iwrkr = mod(jobtag,mxces) + 1 if (icango .eq. 0 ) then call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = jobtag rtail(iwrkr) = rtail(iwrkr) + 1 call lockof(trlock(iwrkr)) endif c c last card of place c return end c************************************************************************* c************************************************************************* real function second(t) cpsu This provides a generic timing routine for the IBM3090 real*4 t real*8 schstp MMT00240 real*4 schbeg common/schtm/schstp,schbeg cpsu RTIMER is a timing routine written at the CNSF which returns cpsu a real*8 value representing the system time-of-day clock cpsu (wall clock time). It is an assembler routine which retrieves cpsu the time using the STCK instruction. Because RTIMER is first cpsu invoked with a tstamp of 0, all timings after cpsu that are relative to the first call. if (schbeg.eq.0) then schbeg = 1 schstp = 0 endif t = RTIMER(schstp) second = t return end c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) C Sched routine translated from C to Fortran by Vasicek and Beguelin. SUBROUTINE SCHED( &NPROC,SNAME,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11 &,P12,P13,P14,P15,P16,P17,P18,P19,P20) C-- ---------Modified for MVS by D. Vasicek 7/31/87 cpsu Modified for VM by S. Utter, CNSF, April 1989 INTEGER NPROC INTEGER P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14,P15,P16,P17 1,P18,P19,P20 INTEGER SNAME INTEGER ISUBN(0:999) INTEGER IPARMS(20,0:999) COMMON/INDEX /ISUBN,IPARMS C this procedure obtains nprocs physical processors devoted C to the the execution of the parallel program indicated through parms C which is a structure whose first entry is a subroutine name and whose C remaining entries are parameters appearing in the calling sequence C of that subroutine. C C Call freopen("term","w",stdout) C Call bcopy(&parms, &indx[0], sizeof(struct parms)); cpsu See JUMP ASSEMBLE for description CALL JUMPSV ISUBN(0)= SNAME CALL ITOP (P1 ,IPARMS(1,0)) CALL ITOP (P2 ,IPARMS(2,0)) CALL ITOP (P3 ,IPARMS(3,0)) CALL ITOP (P4 ,IPARMS(4,0)) CALL ITOP (P5 ,IPARMS(5,0)) CALL ITOP (P6 ,IPARMS(6,0)) CALL ITOP (P7 ,IPARMS(7,0)) CALL ITOP (P8 ,IPARMS(8,0)) CALL ITOP (P9 ,IPARMS(9,0)) CALL ITOP (P10 ,IPARMS(10,0)) CALL ITOP (P11 ,IPARMS(11,0)) CALL ITOP (P12 ,IPARMS(12,0)) CALL ITOP (P13 ,IPARMS(13,0)) CALL ITOP (P14 ,IPARMS(14,0)) CALL ITOP (P15 ,IPARMS(15,0)) CALL ITOP (P16 ,IPARMS(16,0)) CALL ITOP (P17 ,IPARMS(17,0)) CALL ITOP (P18 ,IPARMS(18,0)) CALL ITOP (P19 ,IPARMS(19,0)) CALL ITOP (P20 ,IPARMS(20,0)) C C the subroutine name and prameter list have been copied and C placed in a special slot on the parmq C C then libopn is invoked to initialize pointers, grab physical C processors and begin the computation C CALL LIBOPN( NPROC) RETURN END c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) SUBROUTINE PUTQ( & JOBTAG,SNAME,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11, 1P12,P13,P14,P15,P16,P17,P18,P19,P20) C Sched routine translated from C to Fortran by Vasicek and Beguelin. cpsu Modified for VM by S. Utter, CNSF, April 1989 INTEGER JOBTAG INTEGER SNAME,ISUBN(0:999) INTEGER P1 ,P2 ,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14, 1P15,P16,P17,P18,P19,P20 INTEGER IPARMS(20,0:999) COMMON/INDEX /ISUBN,IPARMS C C this procedure puts the descriptor of a schedulable process C onto the problem queue. this process will be scheduled for execution C when its data dependencies have been satisfied (indicated by icango==0). C the argument parms is a structure whose first entry is a subroutine name C and whose remaining entries are parameters appearing in the calling sequence C of that subroutine. C C register int j; INTEGER J J = JOBTAG C bcopy(&parms, &indx[j], sizeof(struct parms));*/ IF (SNAME .EQ. 0 ) THEN PRINT*,' You got problems, Jobtag = ',JOBTAG PRINT*,' Subname is blank' ENDIF cpsu ISUBN(J)= SNAME cpsu See JUMP ASSEMBLE for description CALL CTOM (SNAME, ISUBN(J)) CALL ITOP (P1 ,IPARMS(1,J)) CALL ITOP (P2 ,IPARMS(2,J)) CALL ITOP (P3 ,IPARMS(3,J)) CALL ITOP (P4 ,IPARMS(4,J)) CALL ITOP (P5 ,IPARMS(5,J)) CALL ITOP (P6 ,IPARMS(6,J)) CALL ITOP (P7 ,IPARMS(7,J)) CALL ITOP (P8 ,IPARMS(8,J)) CALL ITOP (P9 ,IPARMS(9,J)) CALL ITOP (P10 ,IPARMS(10,J)) CALL ITOP (P11 ,IPARMS(11,J)) CALL ITOP (P12 ,IPARMS(12,J)) CALL ITOP (P13 ,IPARMS(13,J)) CALL ITOP (P14 ,IPARMS(14,J)) CALL ITOP (P15 ,IPARMS(15,J)) CALL ITOP (P16 ,IPARMS(16,J)) CALL ITOP (P17 ,IPARMS(17,J)) CALL ITOP (P18 ,IPARMS(18,J)) CALL ITOP (P19 ,IPARMS(19,J)) CALL ITOP (P20 ,IPARMS(20,J)) C first the parms block is copied into the slot pointed to by C by jobtag and then this descriptor is placed on the problem C queue C CALL PLACE(JOBTAG) RETURN END c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) SUBROUTINE WORK(ID,JOBTAG) C Sched routine translated from C to Fortran by Vasicek and Beguelin. cpsu Modified for VM by S. Utter, CNSF, April 1989 INTEGER J ,JOBTAG,MYJOB,GTPRB,ID INTEGER PARMS(20) INTEGER IPARMS(20,0:999) INTEGER ISUBN(0:999) COMMON/INDEX /ISUBN,IPARMS C C C extern void start2(); C external int gtprb(); J = ID IF (J .EQ. 1) THEN C C the worker whose id is 1 will execute the subroutine passed to C sched. this subroutine executes the static data dependency graph. C this graph must have at least one node. C IF (ISUBN(0).EQ. 0 ) THEN PRINT*,' No subroutine to jump to???' PRINT*,' PARMS(J)=',(IPARMS(I,0),I=1,20) ENDIF cpsu See JUMP ASSEMBLE for description CALL JUMP(ISUBN(0), IPARMS(1,0), IPARMS(2,0), 1 IPARMS( 3,0), IPARMS( 4,0), IPARMS( 5,0), IPARMS(6,0), 2 IPARMS( 7,0), IPARMS( 8,0), IPARMS( 9,0), 3 IPARMS(10,0), IPARMS(11,0), IPARMS(12,0), 4 IPARMS(13,0), IPARMS(14,0), IPARMS(15,0), 5 IPARMS(16,0), IPARMS(17,0), IPARMS(18,0), 6 IPARMS(19,0), IPARMS(20,0)) CALL START2() ENDIF MYJOB = GTPRB(ID,JOBTAG) C while (myjob .ne. 0) 91919 CONTINUE IF(MYJOB.EQ.0) GOTO 91921 C { J = JOBTAG IF (MYJOB .LE. -1 ) THEN C reenter... simple spawning was done C all kids completed and no reentry C is required. this indicates C jobtag is all done and checkin can proceed. CALL CHEKIN(JOBTAG) MYJOB = GTPRB(ID,JOBTAG) ELSE C C call sname().......... C IF (ISUBN(J).EQ. 0 ) THEN PRINT*,' J=',J,' JOBTAG=',JOBTAG PRINT*,' No subroutine to jump to???' PRINT*,' Parms(j)=',(IPARMS(I,J),I=1,20) ENDIF CALL JUMP (ISUBN(j),IPARMS(1,J), IPARMS(2,J), 1 IPARMS( 3,J), IPARMS(4,J), IPARMS(5,J), IPARMS(6,J), 2 IPARMS( 7,J), IPARMS(8,J), IPARMS(9,J), 3 IPARMS(10,J), IPARMS(11,J), IPARMS(12,J), 4 IPARMS(13,J), IPARMS(14,J), IPARMS(15,J), 5 IPARMS(16,J), IPARMS(17,J), IPARMS(18,J), 6 IPARMS(19,J), IPARMS(20,J)) CALL CHEKIN(JOBTAG) MYJOB = GTPRB(ID,JOBTAG) ENDIF 91920 GOTO 91919 91921 CONTINUE RETURN END c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) subroutine nxtag(mypar,jobtag) cpsu An Alliant directive CVD$R NOCONCUR integer mypar,jobtag c************************************************************************* c c c this subroutine puts data dependencies for problem on the queue. c no synchronization c is necessary because each index of a column of parmq is associated c with a jobtag specified by the user and associated with a unique c schedulable process. the arguments of putq specify a process and are c placed in a column of jobq according to the menue specified in the c common block description given below. c c jobtag is an integer specifying a unique schedulable process c c c icango is a positive integer specifying how many processes must check in c to this process before it can be placed on the readyq. c c nchks is the number of processes that depend upon the completion of c this process. c c mchkin is an integer array specifying the jobtags of the processes c which depend upon completion of this process. c c************************************************************************* c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c for a complete common block description see the subroutine libopn c c c c place this process on the next slot in the problem queue c call lockon(qtlock) next = qtail qtail = qtail + 1 call lockof(qtlock) c cgraph call lockon(qlock(mxprcs)) cgraph if (endgrf .gt. nbuffr) call dump(endgrf,igraph) cgraph insrt = endgrf cgraph endgrf = endgrf + 1 cgraph call lockof(qlock(mxprcs)) cgraph igraph(1,insrt) = 3 cgraph igraph(2,insrt) = mypar cgraph igraph(3,insrt) = next c if ( next .gt. mxprcs) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' user attempt to create too many processes' write(6,*) ' through dynamic spawning ' write(6,*) ' the maximum allowed is ',mxprcs write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop endif c jobtag = next parmq(1,next) = 1 parmq(2,next) = 0 parmq(3,next) = 1 parmq(6,next) = mypar c c update the icango counter of the parent process c by adding 2 to parmq(2,mypar)... prevents race condition. c add 1 to the number of kids spawned by parent mypar c call lockon(qlock(mypar)) parmq(2,mypar) = parmq(2,mypar) + 2 parmq(4,mypar) = parmq(4,mypar) + 1 call lockof(qlock(mypar)) c c set number of kids spawned by next to zero c parmq(4,next) = 0 c c c return c c last card of nxtag c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) logical function wait(jobtag,ienter) c integer jobtag,ienter c***************************************************************************** c c this routine will allow process jobtag to continue after c spawned processes have all checked in. it should only be called if c processes have been spawned by jobtag through the use of c the subroutine spawn. this routine must be used in conjunction with c subroutine prtspn. the required syntax is c c go to (1000,...,L000,...,N000), ientry(mytag,N) c 1000 continue c . c . c . c do 100 j = 1,nproc c . c . (set parameters to define spawned process) c . c call nxtag(mytag,jobtag) c call spawn(mytag,jobtag,subname,) c 100 continue c label = L c if (wait(jobtag,label)) return c L000 continue c . c . c . c c if this subroutine returns a value of .true. then the calling process c jobtag should issue a return. if a value of .false. is returned then c the calling process jobtag should resume execution at the c statement immediately following the reference to wait (ie. at L000 in c the example above. a return value .true. indicates that some spawned c process has not yet completed and checked in. a return value .false. c indicates all spawned processes have checked in. c c***************************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c check the icango counter to see if all spawned processes (kids) c have checked in. c icango = 1 call lockon(qlock(jobtag)) icango = parmq(2,jobtag) - parmq(4,jobtag) call lockof(qlock(jobtag)) c if (icango .eq. 0) then c c all kids are done ... dont wait (ie return false) c wait = .false. c c record re_entry label where computation is to c resume after wait is complete c parmq(1,jobtag) = ienter c if (ienter .gt. parmq(5,jobtag)) then write(6,*) '*************SCHED USER ERROR*****************' write(6,*) ' executing SCHEDULE function WAIT ' write(6,*) ' return label larger than the maximum ' write(6,*) ' specified by user in call to ientry ' write(6,*) ' from process jobtag ',jobtag write(6,*) ' ' write(6,*) ' the maximum reentry number is ' write(6,*) ' ', parmq(5,jobtag) write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop endif c c set last re_entry indication (parmq(5,jobtag) = 0) c if this reentry point corresponds to last one c (recorded in parmq(5,jobtag) during call to ientry) c if (ienter .eq. parmq(5,jobtag)) parmq(5,jobtag) = 0 c else c c kids are not done c wait = .true. c c a checkin will be made so set the number of c entries to return label ienter - 1 to get c correct entry point after checkin c parmq(1,jobtag) = ienter - 1 c endif c return c c last card of wait c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) integer function ientry(jobtag,nentrs) c integer jobtag c***************************************************************************** c c this routine will allow process jobtag to continue after c spawned processes have all checked in. it should only be called if c processes have been spawned by jobtag through the use of c the subroutine spawn. c c go to (1000,2000,...,N000), ientry(jobtag,N) c 1000 continue c . c . c . c do 10 j = 1,nproc c . c . (set parameters to define spawned process) c . c call nxtag(myid,jobtag) c call spawn(myid,jobtag,subname,) c 10 continue c return c 2000 continue c . c . c . c return c N000 continue c c return c end c c this subroutine returns the number of times process jobtag c has been entered. if that number is equal to the total c number nentrs of expected reentries then parmq(5,jobtag) c is set to 0 indicating no more reentries required. c c***************************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c report the entry point where process jobtag should resume c computation c if (nentrs .lt. 2) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' user call to IENTRY with number of ' write(6,*) ' labels in nentrs set less than 2 ' write(6,*) ' from process ',jobtag write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop endif ientry = parmq(1,jobtag) if (ientry .lt. nentrs) then parmq(5,jobtag) = nentrs else parmq(5,jobtag) = 0 endif c return c c last card of ientry c end c************************************************************************* c************************************************************************* subroutine dump(endgrf,igraph) parameter (nslots = 30,nbuffr = 500) integer endgrf real igraph(nslots,nbuffr) integer ievent(nslots) cpsu The file was opened in libopn. This simply attaches the unit cpsu to the current process so it can write out the buffer to the cpsu file. open(unit=3) c c this routine writes graphics output to a file c and resets endgrf to 1 c c do 100 j = 1,endgrf c write(6,15) (igraph(i,j),i = 1,nslots) c 100 continue c 15 format('dump: igraph',30f5.1) do 300 j = 1,endgrf-1 do 302 i = 1,nslots ievent(i) = igraph(i,j) 302 continue if( ievent(1) .eq. 0 ) $ write(3,301) (ievent(i),i=1,ievent(4)+4) if( ievent(1) .eq. 1 ) $ write(3,303) (ievent(i),i=1,2),igraph(3,j) if( ievent(1) .eq. 2 ) $ write(3,303) (ievent(i),i=1,2),igraph(3,j) if( ievent(1) .eq. 3 ) $ write(3,301) (ievent(i),i=1,3) if( ievent(1) .eq. 4 ) $ write(3,304) (ievent(i),i=1,3),igraph(4,j) if( ievent(1) .eq. 5 ) $ write(3,304) (ievent(i),i=1,3),igraph(4,j) 301 format(14i8) 303 format(2i8,1pe16.8) 304 format(3i8,1pe16.8) 300 continue c endgrf = 1 c return end c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) SUBROUTINE SPAWN( & PARENT,JOBTAG,SNAME,P1,P2,P3,P4,P5,P6,P7,P8,P9, 1P10,P11,P12,P13,P14,P15,P16,P17,P18,P19,P20) C Sched routine translated from C to Fortran by Vasicek and Beguelin. cpsu Modified for VM by S. Utter, CNSF, April 1989 cpsu Clone is presently a dummy routine External Clone INTEGER PARENT,JOBTAG,CADRS Cint *parent,*jobtag; INTEGER P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14,P15 1,P16,P17,P18,P19,P20 COMMON/INDEX /ISUBN,IPARMS INTEGER ISUBN(0:999),SNAME INTEGER IPARMS(20,0:999) C* C this procedure puts the descriptor of a schedulable process C onto the problem queue. this process will be scheduled for execution C when its data dependencies have been satisfied (indicated by icango==0). C the argument parms is a structure whose first entry is a subroutine name C and whose remaining entries are parameters appearing in the calling sequence C of that subroutine. C C the action of this procedure differs from putq in that the user does not C assign jobtags or data dependencies. a parent may spawn any number of C children but these child processes only report to the parent. C I = PARENT J = JOBTAG C bcopy(&parms, &indx[j], sizeof(struct parms));*/ cpsu ISUBN(J)= SNAME cpsu See JUMP ASSEMBLE for description CALL CTOM (SNAME, ISUBN(J)) CALL ITOP (P1 ,IPARMS(1,J)) CALL ITOP (P2 ,IPARMS(2,J)) CALL ITOP (P3 ,IPARMS(3,J)) CALL ITOP (P4 ,IPARMS(4,J)) CALL ITOP (P5 ,IPARMS(5,J)) CALL ITOP (P6 ,IPARMS(6,J)) CALL ITOP (P7 ,IPARMS(7,J)) CALL ITOP (P8 ,IPARMS(8,J)) CALL ITOP (P9 ,IPARMS(9,J)) CALL ITOP (P10 ,IPARMS(10,J)) CALL ITOP (P11 ,IPARMS(11,J)) CALL ITOP (P12 ,IPARMS(12,J)) CALL ITOP (P13 ,IPARMS(13,J)) CALL ITOP (P14 ,IPARMS(14,J)) CALL ITOP (P15 ,IPARMS(15,J)) CALL ITOP (P16 ,IPARMS(16,J)) CALL ITOP (P17 ,IPARMS(17,J)) CALL ITOP (P18 ,IPARMS(18,J)) CALL ITOP (P19 ,IPARMS(19,J)) CALL ITOP (P20 ,IPARMS(20,J)) C first the parms block is copied into the slot pointed to by C by jobtag and then this descriptor is placed on the problem C queue C cpsu The following code is for implementing recursive spawning. c I commented it out for now, because clone is a dummy routine. c If it is added, will need Vasecik's IDEN subroutine. C C IF (ISUBN(J) .EQ. IDEN(CLONE)) THEN C ISUBN(J) = ISUBN(I) C PRINT *,' RECURSIVE SPAWNING IS USED' C PRINT *,' INDEX_SNAME=',ISUBN(I) C ENDIF C if (indx[j].sname == clone) indx[j].sname = indx[i].sname; C C here we ask if this is a recursive spawning. if so the name C clone has been called instead of sname so we replace the name C clone by sname. C CALL PLACE(JOBTAG) END c************************************************************************* c************************************************************************* SUBROUTINE CLONE() C this is a dummy routine to satisfy unresolved external RETURN END c************************************************************************* c************************************************************************* subroutine lockon(i) integer i,m 1 Call Lock(i,m) If (m .eq. 2) go to 1 C Wait for lock to be off. return end c************************************************************************* c************************************************************************* subroutine lockof(i) integer i i = 0 return end c************************************************************************* c************************************************************************* subroutine name(jobtag,sname) character*6 sname C this is a dummy routine to satisfy unresolved external return end c************************************************************************* c************************************************************************* subroutine lckasn(ilock) integer ilock ilock = 0 return end %%%%%%%%%%%%%%%%%%%%%%%%%%% GSCHED FORTRAN %%%%%%%%%%%%%%%%%%%%%%%%% @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) subroutine chekin(jobtag) cpsu An Alliant directive CVD$R NOCONCUR integer jobtag c*********************************************************************** c c this subroutine reports unit of computation labeled by c jobtag has completed to all dependent nodes. these nodes are c recorded in parmq(i,jobtag) where 6 .le. i .le. nchks+5 c checkin consists of decrementing the value in each of these c locations by 1. each of these is done in a critical section c protected by qlock(ichek) c c if the value in parmq(2,ichek) is 0 where ichek is a process c dependent upon this one then ichek is placed on the readyq c by entering the critical section protected by rtlock. the c pointer rtail to the tail of the readyq is incremented c unless task done is to be recorded. task done is placed on c the ready q and the pointer rtail left in place if nchks .eq. 0 c is found. c c see the common block description in libopn for more detail. c c*********************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock c integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c a complete common block description is given in the routine libopn c c**************************************************************************** c c check to see if this process has completed. if not do not checkin c c first ask if any kids spawned by jobtag c if (parmq(4,jobtag) .ne. 0 .or. parmq(5,jobtag) .ne. 0 ) then c c either kids have been spawned or ientry has been referenced c indicating reentry is required c c c find out how many are waiting to complete c if (parmq(4,jobtag) .ne. 0) then call lockon(qlock(jobtag)) parmq(2,jobtag) = parmq(2,jobtag) - parmq(4,jobtag) call lockof(qlock(jobtag)) endif c c reset number of kids c parmq(4,jobtag) = 0 c c update the number of times this procedure has been c entered c parmq(1,jobtag) = parmq(1,jobtag) + 1 c c return without checkin if all the kids have not c checked in to jobtag yet or if a reentry is required. c process jobtag is not done in either case. c if (parmq(2,jobtag) .ne. 0 ) return c c if ientry has been called but jobtag is not waiting c on any kids then jobtag is placed back on the readyq c if ( parmq(5,jobtag) .ne. 0) then iwrkr = mod(jobtag,mxces) + 1 call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = jobtag rtail(iwrkr) = rtail(iwrkr) + 1 call lockof(trlock(iwrkr)) return endif endif c c the process has completed so chekin proceeds c call lockon(qlock(mxprcs)) if (endgrf .gt. nbuffr) call dump(endgrf,igraph) insrt = endgrf endgrf = endgrf + 1 call lockof(qlock(mxprcs)) if (jobtag .ge. intspn) then igraph(1,insrt) = 5 igraph(2,insrt) = parmq(6,jobtag) igraph(3,insrt) = jobtag igraph(4,insrt) = second(foo) else igraph(1,insrt) = 2 igraph(2,insrt) = jobtag igraph(3,insrt) = second(foo) endif c nchks = parmq(3,jobtag) c c if this is the final process (indicated by nchks .eq. 0) then c record task done. do not advance the tail so task done sequence c is set. all subsequent gtprb queries will leave rhead .eq. rtail c with readyq(rhead) .eq. done. c if (nchks .eq. 0) then do 20 iwrkr = 1,mxces call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = done call lockof(trlock(iwrkr)) return 20 continue endif do 50 j = 6,nchks+5 mychek = parmq(j,jobtag) c c get unique access to the checkin node mychek c and checkin by decrementing the appropriate counter c mchkgo = 1 call lockon(qlock(mychek)) parmq(2,mychek) = parmq(2,mychek) - 1 mchkgo = parmq(2,mychek) call lockof(qlock(mychek)) c c place mychek on readyq if parmq(2,mychek) is 0 c if (mchkgo .eq. 0 ) then iwrkr = mod(mychek,mxces) + 1 call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = mychek rtail(iwrkr) = rtail(iwrkr) + 1 call lockof(trlock(iwrkr)) endif 50 continue return c c last card of chekin c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) subroutine dep(jobtag,icango,nchks,mychkn) cpsu An Alliant directive CVD$R NOCONCUR integer jobtag,icango,nchks,mychkn(*) c************************************************************************* c c warning - this routine may only be used by driver in a static definition c of the data dependencies in the task. c c c usage c subroutine xxx() c external yyy c . c . c . c call dep(jobtag,icango,nchks,mychkn) c call putq(jobtag,yyy,) c . c . c . c c this subroutine puts data dependencies for problem on the queue. c no synchronization is necessary because each index of a column of c parmq is associated with a jobtag specified by the user and c associated with a unique unit of computation. the arguments of c dep specify a the data dependencies associated with the unit of c computation labeled by jobtag and are placed in a column of parmq c to the menue specified below. c c jobtag is an integer specifying a unique schedulable process c c c icango is a positive integer specifying how many processes must check in c to this process before it can be placed on the readyq. c c nchks is the number of processes that depend upon the completion of c this process. c c mychkn is an integer array specifying the jobtags of the processes c which depend upon completion of this process. c c************************************************************************* c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c for a complete common block description see the subroutine libopn c c c place process jobtag on the problem queue c no synchronization required to update qtail since c only one program work executes this code. c if ((jobtag .le. 0 .or. jobtag .gt. mxprcs) .or. & icango .lt. 0 .or. nchks .lt. 0) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' incorrect specification of dependencies ' write(6,*) ' all DEP parameters must be non-negative' write(6,*) ' input was ' write(6,*) ' jobtag ',jobtag ,'.... must be postitive ' write(6,*) ' but less than ',mxprcs write(6,*) ' icango ',icango write(6,*) ' nchks ',nchks write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop c endif qtail = qtail + 1 next = jobtag parmq(1,next) = 1 parmq(2,next) = icango parmq(3,next) = nchks parmq(4,next) = 0 c c check to see that exactly one node has ncheks set to 0 c if (nchks .eq. 0 .and. done .eq. 0) then done = -2 else if (nchks .eq. 0) done = 0 endif c c specify identifiers of processes which depend on this one c if there are too many abort c if (nchks .gt. nslots - 5) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' attempt to place too many dependencies ' write(6,*) ' on chekin list during call to dep ' write(6,*) ' with jobtag ',jobtag write(6,*) ' ' write(6,*) ' user tried to place ',nchks ,' dependencies ' write(6,*) ' the maximum number is ',nslots - 5 write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop c endif do 50 j = 1,nchks parmq(j+5,next) = mychkn(j) c if (mychkn(j) .le. 0) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' incorrect specification of dependencies ' write(6,*) ' all mychkn entries must be positive' write(6,*) ' input was ' write(6,*) ' mychkn(',j,') = ',mychkn(j) write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop endif c 50 continue call lockon(qlock(mxprcs)) if (endgrf .gt. nbuffr) call dump(endgrf,igraph) insrt = endgrf endgrf = endgrf + 1 call lockof(qlock(mxprcs)) igraph(1,insrt) = 0 igraph(2,insrt) = jobtag igraph(3,insrt) = icango igraph(4,insrt) = nchks do 9001 jnsrt = 6,nchks + 5 igraph(jnsrt-1,insrt) = parmq(jnsrt,next) 9001 continue c return c c last card of dep c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) integer function gtprb(id,jobtag) cpsu An Alliant directive CVD$R NOCONCUR c************************************************************************** c c this function gets unique access to the head of the readyq c pointed to by id and then claims the pointer to the next c schedulable process if there is one and returns with a nonzero c value when there is a process to schedule. if there are no entries c in the readyq indexed by id then the remaning ready ques are c polled in a round robin manner until schedulable process is found c or task done is recorded. if task done has been recorded the value c zero is returned in gtprb. if a nonzero value is returned in gtprb, c the integer jobtag will contain the identifier of the unit of c computation that is to be executed. c c input parameter c c id an integer specifying which readyq to access first c for work to do. c c output parameters c c jobtag an integer containing the next process to be executed c c gtprb the return value of this integer function is: c c 0 if task done has been posted c c nonzero if a schedulable process has been claimed. c c c*************************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c common block description: c c for a complete common block description see the routine libopn c c nspins = 0 cpsu Does this do anything? fsave = second(foo) iwrkr = id 10 continue mhead = -1 call lockon(hrlock(iwrkr)) c c gain access to head of readyq. if task done has not been recorded c then increment the head of the readyq. otherwise the head pointer c is left fixed so the next active process will receive task done. c if (rhead(iwrkr) .lt. rtail(iwrkr)) then mhead = rhead(iwrkr) rhead(iwrkr) = rhead(iwrkr) + 1 endif call lockof(hrlock(iwrkr)) if (mhead .gt. 0) then c c there was a work unit on the readyq c jobtag = readyq(mhead,iwrkr) call lockon(qlock(mxprcs)) if (endgrf .gt. nbuffr) call dump(endgrf,igraph) insrt = endgrf endgrf = endgrf + 1 call lockof(qlock(mxprcs)) if (jobtag .ge. intspn) then igraph(1,insrt) = 4 igraph(2,insrt) = parmq(6,jobtag) igraph(3,insrt) = jobtag igraph(4,insrt) = second(foo) else igraph(1,insrt) = 1 igraph(2,insrt) = jobtag igraph(3,insrt) = second(foo) endif c if (jobtag .ne. done) then c c record the subroutine call identifier in gtprb and return c the process identifier in jobtag. c gtprb = parmq(1,jobtag) if (gtprb .gt. 1 .and. parmq(5,jobtag) .eq. 0) gtprb = -1 c else c c task done has been indicated. request a return from subroutine work c by returning the value 0 in gtprb. c gtprb = 0 c endif else c jobtag = readyq(rhead(iwrkr),iwrkr) if (jobtag .eq. done) then c c task done has been posted c gtprb = 0 c else c c there was not any work on the readyq c iwrkr = mod((iwrkr+1),mxces) if (iwrkr .eq. 0) iwrkr = mxces nspins = nspins + 1 if (mod(nspins,mxces) .eq. 0) call nops go to 10 c endif endif return c c last card of gtprb c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) subroutine start2 c c this routine allows parallel processing to start after user supplied c driver has completed by unlocking the head of the readyq c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskik,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,TASKID(MXPRCS),JS(MXCES) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock logical nostrt integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c for common block description see subroutine libopn. c if (done .ne. 0) then write(6,*) '*************SCHED USER ERROR********************' if (done .eq. -1 ) then write(6,*) ' no process has set nchks equal to 0 ' else write(6,*) ' more than one process has set nchks to 0 ' endif write(6,*) ' SCHEDULE will not be able to terminate job' write(6,*) ' correctly ' write(6,*) ' ' write(6,*) ' check subroutine passed to initial call to' write(6,*) ' to see that at exactly one call to DEP has ' write(6,*) ' set nchks = 0 ' write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop endif c nostrt = .true. do 100 iwrkr = 1,mxces if (rhead(iwrkr) .ne. rtail(iwrkr)) nostrt = .false. 100 continue if (nostrt) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' no process had an intitial icango of 0 ' write(6,*) ' SCHEDULE could not begin ' write(6,*) ' ' write(6,*) ' check subroutine passed to initial call to' write(6,*) ' to see that at least one call to DEP has ' write(6,*) ' set icango = 0 ' write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop endif intspn = qtail c do 200 iwrkr = 1,mxces call lockof(hrlock(iwrkr)) 200 continue c return c c last card of start2 c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) subroutine place(jobtag) cpsu An Alliant directive CVD$R NOCONCUR integer jobtag c************************************************************************* c c c this subroutine places a problem on the readyq c c jobtag is an integer specifying a unique schedulable process c c c icango is a positive integer specifying how many processes must check in c to this process before it can be placed on the readyq. c c nchks is the number of processes that depend upon the completion of c this process. c c mchkin is an integer array specifying the jobtags of the processes c which depend upon completion of this process. c c************************************************************************* c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c for a complete common block description see the subroutine libopn c c c c place this process on readyq if icango is 0 c when icango .eq. 0 this process does not depend on any c others. c icango = parmq(2,jobtag) iwrkr = mod(jobtag,mxces) + 1 if (icango .eq. 0 ) then call lockon(trlock(iwrkr)) readyq(rtail(iwrkr),iwrkr) = jobtag rtail(iwrkr) = rtail(iwrkr) + 1 call lockof(trlock(iwrkr)) endif c c last card of place c return end c************************************************************************* c************************************************************************* real function second(t) cpsu This provides a generic timing routine for the IBM3090 real*4 t real*8 schstp MMT00240 real*4 schbeg common/schtm/schstp,schbeg cpsu RTIMER is a timing routine written at the CNSF which returns cpsu a real*8 value representing the system time-of-day clock cpsu (wall clock time). It is an assembler routine which retrieves cpsu the time using the STCK instruction. Because RTIMER is first cpsu invoked with a tstamp of 0, all timings after cpsu that are relative to the first call. if (schbeg.eq.0) then schbeg = 1 schstp = 0 endif t = RTIMER(schstp) second = t return end c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) C Sched routine translated from C to Fortran by Vasicek and Beguelin. SUBROUTINE SCHED( &NPROC,SNAME,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11 &,P12,P13,P14,P15,P16,P17,P18,P19,P20) C-- ---------Modified for MVS by D. Vasicek 7/31/87 cpsu Modified for VM by S. Utter, CNSF, April 1989 INTEGER NPROC INTEGER P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14,P15,P16,P17 1,P18,P19,P20 INTEGER SNAME INTEGER ISUBN(0:999) INTEGER IPARMS(20,0:999) COMMON/INDEX /ISUBN,IPARMS C this procedure obtains nprocs physical processors devoted C to the the execution of the parallel program indicated through parms C which is a structure whose first entry is a subroutine name and whose C remaining entries are parameters appearing in the calling sequence C of that subroutine. C C Call freopen("term","w",stdout) C Call bcopy(&parms, &indx[0], sizeof(struct parms)); cpsu See JUMP ASSEMBLE for description CALL JUMPSV ISUBN(0)= SNAME CALL ITOP (P1 ,IPARMS(1,0)) CALL ITOP (P2 ,IPARMS(2,0)) CALL ITOP (P3 ,IPARMS(3,0)) CALL ITOP (P4 ,IPARMS(4,0)) CALL ITOP (P5 ,IPARMS(5,0)) CALL ITOP (P6 ,IPARMS(6,0)) CALL ITOP (P7 ,IPARMS(7,0)) CALL ITOP (P8 ,IPARMS(8,0)) CALL ITOP (P9 ,IPARMS(9,0)) CALL ITOP (P10 ,IPARMS(10,0)) CALL ITOP (P11 ,IPARMS(11,0)) CALL ITOP (P12 ,IPARMS(12,0)) CALL ITOP (P13 ,IPARMS(13,0)) CALL ITOP (P14 ,IPARMS(14,0)) CALL ITOP (P15 ,IPARMS(15,0)) CALL ITOP (P16 ,IPARMS(16,0)) CALL ITOP (P17 ,IPARMS(17,0)) CALL ITOP (P18 ,IPARMS(18,0)) CALL ITOP (P19 ,IPARMS(19,0)) CALL ITOP (P20 ,IPARMS(20,0)) C C the subroutine name and prameter list have been copied and C placed in a special slot on the parmq C C then libopn is invoked to initialize pointers, grab physical C processors and begin the computation C CALL LIBOPN( NPROC) RETURN END c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) SUBROUTINE PUTQ( & JOBTAG,SNAME,P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11, 1P12,P13,P14,P15,P16,P17,P18,P19,P20) C Sched routine translated from C to Fortran by Vasicek and Beguelin. cpsu Modified for VM by S. Utter, CNSF, April 1989 INTEGER JOBTAG INTEGER SNAME,ISUBN(0:999) INTEGER P1 ,P2 ,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14, 1P15,P16,P17,P18,P19,P20 INTEGER IPARMS(20,0:999) COMMON/INDEX /ISUBN,IPARMS C C this procedure puts the descriptor of a schedulable process C onto the problem queue. this process will be scheduled for execution C when its data dependencies have been satisfied (indicated by icango==0). C the argument parms is a structure whose first entry is a subroutine name C and whose remaining entries are parameters appearing in the calling sequence C of that subroutine. C C register int j; INTEGER J J = JOBTAG C bcopy(&parms, &indx[j], sizeof(struct parms));*/ IF (SNAME .EQ. 0 ) THEN PRINT*,' You got problems, Jobtag = ',JOBTAG PRINT*,' Subname is blank' ENDIF cpsu ISUBN(J)= SNAME cpsu See JUMP ASSEMBLE for description CALL CTOM (SNAME, ISUBN(J)) CALL ITOP (P1 ,IPARMS(1,J)) CALL ITOP (P2 ,IPARMS(2,J)) CALL ITOP (P3 ,IPARMS(3,J)) CALL ITOP (P4 ,IPARMS(4,J)) CALL ITOP (P5 ,IPARMS(5,J)) CALL ITOP (P6 ,IPARMS(6,J)) CALL ITOP (P7 ,IPARMS(7,J)) CALL ITOP (P8 ,IPARMS(8,J)) CALL ITOP (P9 ,IPARMS(9,J)) CALL ITOP (P10 ,IPARMS(10,J)) CALL ITOP (P11 ,IPARMS(11,J)) CALL ITOP (P12 ,IPARMS(12,J)) CALL ITOP (P13 ,IPARMS(13,J)) CALL ITOP (P14 ,IPARMS(14,J)) CALL ITOP (P15 ,IPARMS(15,J)) CALL ITOP (P16 ,IPARMS(16,J)) CALL ITOP (P17 ,IPARMS(17,J)) CALL ITOP (P18 ,IPARMS(18,J)) CALL ITOP (P19 ,IPARMS(19,J)) CALL ITOP (P20 ,IPARMS(20,J)) C first the parms block is copied into the slot pointed to by C by jobtag and then this descriptor is placed on the problem C queue C CALL PLACE(JOBTAG) RETURN END c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) SUBROUTINE WORK(ID,JOBTAG) C Sched routine translated from C to Fortran by Vasicek and Beguelin. cpsu Modified for VM by S. Utter, CNSF, April 1989 INTEGER J ,JOBTAG,MYJOB,GTPRB,ID INTEGER PARMS(20) INTEGER IPARMS(20,0:999) INTEGER ISUBN(0:999) COMMON/INDEX /ISUBN,IPARMS C C C extern void start2(); C external int gtprb(); J = ID IF (J .EQ. 1) THEN C C the worker whose id is 1 will execute the subroutine passed to C sched. this subroutine executes the static data dependency graph. C this graph must have at least one node. C IF (ISUBN(0).EQ. 0 ) THEN PRINT*,' No subroutine to jump to???' PRINT*,' PARMS(J)=',(IPARMS(I,0),I=1,20) ENDIF cpsu See JUMP ASSEMBLE for description CALL JUMP(ISUBN(0), IPARMS(1,0), IPARMS(2,0), 1 IPARMS( 3,0), IPARMS( 4,0), IPARMS( 5,0), IPARMS(6,0), 2 IPARMS( 7,0), IPARMS( 8,0), IPARMS( 9,0), 3 IPARMS(10,0), IPARMS(11,0), IPARMS(12,0), 4 IPARMS(13,0), IPARMS(14,0), IPARMS(15,0), 5 IPARMS(16,0), IPARMS(17,0), IPARMS(18,0), 6 IPARMS(19,0), IPARMS(20,0)) CALL START2() ENDIF MYJOB = GTPRB(ID,JOBTAG) C while (myjob .ne. 0) 91919 CONTINUE IF(MYJOB.EQ.0) GOTO 91921 C { J = JOBTAG IF (MYJOB .LE. -1 ) THEN C reenter... simple spawning was done C all kids completed and no reentry C is required. this indicates C jobtag is all done and checkin can proceed. CALL CHEKIN(JOBTAG) MYJOB = GTPRB(ID,JOBTAG) ELSE C C call sname().......... C IF (ISUBN(J).EQ. 0 ) THEN PRINT*,' J=',J,' JOBTAG=',JOBTAG PRINT*,' No subroutine to jump to???' PRINT*,' Parms(j)=',(IPARMS(I,J),I=1,20) ENDIF CALL JUMP (ISUBN(j),IPARMS(1,J), IPARMS(2,J), 1 IPARMS( 3,J), IPARMS(4,J), IPARMS(5,J), IPARMS(6,J), 2 IPARMS( 7,J), IPARMS(8,J), IPARMS(9,J), 3 IPARMS(10,J), IPARMS(11,J), IPARMS(12,J), 4 IPARMS(13,J), IPARMS(14,J), IPARMS(15,J), 5 IPARMS(16,J), IPARMS(17,J), IPARMS(18,J), 6 IPARMS(19,J), IPARMS(20,J)) CALL CHEKIN(JOBTAG) MYJOB = GTPRB(ID,JOBTAG) ENDIF 91920 GOTO 91919 91921 CONTINUE RETURN END c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) subroutine nxtag(mypar,jobtag) cpsu An Alliant directive CVD$R NOCONCUR integer mypar,jobtag c************************************************************************* c c c this subroutine puts data dependencies for problem on the queue. c no synchronization c is necessary because each index of a column of parmq is associated c with a jobtag specified by the user and associated with a unique c schedulable process. the arguments of putq specify a process and are c placed in a column of jobq according to the menue specified in the c common block description given below. c c jobtag is an integer specifying a unique schedulable process c c c icango is a positive integer specifying how many processes must check in c to this process before it can be placed on the readyq. c c nchks is the number of processes that depend upon the completion of c this process. c c mchkin is an integer array specifying the jobtags of the processes c which depend upon completion of this process. c c************************************************************************* c parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c common block description: c c for a complete common block description see the subroutine libopn c c c c place this process on the next slot in the problem queue c call lockon(qtlock) next = qtail qtail = qtail + 1 call lockof(qtlock) c call lockon(qlock(mxprcs)) if (endgrf .gt. nbuffr) call dump(endgrf,igraph) insrt = endgrf endgrf = endgrf + 1 call lockof(qlock(mxprcs)) igraph(1,insrt) = 3 igraph(2,insrt) = mypar igraph(3,insrt) = next c if ( next .gt. mxprcs) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' user attempt to create too many processes' write(6,*) ' through dynamic spawning ' write(6,*) ' the maximum allowed is ',mxprcs write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop endif c jobtag = next parmq(1,next) = 1 parmq(2,next) = 0 parmq(3,next) = 1 parmq(6,next) = mypar c c update the icango counter of the parent process c by adding 2 to parmq(2,mypar)... prevents race condition. c add 1 to the number of kids spawned by parent mypar c call lockon(qlock(mypar)) parmq(2,mypar) = parmq(2,mypar) + 2 parmq(4,mypar) = parmq(4,mypar) + 1 call lockof(qlock(mypar)) c c set number of kids spawned by next to zero c parmq(4,next) = 0 c c c return c c last card of nxtag c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) logical function wait(jobtag,ienter) c integer jobtag,ienter c***************************************************************************** c c this routine will allow process jobtag to continue after c spawned processes have all checked in. it should only be called if c processes have been spawned by jobtag through the use of c the subroutine spawn. this routine must be used in conjunction with c subroutine prtspn. the required syntax is c c go to (1000,...,L000,...,N000), ientry(mytag,N) c 1000 continue c . c . c . c do 100 j = 1,nproc c . c . (set parameters to define spawned process) c . c call nxtag(mytag,jobtag) c call spawn(mytag,jobtag,subname,) c 100 continue c label = L c if (wait(jobtag,label)) return c L000 continue c . c . c . c c if this subroutine returns a value of .true. then the calling process c jobtag should issue a return. if a value of .false. is returned then c the calling process jobtag should resume execution at the c statement immediately following the reference to wait (ie. at L000 in c the example above. a return value .true. indicates that some spawned c process has not yet completed and checked in. a return value .false. c indicates all spawned processes have checked in. c c***************************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c c check the icango counter to see if all spawned processes (kids) c have checked in. c icango = 1 call lockon(qlock(jobtag)) icango = parmq(2,jobtag) - parmq(4,jobtag) call lockof(qlock(jobtag)) c if (icango .eq. 0) then c c all kids are done ... dont wait (ie return false) c wait = .false. c c record re_entry label where computation is to c resume after wait is complete c parmq(1,jobtag) = ienter c if (ienter .gt. parmq(5,jobtag)) then write(6,*) '*************SCHED USER ERROR*****************' write(6,*) ' executing SCHEDULE function WAIT ' write(6,*) ' return label larger than the maximum ' write(6,*) ' specified by user in call to ientry ' write(6,*) ' from process jobtag ',jobtag write(6,*) ' ' write(6,*) ' the maximum reentry number is ' write(6,*) ' ', parmq(5,jobtag) write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop endif c c set last re_entry indication (parmq(5,jobtag) = 0) c if this reentry point corresponds to last one c (recorded in parmq(5,jobtag) during call to ientry) c if (ienter .eq. parmq(5,jobtag)) parmq(5,jobtag) = 0 c else c c kids are not done c wait = .true. c c a checkin will be made so set the number of c entries to return label ienter - 1 to get c correct entry point after checkin c parmq(1,jobtag) = ienter - 1 c endif c return c c last card of wait c end c************************************************************************* c************************************************************************* @PROCESS DC(QDATA) DC(QSYNC) DC(GPHOUT) integer function ientry(jobtag,nentrs) c integer jobtag c***************************************************************************** c c this routine will allow process jobtag to continue after c spawned processes have all checked in. it should only be called if c processes have been spawned by jobtag through the use of c the subroutine spawn. c c go to (1000,2000,...,N000), ientry(jobtag,N) c 1000 continue c . c . c . c do 10 j = 1,nproc c . c . (set parameters to define spawned process) c . c call nxtag(myid,jobtag) c call spawn(myid,jobtag,subname,) c 10 continue c return c 2000 continue c . c . c . c return c N000 continue c c return c end c c this subroutine returns the number of times process jobtag c has been entered. if that number is equal to the total c number nentrs of expected reentries then parmq(5,jobtag) c is set to 0 indicating no more reentries required. c c***************************************************************************** parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c c report the entry point where process jobtag should resume c computation c if (nentrs .lt. 2) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' user call to IENTRY with number of ' write(6,*) ' labels in nentrs set less than 2 ' write(6,*) ' from process ',jobtag write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop endif ientry = parmq(1,jobtag) if (ientry .lt. nentrs) then parmq(5,jobtag) = nentrs else parmq(5,jobtag) = 0 endif c return c c last card of ientry c end c************************************************************************* c************************************************************************* subroutine dump(endgrf,igraph) parameter (nslots = 30,nbuffr = 500) integer endgrf real igraph(nslots,nbuffr) integer ievent(nslots) cpsu The file was opened in libopn. This simply attaches the unit cpsu to the current process so it can write out the buffer to the cpsu file. open(unit=3) c c this routine writes graphics output to a file c and resets endgrf to 1 c c do 100 j = 1,endgrf c write(6,15) (igraph(i,j),i = 1,nslots) c 100 continue c 15 format('dump: igraph',30f5.1) do 300 j = 1,endgrf-1 do 302 i = 1,nslots ievent(i) = igraph(i,j) 302 continue if( ievent(1) .eq. 0 ) $ write(3,301) (ievent(i),i=1,ievent(4)+4) if( ievent(1) .eq. 1 ) $ write(3,303) (ievent(i),i=1,2),igraph(3,j) if( ievent(1) .eq. 2 ) $ write(3,303) (ievent(i),i=1,2),igraph(3,j) if( ievent(1) .eq. 3 ) $ write(3,301) (ievent(i),i=1,3) if( ievent(1) .eq. 4 ) $ write(3,304) (ievent(i),i=1,3),igraph(4,j) if( ievent(1) .eq. 5 ) $ write(3,304) (ievent(i),i=1,3),igraph(4,j) 301 format(14i8) 303 format(2i8,1pe16.8) 304 format(3i8,1pe16.8) 300 continue c endgrf = 1 c return end c************************************************************************* c************************************************************************* @PROCESS DC(INDEX) SUBROUTINE SPAWN( & PARENT,JOBTAG,SNAME,P1,P2,P3,P4,P5,P6,P7,P8,P9, 1P10,P11,P12,P13,P14,P15,P16,P17,P18,P19,P20) C Sched routine translated from C to Fortran by Vasicek and Beguelin. cpsu Modified for VM by S. Utter, CNSF, April 1989 cpsu Clone is presently a dummy routine External Clone INTEGER PARENT,JOBTAG,CADRS Cint *parent,*jobtag; INTEGER P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11,P12,P13,P14,P15 1,P16,P17,P18,P19,P20 COMMON/INDEX /ISUBN,IPARMS INTEGER ISUBN(0:999),SNAME INTEGER IPARMS(20,0:999) C* C this procedure puts the descriptor of a schedulable process C onto the problem queue. this process will be scheduled for execution C when its data dependencies have been satisfied (indicated by icango==0). C the argument parms is a structure whose first entry is a subroutine name C and whose remaining entries are parameters appearing in the calling sequence C of that subroutine. C C the action of this procedure differs from putq in that the user does not C assign jobtags or data dependencies. a parent may spawn any number of C children but these child processes only report to the parent. C I = PARENT J = JOBTAG C bcopy(&parms, &indx[j], sizeof(struct parms));*/ cpsu ISUBN(J)= SNAME cpsu See JUMP ASSEMBLE for description CALL CTOM (SNAME, ISUBN(J)) CALL ITOP (P1 ,IPARMS(1,J)) CALL ITOP (P2 ,IPARMS(2,J)) CALL ITOP (P3 ,IPARMS(3,J)) CALL ITOP (P4 ,IPARMS(4,J)) CALL ITOP (P5 ,IPARMS(5,J)) CALL ITOP (P6 ,IPARMS(6,J)) CALL ITOP (P7 ,IPARMS(7,J)) CALL ITOP (P8 ,IPARMS(8,J)) CALL ITOP (P9 ,IPARMS(9,J)) CALL ITOP (P10 ,IPARMS(10,J)) CALL ITOP (P11 ,IPARMS(11,J)) CALL ITOP (P12 ,IPARMS(12,J)) CALL ITOP (P13 ,IPARMS(13,J)) CALL ITOP (P14 ,IPARMS(14,J)) CALL ITOP (P15 ,IPARMS(15,J)) CALL ITOP (P16 ,IPARMS(16,J)) CALL ITOP (P17 ,IPARMS(17,J)) CALL ITOP (P18 ,IPARMS(18,J)) CALL ITOP (P19 ,IPARMS(19,J)) CALL ITOP (P20 ,IPARMS(20,J)) C first the parms block is copied into the slot pointed to by C by jobtag and then this descriptor is placed on the problem C queue C cpsu The following code is for implementing recursive spawning. c I commented it out for now, because clone is a dummy routine. c If it is added, will need Vasecik's IDEN subroutine. C C IF (ISUBN(J) .EQ. IDEN(CLONE)) THEN C ISUBN(J) = ISUBN(I) C PRINT *,' RECURSIVE SPAWNING IS USED' C PRINT *,' INDEX_SNAME=',ISUBN(I) C ENDIF C if (indx[j].sname == clone) indx[j].sname = indx[i].sname; C C here we ask if this is a recursive spawning. if so the name C clone has been called instead of sname so we replace the name C clone by sname. C CALL PLACE(JOBTAG) END c************************************************************************* c************************************************************************* SUBROUTINE CLONE() C this is a dummy routine to satisfy unresolved external RETURN END c************************************************************************* c************************************************************************* subroutine lockon(i) integer i,m 1 Call Lock(i,m) If (m .eq. 2) go to 1 C Wait for lock to be off. return end c************************************************************************* c************************************************************************* subroutine lockof(i) integer i i = 0 return end c************************************************************************* c************************************************************************* subroutine name(jobtag,sname) character*6 sname C this is a dummy routine to satisfy unresolved external return end c************************************************************************* c************************************************************************* subroutine lckasn(ilock) integer ilock ilock = 0 return end %%%%%%%%%%%%%%%%%%%%%%%%%%% LIBOPN FORTRAN %%%%%%%%%%%%%%%%%%%%%%%%% @PROCESS DC(INDEX) DC(QDATA) DC(QSYNC) subroutine libopn(nproc) integer nproc c************************************************************************ c c this routine sets locks and initializes variables c and then spawns nproc generic work routines. c c nproc is a positive integer. care should be taken to c match nproc to the number of physical processors c available. c c************************************************************************ parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js cpsu These commons must be shared among the originated tasks integer isubn(0:999) integer iparms(20,0:999) common/index /isubn,iparms common/jumpcm/ijump cpsu This common is for timing info real*4 schbeg real*8 schstp common/schtm/schstp,schbeg cpsu These variables are used to control how many tasks will be cpsu originated if a program has multiple calls to sched logical schflg integer orgprc,prc save schflg,orgprc common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock c cgraph integer endgrf cgraph real igraph cgraph common /gphout/ endgrf,igraph(nslots,nbuffr) c integer ispace(mxces) cpsu Set sched entry flag to false initially data schflg/.false./ c c common block description: c c common/qdata/ c c parmq is a two dimensional integer array. each column of c this array represents a schedulable process. a process is c identified by its jobtag which corresponds to a unique c column of parmq. a column of parmq has the following c entries c c parmq(1,jobtag) = nentries c a nonzero integer. if process jobtag c is on the readyq then this integer c is equal to the one plus number of times c process jobtag has been entered. c thus when work executes this process c the integer is equal to the number c of times the process has been entered. c c parmq(2,jobtag) = icango c an integer specifying the number c of processes that must check in c before this process may scheduled c (ie. be placed on the ready queue) c c parmq(3,jobtag) = nchks c an integer specifying the number c of processes that this process c must checkin to. identifiers of c these processes are recorded below. c if nchks .eq. 0 then completion of c this process signifies completion of c task. c c parmq(4,jobtag) = the number of kids spawned by this c process. if this value is zero c then this process has not spawned c any subprocesses. c c parmq(5,jobtag) = entry_flag c has the value 1 if ientry was called c has the value 0 otherwise c c parmq(6:6+nchks,jobtag) is reserved for identifiers of the c nchks c processes that must wait for completion c of this process before they can execute. c c c phead pointer to head of parmq c c intspn pointer to first spawned process. all jobtags c with values greater than or equal to intspn will c be spawned processes. c c readyq a two dimensional integer array that holds the jobtags of those c processes that are ready to execute. the k-th column of c this array serves as a readyq for the k-th work routine. c on executing gtprb, the k-th work routine will look for work c in the k-th readyq first and then the others (round robin). c if readyq(j,id) .eq. done has been set then a return from c subroutine work(*,*,id) is indicated. c c rhead an integer array. the i-th entry of rhead is a pointer to the c head of the i-th column of readyq c c rtail an integer array. the i-th entry of rtail is a pointer to the c tail of the i-th column of readyq c c c common/sync/ c c qlock is an integer array of locks. there is one lock for each c column of parmq. the purpose of this lock is to ensure c unique access to a column of parmq during the checkin operation. c c hrlock is an integer lock. the purpose of this lock is to ensure c unique access to the pointer rhead to the head of the readyq. c c trlock is an integer lock. the purpose of this lock is to ensure c unique access to the pointer rtail to the tail of the readyq. c c done is a unique non positive integer set in libopn to indicate c task done. c c common /gphout/ c c endgrf is an integer pointing to the next available c slot in igraph c c igraph is a two dimensional integer array c used as a buffer for graphics output c each column of igraph records an event. c c if (nproc .gt. mxces) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' user asking for more physical processors' write(6,*) ' than are available on this system ' write(6,*) ' the maximum allowed is nproc = ',mxces write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' cgraph call dump(endgrf,igraph) stop endif c jobtag = next done = -1 c c set qlocks off c initialize readyq(*) = -1 to set done sequence c initialize reentry indicator in parmq(5,*) c do 50 j = 1,mxces hrlock(j) = 0 trlock(j) = 0 rhead(j) = 1 rtail(j) = 1 do 20 i = 1,iprcs readyq(i,j) = -1 20 continue 50 continue c do 100 j = 1,mxprcs qlock(j) = 0 parmq(5,j) = 0 100 continue c c set readyq locks off c cpsu Changed from tqlock to qtlock - I think tqlock was a typo qtlock = 0 c c initialize queue pointers c phead = 1 intspn = 1 qtail = 2 next = 1 endgrf = 1 cpsu Moved this open statement from dump to here for graph file cgraph open( file='graph',unit=3) c c set lock on pointer to head of readyq so c no process may start until all process and data dependencies c have been specified by the user supplied routine driver. c do 150 j = 1,mxces call lockon(hrlock(j)) 150 continue c c now spawn virtual processors. these generic work routines will c assume the identity of any schedulable process specified by driver. c cpsu If tasks have already been originated, only originate more if cpsu more have been requested, otherwise, just use existing tasks if (schflg) then if (nproc .le. orgprc) then prc = 0 else prc = nproc - orgprc orgprc = nproc endif else schflg = .true. orgprc = nproc prc = nproc endif cpsu An Alliant directive CVD$L CNCALL cpsu Note that if no new tasks are needed, prc will be equal to 0, cpsu meaning no new tasks will be originated. do 200 j = 1,prc cpsu This is the way tasks are originated and work scheduled in cpsu FX/FORTRAN on the Alliant. cpsu call work(j,ispace(j)) ORIGINATE ANY TASK taskid(j) 200 continue cpsu Now assign work to the originated tasks. cpsu NOTE: User common block areas must also be listed as arguments cpsu for the SHARING option. User common block names will be added cpsu as part of the SCHLINK step, then libopn will be compiled and cpsu inserted in the TEXT deck. DO NOT attempt to separately compile cpsu this routine using PFPCOMP, because it WILL NOT WORK. do 210 j = 1,nproc js(j) = j SCHEDULE TASK taskid(j), SHARING (qdata,qsync,index,jumpcm, % schtm & CALLING work(js(j),ispace(j)) 210 continue cpsu Wait for all tasks to complete, then terminate them. WAIT FOR ALL TASKS cgraph call dump(endgrf,igraph) return c c last card of libopn c end %%%%%%%%%%%%%%%%%%%%%%%%%% GLIBOPN FORTRAN %%%%%%%%%%%%%%%%%%%%%%%%% @PROCESS DC(INDEX) DC(QDATA) DC(QSYNC) DC(GPHOUT) subroutine libopn(nproc) integer nproc c************************************************************************ c c this routine sets locks and initializes variables c and then spawns nproc generic work routines. c c nproc is a positive integer. care should be taken to c match nproc to the number of physical processors c available. c c************************************************************************ parameter (mxprcs = 1000,iprcs = 120,mxces = 6,nslots = 30) parameter (nbuffr = 500) cpsu Added taskid and js for task origination and scheduling integer parmq,readyq,qlock,hrlock,trlock,phead,intspn,rhead,rtail, & done,qtail,qtlock,taskid,js cpsu These commons must be shared among the originated tasks integer isubn(0:999) integer iparms(20,0:999) common/index /isubn,iparms common/jumpcm/ijump cpsu This common is for timing info real*4 schbeg real*8 schstp common/schtm/schstp,schbeg cpsu These variables are used to control how many tasks will be cpsu originated if a program has multiple calls to sched logical schflg integer orgprc,prc save schflg,orgprc common /qdata/ parmq(nslots,mxprcs),phead,intspn, & readyq(iprcs,mxces),rhead(mxces),rtail(mxces), & qtail,taskid(mxprcs),js(mxces) common /qsync/ qlock(mxprcs),hrlock(mxces),trlock(mxces), & done,qtlock c integer endgrf real igraph common /gphout/ endgrf,igraph(nslots,nbuffr) c integer ispace(mxces) cpsu Set sched entry flag to false initially data schflg/.false./ c c common block description: c c common/qdata/ c c parmq is a two dimensional integer array. each column of c this array represents a schedulable process. a process is c identified by its jobtag which corresponds to a unique c column of parmq. a column of parmq has the following c entries c c parmq(1,jobtag) = nentries c a nonzero integer. if process jobtag c is on the readyq then this integer c is equal to the one plus number of times c process jobtag has been entered. c thus when work executes this process c the integer is equal to the number c of times the process has been entered. c c parmq(2,jobtag) = icango c an integer specifying the number c of processes that must check in c before this process may scheduled c (ie. be placed on the ready queue) c c parmq(3,jobtag) = nchks c an integer specifying the number c of processes that this process c must checkin to. identifiers of c these processes are recorded below. c if nchks .eq. 0 then completion of c this process signifies completion of c task. c c parmq(4,jobtag) = the number of kids spawned by this c process. if this value is zero c then this process has not spawned c any subprocesses. c c parmq(5,jobtag) = entry_flag c has the value 1 if ientry was called c has the value 0 otherwise c c parmq(6:6+nchks,jobtag) is reserved for identifiers of the c nchks c processes that must wait for completion c of this process before they can execute. c c c phead pointer to head of parmq c c intspn pointer to first spawned process. all jobtags c with values greater than or equal to intspn will c be spawned processes. c c readyq a two dimensional integer array that holds the jobtags of those c processes that are ready to execute. the k-th column of c this array serves as a readyq for the k-th work routine. c on executing gtprb, the k-th work routine will look for work c in the k-th readyq first and then the others (round robin). c if readyq(j,id) .eq. done has been set then a return from c subroutine work(*,*,id) is indicated. c c rhead an integer array. the i-th entry of rhead is a pointer to the c head of the i-th column of readyq c c rtail an integer array. the i-th entry of rtail is a pointer to the c tail of the i-th column of readyq c c c common/sync/ c c qlock is an integer array of locks. there is one lock for each c column of parmq. the purpose of this lock is to ensure c unique access to a column of parmq during the checkin operation. c c hrlock is an integer lock. the purpose of this lock is to ensure c unique access to the pointer rhead to the head of the readyq. c c trlock is an integer lock. the purpose of this lock is to ensure c unique access to the pointer rtail to the tail of the readyq. c c done is a unique non positive integer set in libopn to indicate c task done. c c common /gphout/ c c endgrf is an integer pointing to the next available c slot in igraph c c igraph is a two dimensional integer array c used as a buffer for graphics output c each column of igraph records an event. c c if (nproc .gt. mxces) then write(6,*) '*************SCHED USER ERROR********************' write(6,*) ' user asking for more physical processors' write(6,*) ' than are available on this system ' write(6,*) ' the maximum allowed is nproc = ',mxces write(6,*) ' ' write(6,*) ' EXECUTION TERMINATED BY SCHED ' call dump(endgrf,igraph) stop endif c jobtag = next done = -1 c c set qlocks off c initialize readyq(*) = -1 to set done sequence c initialize reentry indicator in parmq(5,*) c do 50 j = 1,mxces hrlock(j) = 0 trlock(j) = 0 rhead(j) = 1 rtail(j) = 1 do 20 i = 1,iprcs readyq(i,j) = -1 20 continue 50 continue c do 100 j = 1,mxprcs qlock(j) = 0 parmq(5,j) = 0 100 continue c c set readyq locks off c cpsu Changed from tqlock to qtlock - I think tqlock was a typo qtlock = 0 c c initialize queue pointers c phead = 1 intspn = 1 qtail = 2 next = 1 endgrf = 1 cpsu Moved this open statement from dump to here for graph file open( file='graph',unit=3) c c set lock on pointer to head of readyq so c no process may start until all process and data dependencies c have been specified by the user supplied routine driver. c do 150 j = 1,mxces call lockon(hrlock(j)) 150 continue c c now spawn virtual processors. these generic work routines will c assume the identity of any schedulable process specified by driver. c cpsu If tasks have already been originated, only originate more if cpsu more have been requested, otherwise, just use existing tasks if (schflg) then if (nproc .le. orgprc) then prc = 0 else prc = nproc - orgprc orgprc = nproc endif else schflg = .true. orgprc = nproc prc = nproc endif cpsu An Alliant directive CVD$L CNCALL cpsu Note that if no new tasks are needed, prc will be equal to 0, cpsu meaning no new tasks will be originated. do 200 j = 1,prc cpsu This is the way tasks are originated and work scheduled in cpsu FX/FORTRAN on the Alliant. cpsu call work(j,ispace(j)) ORIGINATE ANY TASK taskid(j) 200 continue cpsu Now assign work to the originated tasks. cpsu NOTE: User common block areas must also be listed as arguments cpsu for the SHARING option. User common block names will be added cpsu as part of the SCHLINK step, then libopn will be compiled and cpsu inserted in the TEXT deck. DO NOT attempt to separately compile cpsu this routine using PFPCOMP, because it WILL NOT WORK. do 210 j = 1,nproc js(j) = j SCHEDULE TASK taskid(j), SHARING (qdata,qsync,index,jumpcm, % gphout,schtm & CALLING work(js(j),ispace(j)) 210 continue cpsu Wait for all tasks to complete, then terminate them. WAIT FOR ALL TASKS call dump(endgrf,igraph) return c c last card of libopn c end Here are the Assembler routines: %%%%%%%%%%%%%%%%%%%%%% JUMPXA ASSEMBLE %%%%%%%%%%%%%%%%%%%%%%%%%%%%% *---------------------------------------------------------------------* * CREATED BY RICK EWING ON 7/8/87 * * MODIFIED BY D. VASICEK 7/9/87 * * THIS SUBROUTINE BRANCHES TO THE ADDRESS SENT IN THE PARM LIST * * USE: CALL JUMP(ADDRESS-OF-SUBROUTINE, ARG-LIST) * * TO EXECUTE THE SUBROUTINE AT THE ADDRESS AND PASS IT THE * * ARG-LIST. (SEE CRON 87190ART0110 FOR TEST PROGRAM.) * * * * THIS PROGRAM WAS CREATED BY REQUEST OF DAN VASICEK. * * * * Modified for VM by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * *---------------------------------------------------------------------* SPACE JUMP AMODE 31 SPACE JUMP CSECT SAVE (14,12),T,* Save callers registers LR R12,R15 Copy our address USING JUMP,R12 ESTABLISH ADDRESSABILITY LA R15,JUMPSAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area EJECT L R7,0(,R1) R7 contains address of subroutine TM 0(R1),X'80' Is this the only parm? BO CALLSUB Yes LA R1,4(,R1) Reset R1 to point to parameter list LR R2,R1 R2 will bump though the parm list SPACE 1 *---------------------------------------------------------------------* * Change parm list from pointers to pointers to pointers * *---------------------------------------------------------------------* SPACE 1 LOOP DS 0H L R3,0(,R2) R3 has addr of addr of variable TM 0(R3),X'80' test of end of list, branch later L R4,0(,R3) R4 has addr of variable ST R4,0(,R2) Store in original parm list BO LOOPEND End of parm list - branch above LA R2,4(,R2) No - bump to next parm B LOOP ...loop SPACE 1 LOOPEND DS 0H OI 0(R2),X'80' Reset end-of-parms flag EJECT *---------------------------------------------------------------------* * Added for VM by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * Calculate the address of the routine and transfer to it * *---------------------------------------------------------------------* SPACE CALLSUB DS 0H L R3,=V(JUMPCM) PICKUP ADDRESS OF COMMON BLOCK USING JUMPCM,R3 ADDRESS INTO COMMON LR R15,R12 GET A COPY OF OUR ENTRY ADDRESS S R15,AJUMP CALCULATE BASE OFFSET TO OUR IMAGE A R15,0(R7) AND ADD ADDRESS OF TARGET SUBROUTINE BASR R14,R15 Branch to the subroutine SPACE L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12,R3 Drop addressability EJECT *---------------------------------------------------------------------* * Added for VM by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * JUMPSV - Saves the address of the JUMP entrypoint in the common * * block. This is later used to find the offset between the main * * routine's copy of JUMP and the currently executing copy which is * * then added to the entry point being called to insure that the * * correct copy is executed. * *---------------------------------------------------------------------* ENTRY JUMPSV JUMPSV DS 0H SAVE (14,12),T,JUMPSV Save callers registers LR R12,R15 Copy our address USING JUMPSV,R12 Establish addressability LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE 1 L R3,=V(JUMPCM) PICKUP ADDRESS OF COMMON BLOCK USING JUMPCM,R3 ADDRESS INTO COMMON SPACE 1 MVC AJUMP,=A(JUMP) SAVE ADDRESS OF JUMP SPACE 1 L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12,R3 Drop addressability EJECT *---------------------------------------------------------------------* * Added for VM by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * CTOM - converts address of subroutine in an processors copy of * * of the module to an address of the subroutine in main copy. * * CTOM(SNAME,ISUBN(j)); * *---------------------------------------------------------------------* SPACE ENTRY CTOM CTOM DS 0H SAVE (14,12),T,CTOM Save callers registers LR R12,R15 Copy our address USING CTOM,R12 ESTABLISH ADDRESSABILITY LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE 1 L R3,=V(JUMPCM) Pickup address of common block USING JUMPCM,R3 Establish addressability of common SPACE L R2,0(,R1) Pickup pointer to pointer L R2,0(,R2) Pickup pointer to subroutine S R2,=V(JUMP) Make relative to entry point A R2,AJUMP Make relative to main routine L R4,4(,R1) Pickup address of variable ST R2,0(,R4) Save in user's variable SPACE L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12,R3 Drop addressability EJECT *---------------------------------------------------------------------* * Modified for VM by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * Use: Call Itop(I,P) places the address of I in the integer P. * * (See Cron 87190ART0110 for a test program for this routine.) * * * * THIS IS A PROGRAM was created to store the address of the first * * argument into the second argument by request of Dan Vasicek. * * * *---------------------------------------------------------------------* SPACE ENTRY ITOP ITOP DS 0H SAVE (14,12),T,ITOP Save callers registers LR R12,R15 Copy our address USING ITOP,R12 ESTABLISH ADDRESSABILITY LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE L R7,0(R1) LOAD IN ADDRESS OF first arg L R6,4(R1) LOAD IN ADDRESS OF 2nd arg ST R7,0(R6) STORE ADDRESS OF 1st arg into 2nd SPACE L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12 Drop addressability EJECT *---------------------------------------------------------------------* * CREATED BY D. Vasicek 7/15/87 * * Modified by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * To impliment the test and set function * * THIS SUBROUTINE DOES NOT MAKE ANY CALLS * * Use: Call Lock(i,m) Tests I, if I is unavailable (x'FF') then m = 2,* * If I is available then I is set to ('FF') and m = 1 * *---------------------------------------------------------------------* SPACE ENTRY LOCK LOCK DS 0H SAVE (14,12),T,LOCK Save callers registers LR R12,R15 Copy our address USING LOCK,R12 ESTABLISH ADDRESSABILITY LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE 1 L R7,0(R1) LOAD IN ADDRESS OF first arg L R6,4(R1) LOAD IN ADDRESS OF 2nd arg LA R5,1 Assume success, set return code TS 0(R7) Test and Set value at address in R7 BZ LOCKST LA R5,2 Load 2 into R5 LOCKST ST R5,0(R6) Store 2 in 2nd arg SPACE 1 L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12 Drop addressability EJECT *---------------------------------------------------------------------* * Modified by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * NOPS - wait a bit * *---------------------------------------------------------------------* SPACE ENTRY NOPS NOPS DS 0H SAVE (14,12),T,NOPS Save callers registers LR R12,R15 Copy our address USING NOPS,R12 ESTABLISH ADDRESSABILITY LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE 1 LA R1,132 Pickup count of times to loop NOPSLP NOP 0 Wait a tiny bit BCT R1,NOPSLP And repeat till done SPACE L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12 Drop addressability EJECT *---------------------------------------------------------------------* * Save area and literals * *---------------------------------------------------------------------* SPACE JUMPSAVE DS 18F Save area for dispatching routine SAVE DS 18F Save area for all others SPACE 1 LTORG EJECT *---------------------------------------------------------------------* * Common block used to save the address of the main copy of JUMP * *---------------------------------------------------------------------* SPACE JUMPCM COM AJUMP DS A(0) EJECT *---------------------------------------------------------------------* * Machine register equates * *---------------------------------------------------------------------* SPACE REGEQU END %%%%%%%%%%%%%%%%%%%%%% RTIMER ASSEMBLE %%%%%%%%%%%%%%%%%%%%%%%%%%%%% TITLE 'RTIMER - Real TIMe Elapsed since a Read timestamp' * --------------------------------------------------------------------* * RTIMER can be used as a real*4 or real*8 function from within VS or * * a Parallel Fortran program. It returns the current wallclock time * * in seconds, elapsed since an initial timestamp. * * * * Syntax: * * * * RTIMER ( < t_stamp > ) * * * * where t_stamp is an optional real*8 parameter for a timestamp. If * * you dont provide one, RTIMER uses an internal timestamp. If you * * don't provide a timestamp, or if you set t_stamp to zero, the first * * invocation of RTIMER initializes the timestamp (either its internal * * one or yours) to the time of day TOD clock. Upon subsequent calls * * to RTIMER, the value returned is the elapsed wallclock time since * * the initial timestamp. If you provide your own timestamp with a * * non-zero value, it must contain a value expressed in seconds. The * * value returned from RTIMER has a resolution of a microsecond if * * used as a double precision function; when used as a single * * precision function it has the same resolution, but begins to loose * * accuracy for elapsed times greater than a million seconds (about 12 * * days). * * * *---------------------------------------------------------------------* * Usage notes: * * * * 1. When used with PF or any other parallel Fortran application which* * replicates code , each copy of RTIMER will have its own internal * * "timestamp" if you do not provide one. If the first invocation of* * RTIMER occurrs after the code replication (as it does with PF in * * PFPLINK EXEC by default), invocations of RTIMER are independent * * for each copy of RTIMER (for each parallel task in the case of * * PF). If you want to have a common timestamp for elapsed times * * within PF tasks you must make t_stamp a shared variable. * * * * 2. RTIMER provides good resolution even when used as a real*4 * * function. Note that TOD can only be used as a real*8 function. * * If you use RTIMER as a real*4 function and provide a non-zero * * timestamp, you must make sure that it is long enough to meet * * your required accuracy. * * * * 3. Elapsed time can be easily converted to its rounded integer * * value by using an assignment like the following: * * * * isec = RTIMER() + .5 * * * * 4. RTIMER can be used to measure elapsed time since a previous * * invocation, as follows: * * * * t_stmp = 0D0 * * clock = rtimer(t_stmp) /* for first invocation */ * * . . . * * t_stmp = t_stmp + clock /* for every next invocation */ * * clock = RTIMER(t_stmp) * * * * Note that the last two lines are NOT equal to * * * * clock = RTIMER (t_stpm + clock) * * * * Do you understand why? * *---------------------------------------------------------------------* * * * MODULE NAME - RTIMER * * * * DESCRIPTION - see above * * * * STATUS - NEW, APRIL 25, 1989 * * * * - LAST REVISION, MAY 05, 1989 * * * * DEPENDENCIES - NONE * * * * INPUT - NONE * * * * OUTPUT - TIME IN SECONDS SINCE THE FIRST REFERENCE, * * (SEE THE DESCRIPTION ABOVE) * * * * * * * * MODULE TYPE - PROCEDURE. * * * * PROCESSOR - ASSEMBLER H, VERSION 2, RELEASE 1 * * * * LIBRARY - MACLIB OSMACRO (ASSELIBS at Cornell) * * * * ATTRIBUTES - SERIALLY REUSABLE * * * * ENTRY POINT - RTIMER * * * * ERRORS - ? * * * * 05/07/88 Valery I. Garger, Technology Integration * * Group, CNSF, TC, Cornell University * *-------------------------------------------------------------------- * * Change log: not yet. * * Last revision: 05-11-89 / 11.30.00 * * ------------------------------------------------------------------- * RTIMER RMODE ANY RTIMER AMODE ANY *RTIMER BEGIN DATE=/05-11-89/version_1.7/ RTIMER CSECT USING RTIMER,15 B 34(,15) DC AL1(6+22) DC CL6'RTIMER' DC CL22'/05-11-89/version_1.7/' STM 14,12,12(13) CNOP 0,4 BAS 2,*+76 $$SA001 DC 18F'0' ST 2,8(,13) ST 13,4(,2) LR 13,2 USING $$SA001,13 DROP 15 R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 STCK TOD LM R10,R11,TOD SRDL R10,12 STM R10,R11,TOD MVI TOD,X'4E' LTR R1,R1 BZ SELF L R2,00(,R1) B CHECK IF SAVED SELF LA R2,BEF CHECK DS 0H CLC 00(8,R2),=D'0' BZ FIRSTENT LD R0,TOD DD R0,=D'1000000.' SD R0,00(,R2) B EXIT * -------------------------------- FIRSTENT DS 0H SDR R0,R0 AD R0,TOD DD R0,=D'1000000.' STD R0,00(,R2) SDR R0,R0 * _____________________________ EXIT L R13,4(R13) RETURN (14,12),,RC=0 RESTORE THE REGISTERS * ----------------------------------------------------------------- TOD DC D'0' BEF DC D'0' END RTIMER e address of I in the integer P. * * (See Cron 87190ART0110 for a test program for this routine.) * * * * THIS IS A PROGRAM was created to store the address of the first * * argument into the second argument by request of Dan Vasicek. * * * *---------------------------------------------------------------------* SPACE ENTRY ITOP ITOP DS 0H SAVE (14,12),T,ITOP Save callers registers LR R12,R15 Copy our address USING ITOP,R12 ESTABLISH ADDRESSABILITY LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE L R7,0(R1) LOAD IN ADDRESS OF first arg L R6,4(R1) LOAD IN ADDRESS OF 2nd arg ST R7,0(R6) STORE ADDRESS OF 1st arg into 2nd SPACE L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12 Drop addressability EJECT *---------------------------------------------------------------------* * CREATED BY D. Vasicek 7/15/87 * * Modified by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * To impliment the test and set function * * THIS SUBROUTINE DOES NOT MAKE ANY CALLS * * Use: Call Lock(i,m) Tests I, if I is unavailable (x'FF') then m = 2,* * If I is available then I is set to ('FF') and m = 1 * *---------------------------------------------------------------------* SPACE ENTRY LOCK LOCK DS 0H SAVE (14,12),T,LOCK Save callers registers LR R12,R15 Copy our address USING LOCK,R12 ESTABLISH ADDRESSABILITY LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE 1 L R7,0(R1) LOAD IN ADDRESS OF first arg L R6,4(R1) LOAD IN ADDRESS OF 2nd arg LA R5,1 Assume success, set return code TS 0(R7) Test and Set value at address in R7 BZ LOCKST LA R5,2 Load 2 into R5 LOCKST ST R5,0(R6) Store 2 in 2nd arg SPACE 1 L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12 Drop addressability EJECT *---------------------------------------------------------------------* * Modified by Jeff Honig, Cornell Theory Center/CNSF, * * April, 1989 * * * * NOPS - wait a bit * *---------------------------------------------------------------------* SPACE ENTRY NOPS NOPS DS 0H SAVE (14,12),T,NOPS Save callers registers LR R12,R15 Copy our address USING NOPS,R12 ESTABLISH ADDRESSABILITY LA R15,SAVE Pickup address of our save area ST R13,4(,R15) Save address of calling save area ST R15,8(,R13) Save address of called save area LR R13,R15 Point to our save area SPACE 1 LA R1,132 Pickup count of times to loop NOPSLP NOP 0 Wait a tiny bit BCT R1,NOPSLP And repeat till done SPACE L R13,4(,R13) RESTORE CALLER'S REGISTERS RETURN (14,12),T,RC=0 Return from whence SPACE DROP R12 Drop addressability EJECT *---------------------------------------------------------------------* * Save area and literals * *---------------------------------------------------------------------* SPACE JUMPSAVE DS 18F Save area for dispatching routine SAVE DS 18F Save area for all others SPACE 1 LTORG EJECT *---------------------------------------------------------------------* * Common block used to save the address of the main copy of JUMP * *---------------------------------------------------------------------* SPACE JUMPCM COM AJUMP DS A(0) EJECT *---------------------------------------------------------------------* * Machine register equates * *---------------------------------------------------------------------* SPACE REGEQU END %%%%%%%%%%%%%%%%%%%%%% RTIMER ASSEMBLE %%%%%%%%%%%%%%%%%%%%%%%%%%%%% TITLE 'RTIMER - Real TIMe Elapsed since a Read timestamp' * --------------------------------------------------------------------* * RTIMER can be used as a real*4 or real*8 function from within VS or * * a Parallel Fortran program. It returns the current wallclock time * * in seconds, elapsed since an initial timestamp. * * * * Syntax: * * * * RTIMER ( < t_stamp > ) * * * * where t_stamp is an optional real*8 parameter for a timestamp. If * * you dont provide one, RTIMER uses an internal timestamp. If you * * don't provide a timestamp, or if you set t_stamp to zero, the first * * invocation of RTIMER initializes the timestamp (either its internal * * one or yours) to the time of day TOD clock. Upon subsequent calls * * to RTIMER, the value returned is the elapsed wallclock time since * * the initial timestamp. If you provide your own timestamp with a * * non-zero value, it must contain a value expressed in seconds. The * * value returned from RTIMER has a resolution of a microsecond if * * used as a double precision function; when used as a single * * precision function it has the same resolution, but begins to loose * * accuracy for elapsed times greater than a million seconds (about 12 * * days). * * * *---------------------------------------------------------------------* * Usage notes: * * * * 1. When used with PF or any other parallel Fortran application which* * replicates code , each copy of RTIMER will have its own internal * * "timestamp" if you do not provide one. If the first invocation of* * RTIMER occurrs after the code replication (as it does with PF in * * PFPLINK EXEC by default), invocations of RTIMER are independent * * for each copy of RTIMER (for each parallel task in the case of * * PF). If you want to have a common timestamp for elapsed times * * within PF tasks you must make t_stamp a shared variable. * * * * 2. RTIMER provides good resolution even when used as a real*4 * * function. Note that TOD can only be used as a real*8 function. * * If you use RTIMER as a real*4 function and provide a non-zero * * timestamp, you must make sure that it is long enough to meet * * your required accuracy. * * * * 3. Elapsed time can be easily converted to its rounded integer * * value by using an assignment like the following: * * * * isec = RTIMER() + .5 * * * * 4. RTIMER can be used to measure elapsed time since a previous * * invocation, as follows: * * * * t_stmp = 0D0 * * clock = rtimer(t_stmp) /* for first invocation */ * * . . . * * t_stmp = t_stmp + clock /* for every next invocation */ * * clock = RTIMER(t_stmp) * * * * Note that the last two lines are NOT equal to * * * * clock = RTIMER (t_stpm + clock) * * * * Do you understand why? * *---------------------------------------------------------------------* * * * MODULE NAME - RTIMER * * * * DESCRIPTION - see above * * * * STATUS - NEW, APRIL 25, 1989 * * * * - LAST REVISION, MAY 05, 1989 * * * * DEPENDENCIES - NONE * * * * INPUT - NONE * * * * OUTPUT - TIME IN SECONDS SINCE THE FIRST REFERENCE, * * (SEE THE DESCRIPTION ABOVE) * * * * * * * * MODULE TYPE - PROCEDURE. * * * * PROCESSOR - ASSEMBLER H, VERSION 2, RELEASE 1 * * * * LIBRARY - MACLIB OSMACRO (ASSELIBS at Cornell) * * * * ATTRIBUTES - SERIALLY REUSABLE * * * * ENTRY POINT - RTIMER * * * * ERRORS - ? * * * * 05/07/88 Valery I. Garger, Technology Integration * * Group, CNSF, TC, Cornell University * *-------------------------------------------------------------------- * * Change log: not yet. * * Last revision: 05-11-89 / 11.30.00 * * ------------------------------------------------------------------- * RTIMER RMODE ANY RTIMER AMODE ANY *RTIMER BEGIN DATE=/05-11-89/version_1.7/ RTIMER CSECT USING RTIMER,15 B 34(,15) DC AL1(6+22) DC CL6'RTIMER' DC CL22'/05-11-89/version_1.7/' STM 14,12,12(13) CNOP 0,4 BAS 2,*+76 $$SA001 DC 18F'0' ST 2,8(,13) ST 13,4(,2) LR 13,2 USING $$SA001,13 DROP 15 R0 EQU 0 R1 EQU 1 R2 EQU 2 R3 EQU 3 R4 EQU 4 R5 EQU 5 R6 EQU 6 R7 EQU 7 R8 EQU 8 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 STCK TOD LM R10,R11,TOD SRDL R10,12 STM R10,R11,TOD MVI TOD,X'4E' LTR R1,R1 BZ SELF L R2,00(,R1) B CHECK IF SAVED SELF LA R2,BEF CHECK DS 0H CLC 00(8,R2),=D'0' BZ FIRSTENT LD R0,TOD DD R0,=D'1000000.' SD R0,00(,R2) B EXIT * -------------------------------- FIRSTENT DS 0H SDR R0,R0 AD R0,TOD DD R0,=D'1000000.' STD R0,00(,R2) SDR R0,R0 * _____________________________ EXIT L R13,4(R13) RETURN (14,12),,RC=0 RESTORE THE REGISTERS * ----------------------------------------------------------------- TOD DC D'0' BEF DC D'0' END RTIMER Here are the REXX execs: %%%%%%%%%%%%%%%%%%%% SCHCOMP EXEC %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /********************************************************************/ /* SCHCOMP EXEC - Created 3-22-89 by Sue Utter (PSU), CNSF */ /********************************************************************/ /* Exec to read a user's SCHEDULE'ized Fortran program to pull out */ /* user common block names then compile using PFPCOMP. */ /* Common block names are stored in a file called fn COMMONS A */ /* with each name being on a separate line, preceded by a blank. */ /* If the source code contains no named commons, then the COMMONS */ /* file contains the string '%NOCOMMON' at col. 1, line 1. */ /********************************************************************/ /* Modifications: */ /* 10-6-89 Corrected bugs involving large numbers of commons */ /* Commons initialized in BLOCKDATA inits will not be */ /* made dynamic (would produce a compilation error) */ /* Done by marking commons non-dynamic by annotating */ /* an asterisk to the beginning of the name */ /* Corrected REXX error involving checking return codes */ /* after function calls */ /********************************************************************/ address command arg fn ft fm "(" parms /* Make sure file to be compiled is there */ if fn = "" then do say say "Command format is: SCHCOMP fn {ft fm (options)}" say " (ft is FORTRAN by default; fm is A by default)" exit end if ft ^== "FORTRAN" then if ft = "" then ft = "FORTRAN" else do say say "Invalid filetype: " ft exit end /* If file exists, captures fm so can store COMMONS file on same disk as FORTRAN file. If file doesn't exist, reports error and exits */ "MAKEBUF" "LISTFILE" fn "FORTRAN * (STACK" if rc = 0 then do pull . . fm fm = strip(fm) fm = substr(fm,1,1) end else do say say "File" fn ft "not found" exit end "DROPBUF" eflag = 0 blockdataflag = 0 /* Check to see if PARALLEL option specifiec */ if pos('PAR',parms) ^= 0 then do eflag = 1 say say "The PARALLEL compiler option is illegal for the", "SCHCOMP command. " end /* Check to see if FREE option specifiec */ if pos('FREE',parms) ^= 0 then do eflag = 1 say say "The FREE compiler option is illegal for the SCHCOMP command. " end /* if option errors, leave */ if eflag then exit /* erase old output file, if any */ call quiet "ERASE" fn "COMMONS" fm if RESULT = 0 | RESULT = 28 then nop else do say say "Unexpected return code" rc "from ERASE" fn "COMMONS" fm exit end "MAKEBUF" commons = "" dcstring = "DC(" "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc /* while not EOF do */ do while eof^=2 upper inline /* translate to upper case */ /* first test to see if initial line is a comment or blank line */ if substr(inline,1,1) ^= 'C' & substr(inline,1,1) ^= '*' &, inline ^= " " then do /* initial line is not a comment or blank line */ /* strip out blanks */ temp = "" do i = 1 by 1 while i <= words(inline) temp = temp || word(inline,i) end inline = temp /* if block data statement, set flag to prevent dynamic commons */ if pos('BLOCKDATA',inline) ^= 0 then if pos('!',inline) = 0 |, pos('!',inline) > pos('BLOCKDATA',inline) then do /* BLOCK DATA initialization */ blockdataflag = 1 "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end /* if in block data, check for end */ if blockdataflag then do temp = substr(inline,1,3) if temp == 'END' then do /* end of BLOCK DATA */ blockdataflag = 0 "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end end /* check for possibility of a COMMON statement */ if pos('COMMON',inline) = 0 then do /* not a COMMON statement */ "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end else do /* this line may be a COMMON statement */ /* strip off inline comments */ if pos('!',inline) = 0 then /* no inline comments */ nop else do if pos('!',inline) > 1 then /* inline comment present */ inline = substr(inline,1,pos('!',inline) - 1) else /* line contains nothing but inline comment */ do "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end end /* check for ' mark - COMMON statements can't have them */ if pos('''',inline) = 0 then do /* this is a COMMON statement */ line = inline "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc /* add any continuation lines */ do while eof^= 2 & substr(inline,6,1) ^= ' ' &, substr(inline,6,1) ^= '0' upper inline /* translate to upper case */ /* is new line a comment? */ if substr(inline,1,1) ^= 'C' &, substr(inline,1,1) ^= '*' &, inline ^= " " then do /* new line is continuation line */ inline = substr(inline,7,66) /* strip out blanks */ temp = "" do i = 1 by 1 while i <= words(inline) temp = temp || word(inline,i) end inline = temp /* strip off inline comments */ if pos('!',inline) = 0 then /* none */ nop else do if pos('!',inline) > 1 then /* present */ inline = substr(inline,1,pos('!',inline) - 1) else /* inline comment only */ do "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end end line = line || inline "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end else /* new line is a comment, not a continuation */ do "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end end /* pull out COMMON names */ do while pos('/',line) ^= 0 line = substr(line,pos('/',line) + 1) name = substr(line,1,pos('/',line) - 1) line = substr(line,pos('/',line) + 1) /* don't add null name */ if name ^== "" then found = 0 else found = 1 /* add to list if not already there */ do i = 1 by 1 while i <= words(commons) & ^found oldname = word(commons,i) if substr(oldname,1,1) ^= '*' then if name == oldname then /* common already exists */ do found = 1 if blockdataflag then do /* if already listed common now appears in */ /* BLOCKDATA init, mark it non-dynamic */ temp1 = substr(commons,1,, pos(oldname,commons)-1) temp2 = substr(commons,, length(temp1)+length(oldname)+1) commons = temp1 || '*' || name || temp2 /* must also remove it from dcstring */ if pos(oldname,dcstring) ^= 0 then do temp1 = substr(dcstring,1,, pos(oldname,dcstring)-1) temp2 = substr(dcstring,, pos(oldname,dcstring)) if pos(',',temp2)^=length(temp2) then temp2=substr(temp2,pos(',',temp2)+1) else temp2 = "" dcstring = temp1 || temp2 end end end else nop else /* common already marked non-dynamic */ if name == substr(oldname,2) then found = 1 end if ^found then /* add to commons string */ if ^blockdataflag then do commons = commons || name || ' ' dcstring = dcstring || name || ',' end else /* common in BLOCKDATA init, mark non-dynamic */ commons = commons || '*' || name || ' ' end end else do /* this is not a COMMON statement */ "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end end end else do /* initial line is a comment or blank line */ "EXECIO 1 DISKR" fn ft fm "(VAR INLINE" eof = rc iterate end end if commons ^= "" then /* write common names to COMMONS file */ do i = 1 by 1 while i <= words(commons) "EXECIO 1 DISKW" fn "COMMONS" fm "(STRING" word(commons,i) end /* if no common names, make file anyway and put in nocommons symbol */ /* nocommons symbol - %NOCOMMON */ else "EXECIO 1 DISKW" fn "COMMONS" fm "(STRING" '%NOCOMMON' /* Clean up */ "DROPBUF" "FINIS" fn ft fm /* Make final adjustments to dcstring */ if dcstring ^= "DC(" then dcstring = substr(dcstring,1,length(dcstring)-1) || ')' else dcstring = "" address cms /* Now compile the source file */ "PFPCOMP" fn '(' || dcstring || parms exit /*------------------------------------------------------------*/ /* QUIET */ /*------------------------------------------------------------*/ /* Subroutine to issue a CMS command without displaying */ /* a message on the screen. */ /* */ /* The first argument is the command to be executed. */ /*------------------------------------------------------------*/ QUIET: "SET CMSTYPE HT" ''arg(1) /* The null string prevents ARG from being treated*/ /* as an instruction. */ rcsave = rc "SET CMSTYPE RT" return rcsave %%%%%%%%%%%%%%%%%%%% SCHGLOB EXEC %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /********************************************************************/ /* SCHGLOB EXEC - Created 4-18-89 by Sue Utter (PSU), CNSF */ /********************************************************************/ /* Exec to global libraries. Does nothing but pass the list of */ /* libraries to PFPGLOB. */ /********************************************************************/ /* Modifications: */ /********************************************************************/ arg libraries "PFPGLOB" libraries exit %%%%%%%%%%%%%%%%%%%% SCHLINK EXEC %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /********************************************************************/ /* SCHLINK EXEC - Created 3-23-89 by Sue Utter (PSU), CNSF */ /********************************************************************/ /* Exec to prepare an executable SCHEDULE program from user text */ /* files, user text libraries, the SCHEDULE library routines, and */ /* parallel Fortran libraries. */ /* User COMMON block names must be inserted into the SCHEDULE code */ /* responsible for ORIGINATE'ing tasks and then the code compiled */ /* before it can be linked. */ /********************************************************************/ /* Modifications: */ /********************************************************************/ /* 10-6-89 Corrected bugs involving large numbers of commons */ /* Commons initialized in BLOCKDATA inits will not be */ /* made dynamic (would produce a compilation error) */ /* Done by marking commons non-dynamic by annotating */ /* an asterisk to the beginning of the name */ /* Corrected REXX error involving checking return codes */ /* after function calls */ /* Remove temp files if left from previous links */ /********************************************************************/ address command arg loadlib tfiles '(' option ')' /* Make sure at least loadlib is there */ if loadlib = "" then do say say "Command format is: SCHLINK loadlib {text1 text2...}", "{(TRACE)}" exit end /* The default SCHEDULE text files to be linked to are the ones */ /* without the trace statements */ sched = 'SCHED' libopn = 'LIBOPN' /* Check for valid option */ if option ^="" then if option = 'TRACE' then do sched = 'GSCHED' libopn = 'GLIBOPN' end else do say say "Invalid option specified: " '(' || option say " Only valid option is TRACE." exit end /* Clean up any old temp files */ call CLEANUP "$SCHTEMP FILE A" call CLEANUP "$LIBOPN * A" call CLEANUP "$" || loadlib "TEXT A" /* if only one tfile with same name as loadlib... */ if tfiles = "" then tfiles = loadlib tempflag = 0 commons = "" textlist = "" /* Process all tfiles */ do i = 1 by 1 while i <= words(tfiles) fn = word(tfiles,i) /* is there a text file by this name? */ call quiet "STATE" fn "TEXT *" if RESULT ^= 0 then do say say "File" fn "TEXT not found" exit end /* since text file exists, add to list for PFPCOPY statement */ textlist = textlist || fn || ' ' /* does fn have a corresponding COMMONS file? */ call quiet "STATE" fn "COMMONS *" if RESULT ^= 0 then do say say "WARNING: No COMMONS file for" fn say " May produce unpredictable or erroneous results if" say " named COMMON blocks are used to share data." iterate end /* if this is the first commons file, don't have to */ /* check for duplicates */ if i=1 then do "EXECIO 1 DISKR" fn "COMMONS (VAR NAME" eof = rc if name = '%NOCOMMON' then iterate do while eof ^= 2 name = strip(name) commons = commons || name || ' ' "EXECIO 1 DISKR" fn "COMMONS (VAR NAME" eof = rc end end else do "EXECIO 1 DISKR" fn "COMMONS (VAR NAME" eof = rc if name = '%NOCOMMON' then iterate do while eof ^= 2 name = strip(name) found = 0 /* see if name already in commons list; if not, add */ do j = 1 by 1 while j <= words(commons) & ^found /* if no marker, add one and check for match */ if pos('*',name) == 0 then do tname = '*' || name if name == word(commons,j) | tname == word(commons,j) then found = 1 end else /* if marker, does it match with commons entry as is? */ if name == word(commons,j) then found = 1 else /* marker, but didn't match, so try with marker off */ do tname = substr(name,2) /* if it matches, must add marker to commons entry */ if tname == word(commons,j) then /* mark as non-dynamic */ do found = 1 temp1 = substr(commons,1,pos(tname,commons)-1) temp2 = substr(commons,pos(tname,commons)) commons = temp1 || '*' || temp2 end end end if ^found then commons = commons || name || ' ' "EXECIO 1 DISKR" fn "COMMONS (VAR NAME" eof = rc end end end /* now insert commons into libopn SCHEDULE routine */ /* The % markes where in the file the lines should be inserted. */ /* All inserted lines should have # in col. 6. */ dcstring = "DC(" if commons ^=="" then do line = ' #,' do i = 1 by 1 while i <= words(commons) name = word(commons,i) /* if marked non-dynamic, remove mark */ if substr(name,1,1) == '*' then name = substr(name,2) else /* if dynamic, can add to dcstring */ dcstring = dcstring || name || ',' /* add filled line to libopn */ /* and start new one */ if length(name) + 1 + length(line) >= 71 then do "EXECIO 1 DISKW $SCHTEMP FILE A (STRING" line line = ' #' end line = line || name || ',' end line = substr(line,1,length(line) - 1) || '),' "EXECIO 1 DISKW $SCHTEMP FILE A (STRING" line end else do line = ' #),' "EXECIO 1 DISKW $SCHTEMP FILE A (STRING" line end "MAKEBUF" signal on error queue "LOCATE /%/" queue "GET $SCHTEMP FILE A" queue "FILE $LIBOPN FORTRAN A" call QUIET "XEDIT" libopn "FORTRAN (NOPROFILE" signal off error "DROPBUF" /* Make final adjustments to dcstring */ if dcstring ^= "DC(" then dcstring = substr(dcstring,1,length(dcstring)-1) || ')' else dcstring = "" address cms /* Compile personalized version of libopn SCHEDULE routine */ call QUIET "PFPCOMP $LIBOPN" "(PAR(LANG) OPT(3)" dcstring ")" if RESULT > 4 then do say "SCHLINK not successful - problem in INSERT step" say "Report error to systems operator" exit end /* now combine all text files needed into one */ call QUIET "PFPCOPY" "$" || loadlib textlist "$LIBOPN" sched, "JUMPXA RTIMER" if RESULT < 5 then do "PFPLINK" loadlib "$" || loadlib "$" || loadlib /* Clean up */ "ERASE $SCHTEMP FILE A" "ERASE $LIBOPN * A" "ERASE" "$" || loadlib "TEXT A" end else do say "SCHLINK not successful - problem in PFPCOPY step" exit end exit /*------------------------------------------------------------*/ /* QUIET */ /*------------------------------------------------------------*/ /* Subroutine to issue a CMS command without displaying */ /* a message on the screen. */ /* */ /* The first argument is the command to be executed. */ /*------------------------------------------------------------*/ QUIET: "SET CMSTYPE HT" ''arg(1) /* The null string prevents ARG from being treated*/ /* as an instruction. */ rcsave = rc "SET CMSTYPE RT" return rcsave /* ERROR */ /*----------------------------------------------------------------*/ /* Upon system error, this drops the buffer and, if a temp disk */ /* was successfully accessed, releases it. */ /*----------------------------------------------------------------*/ ERROR: rcsave = rc "DROPBUF" exit rcsave /* CLEANUP */ /*----------------------------------------------------------------*/ /* Removes the file listed as an argument. */ /*----------------------------------------------------------------*/ CLEANUP: /* erase old file, if any */ call QUIET "ERASE" arg(1) if RESULT = 0 | RESULT = 28 then nop else do say say "Unexpected return code" RESULT, "from CLEANUP of temp file " arg(1) exit end return %%%%%%%%%%%%%%%%%%%% SCHEXEC EXEC %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% /********************************************************************/ /* SCHEXEC EXEC - Created 3-28-89 by Sue Utter (PSU), CNSF */ /********************************************************************/ /* Exec to run the TEXT loadlib created from SCHLINK. */ /* Does nothing but check to see if TEXT file exists, then runs the */ /* parallel Fortran PFPEXEC exec. Allows the same options as */ /* PFPEXEC, but does no checking to make sure they're valid. */ /********************************************************************/ /* Modifications: */ /********************************************************************/ address command arg loadlib options /* Make sure at least loadlib is there */ if loadlib = "" then do say say "Command format is: SCHEXEC loadlib options" exit end /* is there a text file by this name? */ call quiet "STATE" loadlib "TEXT *" if RESULT ^= 0 then do say say "File" loadlib "TEXT not found" exit end address cms "PFPEXEC" loadlib options exit /*------------------------------------------------------------*/ /* QUIET */ /*------------------------------------------------------------*/ /* Subroutine to issue a CMS command without displaying */ /* a message on the screen. */ /* */ /* The first argument is the command to be executed. */ /*------------------------------------------------------------*/ QUIET: "SET CMSTYPE HT" ''arg(1) /* The null string prevents ARG from being treated*/ /* as an instruction. */ rcsave = rc "SET CMSTYPE RT" return rcsave