From 9fba0a4b33b56d0c8e991de64bb40b33b4a4e912 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juli=C3=A1n=20D=2E=20Ot=C3=A1lvaro?= Date: Tue, 24 Mar 2026 20:44:35 +0000 Subject: [PATCH 1/4] fix(bestdose) variance is calculated using the post_prob --- src/bestdose/bestdose.for | 29946 ++++++++++++++++++++++++++++++++++++ src/bestdose/cost.rs | 2 +- 2 files changed, 29947 insertions(+), 1 deletion(-) create mode 100644 src/bestdose/bestdose.for diff --git a/src/bestdose/bestdose.for b/src/bestdose/bestdose.for new file mode 100644 index 000000000..832091a1d --- /dev/null +++ b/src/bestdose/bestdose.for @@ -0,0 +1,29946 @@ +C BESTDOS121.FOR 6/10/16 + +C BESTDOS121 HAS THE FOLLOWING CHANGES FROM BESTDOS120: + +C THIS PROGRAM IS NOW COMPATIBLE WITH THE NEW "DENSITY OCT_15" +C DENSITY FILE MADE BY THE NEW NPAG PROGRAM (NPAG120.FOR/npagranfix6.f) +C WHICH HAS NRANFIX PARAMETERS. + +C THE CHANGES NECESSARY ARE IN READING IN THE POTENTIAL NRANFIX +C PARAMETER NAMES AND VALUES IN THE NPAGDENFILE. THEN THESE VALUES, +C WHICH WERE ESTIMATED IN THE ORIGINAL NPAG RUN, ARE TREATED JUST THE +C SAME AS THE FIXED PARAMETER VALUES WHICH FIXED IN THE NPAG RUN. + +C----------------------------------------------------------------------- + +C BESTDOS120.FOR 2/19/16 + +C BESTDOS120 HAS ONE SMALL CHANGE FROM BESTDOS119. IN THE CODE BELOW +C FORMAT 8133 IN MAIN, THE CONTINGENCY ON IPRIOR IS REMOVED. THIS +C SHOULD HAVE BEEN DONE IN BESTDOS105.FOR, WHEN IPRIOR WAS NO LONGER +C READ IN, BUT THE EFFECT WAS THE SAME SINCE IF IPRIOR = 0 (WHICH IS +C THE DEFAULT FOR NON-INITIALIZED VARIABLES IN MOST COMPILERS), IERRMOD +C IS WRITTEN TO FILE 24 AS IT SHOULD BE. BUT BECAUSE SOME OPERATING +C SYSTEMS/COMPILERS MAY ASSIGN RANDOM NOS. TO VARIABLES WHICH ARE NOT +C INITIALIZED, IT IS POSSIBLE THAT IPRIOR COULD BE SET TO SOMETHING +C NON-0, WHICH WOULD MEAN THAT IERRMOD WOULD NOT BE WRITTEN TO FILE 24. +C SO THIS CHANGE WILL REMOVE THAT POSSIBLE BUG. NOTE THAT IPRIOR IS +C ALSO REMOVED AS A CALLING ARGUMENT TO SUBROUTINE VERIF1. + +C----------------------------------------------------------------------- + +C BESTDOS119.FOR 7/7/14 + +C BESTDOS119 HAS THE FOLLOWING CHANGES FROM BESTDOS118: + +C 1. THIS PROGRAM NOW ALLOWS STEADY STATE DOSING IN THE "PAST" (NOT +C THE FUTURE). THIS REQUIRES: + +C MODULE IDM1X14.FOR IS UPDATED TO IDM1X15.FOR, WHICH HAS JUST A +C COUPLE OF SMALL CHANGES FROM IDM1X15.F (WHICH IS ALREADY USED IN THE +C NPAG "ENGINE"). + +C MODULE IDM3X141.FOR IS UPDATED TO IDM3X151.FOR, WHICH IS +C SIMILAR TO IDM3X15.F (WHICH IS ALREADY USED IN THE NPAG "ENGINE"), +C BUT WITH THE CHANGE THAT IDM3X141.FOR MADE TO IDM3X14.FOR, +C (DIMENSIONS OF 71281 CHANGED TO 72000). + +C MODULE CALCBST14.FOR IS UPDATED TO CALCBST15.FOR. + +C MODULE NPAGFULL.FOR IS UPDATED TO BE NPAGFULLA.FOR. + +C MODULE NPAGFULL11.FOR IS UPDATED TO BE NPAGFULLA11.FOR. + +C FORMAT 1416 IS EDITED TO INDICATE THAT STEADY STATE DOSE SETS AT THE +C BEGINNING OF THE PATIENT FILE ARE ALLOWED. BUT NOT DOSE OR TIME +C RESETS. AND A NEW CHECK IS PUT IN SUBROUTINE READBLOCK2 TO DISALLOW +C IDEVENT = 4 (DOSE RESETS). + +C NOTE THAT SUBROUTINE CALCTPRED IS MODIFIED TO REALLOW STEADY STATE +C DOSE SETS (THE CODE TO ALLOW THESE SETS WAS REMOVED AS OF +C BESTDOS109.FOR). AND THE SAME IS TRUE FOR SUBROUTINE CALCTPRED2. + + +C 2. JUST BEFORE THE FIRST CALL FILRED(..) STATEMENT, SUBROUTINE +C NEWWORK1 IS CALLED TO READ THE PATIENT DATA FROM FILE 27, AND +C CONVERT IT TO PATIENT DATA ON FILE 37, WITH EACH STEADY STATE DOSE +C INDICATOR RESULTING IN AN EXTRA 100 DOSE SETS (WITH THE NEGATIVE DOSE +C TIME LEFT IN - SEE COMMENTS BELOW).NOTE THAT THIS SUBROUTINE NEWWORK1 +C IS THE SAME AS IN THE CURRENT NPAG "ENGINE" MODULE, npageng25.f, +C EXCEPT IT READS FILE 27 AND WRITES TO FILE 37, RATHER THAN READING +C FROM FILE 23 AND WRITING TO FILE 27; ARRAY TIMOBREL IS NOT +C ESTABLISHED IN NEWWORK1, AND NOT PASSED AS AN ARGUMENT (IT IS NOT +C NEEDED IN THIS PROGRAM); MAXSUB IS ALSO NOT PASSED AS AN +C ARGUMENT (IT IS NOT NEEDED); NSUB IS NOT PASSED AS AN ARGUMENT (IT +C IS NOT NEEDED); AND COMMON/DOSEOBS AND THE ARRAYS IN IT ARE DELETED +C (THEY ARE NOT NEEDED). + +C NOTE THAT THIS NEWWORK1 ROUTINE IS INCLUDED IN THE NPAGFULLA.FOR +C MODULE, AS IS SUBROUTINE ORDERDELTA. + + +C 3. SUBROUTINE MAKETMP NOW RETURNS ND42 RATHER THAN ND41. THE REASON +C IS THAT IF THE PATIENT FILE HAS STEADY STATE DOSING, ND41 WILL +C CHANGE AFTER NEW SUBROUTINE NEWWORK1 (SEE CHANGE 2. ABOVE) IS CALLED +C (I.E., THERE WILL BE A LOT MORE DOSES IN THE "PAST"), BUT ND42 WILL +C NOT (THERE ARE NO STEADY STATE DOSES IN THE "FUTURE"). +C SO ND41 AND NDD41 ARE NOW ESTABLISHED AFTER NEWWORK1 IS CALLED, +C IN THE CASE THAT INCLUDPAST = 1. + + +C 4. SUBROUTINE FILRED IS CHANGED TO READ FILE 37, RATHER THAN +C FILE 27. + + +C 5. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN +C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx +C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING +C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT +C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT +C USING COMMON/ERROR/ERRFIL. + +C NOTE THAT CODE TO READ extnum TO GET THE 4-DIGIT JOB NUMBER IS +C ADDED ALSO TO THE 'GUICMDS.INX' CODE, JUST AFTER PATH IS READ IN, +C BECAUSE ERRFIL MAY HAVE TO BE WRITTEN TO DURING THAT PART OF THE +C CODE ALSO. + + +C 6. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, +C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET +C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED +C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT +C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS +C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL +C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 +C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO +C MAXNUMEQ. + + +C 7. SUBROUTINE DETECT, AND THE ROUTINES IT CALLS, ARE REMOVED FROM +C THE CODE. NOTE IN THE COMMENTS TO BESTDOS8.FOR, DETECT AND THE +C ROUTINE IT CALLED WERE NO LONGER NEEDED, BUT WERE LEFT IN THIS FILE +C IN CASE THEY WERE NEEDED IN THE FUTURE. BUT IF THAT SHOULD OCCUR, +C THESE ROUTINES CAN BE COPIED BACK IN FROM PROGRAM BESTDOS118.FOR. + + +C 8. A BUG IS FIXED IN SUBROUTINE WSUMSQ IN NEW MODULE CALCBST15.FOR. +C IT WAS IN THE IF(ITARGET .EQ. 2) PORTION OF THE CODE. AUC IS NO +C LONGER SET BACK TO 0 IF TPRED(I) = TNEXT ... SINCE AUCs ARE +C CUMULATIVE FROM TIME 0 IN THE "PAST", AS OF BESTDOS118.FOR. THIS +C BUG EXISTED ONLY IN BESTDOS118.FOR. + + +C 9. SUBROUTINE PUTORDER2 IS REMOVED; INSTEAD SUBROUTINE CALCTPRED2 +C WILL CALL PUTORDER, WHICH HAS THE SAME CODE (AT ONE POINT, THESE +C TWO ROUTINES HAD A DIFFERENT DIMENSION FOR XX, BUT THIS IS NO +C LONGER TRUE; AND SO PUTORDER2 BECAME REDUNDANT). + + +C 10. ALL REFERENCES TO THE TEMPLATE MODEL FILE TSTMULTK.FOR ARE +C REPLACED BY TSTMULTM.FOR. + +C----------------------------------------------------------------------- + +C BESTDOS118.FOR 11/13/13 + + +C BESTDOS118 HAS THE FOLLOWING CHANGE TO BESTDOS117: + +C THE CODE IN MAIN CHANGES SO THAT THE AUCs WRITTEN TO DOSEROUTxxxx +C WILL BE CUMULATIVE AUCs FROM TIME 0 IN THE "PAST", RATHER THAN BE +C RESET TO 0 AT TNEXT (= TIME 0 IN THE "FUTURE"). BUT NOTE THAT THE +C CODE IN WSUMSQ (IN CALCBST14.FOR) IS UNCHANGED, SO THAT AUCs IN THE +C "FUTURE" ARE STILL ASSUMED TO BE RELATIVE TO THE BEGINNING OF THE +C "FUTURE", AND ARE RESET TO 0 AT TIME TNEXT. + +C----------------------------------------------------------------------- + +C BESTDOS117.FOR 11/4/13 + +C BESTDOS117 HAS THE FOLLOWING CHANGES TO BESTDOS116: + +C 1. IT HAS A BUG FIX TO BESTDOS116. BELOW THE 2ND CALL TO ELDERY, +C JUST ABOVE WHERE THE DOSEROUTxxxx FILE IS ESTABLISHED, FILE 27 IS +C REWOUND AND FILRED IS CALLED AGAIN. THIS IS DONE TO RE-ESTABLISH THE +C ORIGINAL DOSE VALUES INTO THE RS(.,.) ARRAY. THE REASON IS THAT +C ELDERY CALLS CALCS, WHICH CALLS WSUMSQ, WHICH SETS THE RS(.,.) VALUES +C TO THE CURRENT CANDIDATES SUPPLIED BY ELDERY. AND IF THESE VALUES +C HAPPEN TO BE SET = 0, THEN THE CODE TO WRITE OUT THE OPTIMAL DOSES +C IN MAIN (WHICH DEPEND ON RS(I,2*J-1) OR RS(I,2*J) BEING > 0 TO +C IDENTIFY AN IV OR A BOLUS, RESPECTIVELY) WILL NOT BE ENGAGED. AND +C THEN THE #OPTIMAL DOSES LINE WILL BE FOLLOWED BY NO DOSES AT ALL. +C IN ADDITION, THE CODE TO ESTABLISH THE BEST DOSES INTO RS(.,.) FOR +C THE PURPOSE OF WRITING THE PREDICTED VALUES FOR THESE BEST DOSES, +C FOR EACH GRID PT. IN THE PARAMETER DENSITY, WILL NOT BE ENGAGED +C EITHER. + +C 2. THE NAME "XLAM" IS CHANGED TO BIASWEIGHT TO REMOVE ANY +C CONFUSION WITH LAMBDA, WHICH IS A TERM USED IN THE ASSAY ERROR +C FUNCTION. SIMILARLY, IN THE OUTPUT FILE, "LAMDA" IS CHANGED TO +C "BIASWEIGHT". + +C 3. THE SAME "XLAM" TO "BIASWEIGHT" CHANGE IS MADE IN THE NEW +C CALCBST14.FOR (WHICH REPLACES CALCBST13.FOR). + + +C----------------------------------------------------------------------- + +C BESTDOS116.FOR 10/16/13 + +C BESTDOS116 HAS THE FOLLOWING CHANGES TO BESTDOS115: + +C IF THE USER SELECTS ITARGET = 2 (SEE BELOW), THE AUCs NOW WILL BE +C RELATIVE TO TIME 0 IN THE "FUTURE", AS OPPOSED TO TIME 0 IN THE +C "PAST". + +C THIS REQUIRES CHANGES IN THE CODE IN MAIN, AND IN SUBROUTINE +C WSUMSQ. IN EACH CASE, THE AUC AT TIME TNEXT (WHICH IS THE BEGINNING +C TIME FOR THE "FUTURE") IS RESET BACK TO 0. + +C NOTE ALSO THAT TNEXT IS NOW INCLUDED IN COMMON/TOSUMSQ, SO THAT +C IT CAN BE ADDED TO THE TIMES WHICH ARE ESTABLISHED BY ROUTINES +C CALCTPRED AND CALCTPRED2. + +C NOTE THAT THIS PROGRAM IS NOW LINKED WITH CALCBST13.FOR, WHICH IS +C UPDATED FROM CALCBST12.FOR. + +C----------------------------------------------------------------------- + +C BESTDOS115.FOR 10/6/13 + +C BESTDOS115 HAS THE FOLLOWING CHANGES TO BESTDOS114: + +C 1. IN ADDITION TO USING CONCENTRATIONS (OBSERVED VALUES) AS TARGETS, +C NOW THE USER WILL BE ABLE TO TARGET AUCs ALSO. + +C THIS WILL REQUIRE A NEW INPUT VALUE, ITARGET. IF ITARGET = 1, THE +C TARGETS WILL BE CONCENTRATIONS, AS THEY HAVE BEEN IN PREVIOUS +C PROGRAMS. IF ITARGET = 2, THE TARGETS WILL BE AUCs. NOTE THAT EVEN IF +C THE TARGETS ARE AUCs, THESE VALUES WILL STILL BE READ IN BY THE +C PROGRAM IN THE SAME LOCATIONS (AS IF THEY WERE CONCENTRATIONS IN THE +C PATIENT DATA FILE). + +C BECAUSE THE INSTRUCTION FILE WILL HAVE THE ADDITIONAL ITARGET ENTRY, +C IT WILL ALSO HAVE A NEW CODE, BESTDOS OCT_13. + +C 2. THERE WILL BE EXTENSIVE CHANGES IN SUBROUTINES CALCS AND WSUMSQ +C IN CALCBST12.FOR (UPDATED FROM CALCBST11.FOR). ALSO, THIS MODULE +C HAS NEW SUBOUTINES CALCTPRED2 AND PUTORDER2. + +C 3. NOTE THAT ARRAYS WEIGHT, PREDMIN2, DENSITY2, AND DOSEBEST2 +C HAVE BEEN REMOVED. WEIGHT WAS NOT NEEDED AFTER BESTDOS114.FOR, +C AND THE OTHER 3 ARRAYS WERE NEVER NEEDED. + +C 4. TO MAKE DIMENSIONS CONSISTENT, ALL 24000'S HAVE BEEN CHANGED TO +C 72000'S. AND ALL 71281'S HAVE BEEN CHANGED TO 72000 ALSO (THIS HAS +C ALSO BEEN DONE IN CALCBST12.FOR). SIMILARLY, ALL 7200'S HAVE BEEN +C CHANGED TO 72000'S. THE REASON TO LIMIT NUMT IN CALCTPRED TO 7200 +C WAS A HOLDOVER FROM THE npageng24.f PROGRAM, AND IS NOT APPLICABLE +C IN THIS PROGRAM. + +C 5. THIS PROGRAM IS NOW LINKED WITH IDM3X141.FOR, UPDATED FROM + +C DM3X14.FOR. THE DIFFERENCE IS THAT THE NEW MODULE HAS ALL ITS +C 71281 DIMENSIONS CHANGED TO 72000, TO BE COMPATIBLE WITH CHANGE +C 4. ABOVE. + +C 6. NOTE THAT XLAM HAS BEEN MOVED IN FRONT OF THE INTEGER ARGUMENTS +C IN COMMON/TOCALC TO AVOID A WARNING WHEN THIS PROGRAM IS COMPILED +C WITH gfortran. + +C----------------------------------------------------------------------- + +C BESTDOS114.FOR 9/27/13 + + +C BESTDOS114 HAS THE FOLLOWING CHANGES TO BESTDOS113: + +C 1. IT WILL NOW BE COMPILED WITH CALCBST11.FOR, UPDATED FROM +C CALCBST10.FOR. THE MAIN CHANGE IN SUBROUTINE CALCS IS THAT THE +C COST FUNCTION WILL NOW INVOLVE THE OLD COST FUNCTION (MEAN SQUARED +C ERROR), PLUS A NEW BIAS TERM. THESE TWO TERMS WILL BE WEIGHTED BY +C XLAM (USER SPECIFIED) WHICH WILL MULTIPLY THE BIAS TERM (AND 1-XLAM) +C WILL MULTIPLY THE MEAN SQUARED ERROR TERM. + +C NOTE THAT SINCE THE USER NOW ENTERS XLAM, THERE WILL BE A NEW +C INSTRUCTION FILE, WITH A NEW CODE, BESTDOS SEP_13. AND NOTE THAT +C XLAM IS PROVIDED TO SUBROUTINE CALCS VIA COMMON/TOCALC. + +C NOTE THAT BOTH TERMS IN THE COST FUNCTION ARE NOW ALSO WRITTEN INTO +C DOSEROUTxxxx. + +C 2. THE MEAN SQUARED ERROR TERM WILL HAVE WEIGHT(.,.) REMOVED FROM +C IT. I.E., COST FUNCTION WILL NO LONGER BE A FUNCTION OF THE ASSAY +C COEFFICIENTS. SO WEIGHT IS NOW REMOVED FROM COMMON/TOCALC. + +C 3. INSTEAD OF CALCULATING THE WEIGHTED MEAN OF THE GRID PTS. AND +C CALCULATING THE Y's AND AUC's FOR THAT SINGLE GRID PT., AS THE LAST +C PART TO BE PUT INTO DOSEROUTxxxx, NOW THE WEIGHTED MEAN OF THE +C Y's AND AUC's OVER ALL THE GRID PTS. WILL BE PUT INTO DOSEROUTxxxx. +C THIS IS MORE CONSISTENT WITH THE BIAS TERM CALCULATED IN SUBROUTINE +C CALCS. + +C----------------------------------------------------------------------- + +C BESTDOS113.FOR 8/26/13 + +C BESTDOS113 COMBINES THE CHANGE OF BESTDOS112A WITH THE ORIGINAL +C BESTDOS112. IN PARTICULAR, THIS PROGRAM WILL CALL SUBROUTINE ELDERY +C TWICE, ONCE WITH ALL THE POSTERIOR GRID PTS. HAVING EQUAL +C PROBABILITY (AS IN BESTDOS112), AND ONCE WITH THE POSTERIOR GRID PTS. +C HAVING THEIR VALUES FROM THE 0-CYCLE RUN IN NPAGFULL1. THEN, THE +C ELDERY CALL WHICH PRODUCES THE MIN SUM OF SQUARES WILL BE USED TO +C ESTABLISH THE BEST DOSES. + +C REF: SEE THE EXAMPLE WITH MODEL3.FOR (COMMENTS UNDER 9.) IN +C \ALAN3\BAYARD\SIMSTUDY\SIMSTUDY.EXP. + +C----------------------------------------------------------------------- + + +C BESTDOS112A.FOR 8/18/13 + +C BESTDOS112A HAS ONE CHANGE TO BESTDOS112. AFTER THE RETURN FROM +C SUBROUTINE NPAGFULL, CORDEN(.,NVAR+1) IS NOT RESET. IT WILL NOW +C RETAIN ITS VALUE FROM WHAT IT WAS ON RETURN FROM NPAGFULL1. THE +C REASON IS THAT THE DENSITY VALUES FROM NPAGFULL1 ACCURATELY REFLECT +C HOW IMPORTANT EACH DAUGHTER PT. SHOULD BE IN THE CALL TO ELDERY +C (THE WAY IT WAS DONE IN BESTDOS112.FOR, ALL THE GRID PTS. ENDED +C UP WITH EQUAL PROBABILITY). + +C----------------------------------------------------------------------- + +C BESTDOS112.FOR 8/6/13 + +C BESTDOS112 HAS THE FOLLOWING CHANGES TO BESTDOS111. + +C IT HAS AN EXTENDED PROCESS TO OBTAIN THE POSTERIOR DENSITY TO MAKE IT +C MORE LIKELY THAT THERE WILL BE MORE THAN 1 PT. IN IT. INSTEAD OF +C JUST CALLING NPAGFULL, WHICH ALWAYS RETURNS THE SINGLE BEST POINT +C WHICH IS COMPATIBLE WITH THE "PAST", THIS PROGRAM DOES A 2-STEP +C PROCESS: + +C 1. IT CALLS NPAGFULL11, WHICH RETURNS ALL GRID PTS. FROM THE +C ORIGINAL PRIOR DENSITY WHICH ARE ARE REASONABLY COMPATIBLE WITH THE +C "PAST" (I.E., THOSE WHOSE PROBABILITIES ARE WITHIN 1.D-100 OF THE +C BEST GRID PT.). + +C 2. FOR EACH OF THE GRID PTS. IN 1., IT CALLS NPAGFULL TO OBTAIN +C THE SINGLE DAUGHTER PT. WHICH IS BEST. + +C THE RESULT THEN WILL BE A POSTERIOR CONSISTING OF THE BEST DAUGHTER +C POINT FOR EVERY GRID PT. WHICH SHOWED UP IN STEP 1. + +C----------------------------------------------------------------------- + +C BESTDOS111.FOR 5/23/13 + +C BESTDOS111 HAS THE FOLLOWING CHANGES TO BESTDOS110: + +C 1. IT GIVES THE USER THE OPTION OF NOT CALCULATING THE BEST DOSES +C TO MINIMIZE THE EXPECTED WEIGHTED SUM OF SQUARES OF DIFFERENCES +C BETWEEN OBSERVED AND TARGET CONCENTRATIONS, AND INSTEAD SIMPLY USING +C THE DOSES INCLUDED IN THE "FUTURE" FILE. I.E., WHEN ELDERY IS CALLED, +C THE DOSES IN THE "FUTURE" FILE ARE INITIAL GUESSES FOR THE DOSES TO +C BE USED BY ELDERY IN ITS OPTIMIZATION. BUT IF THE STEP(.) VALUES ARE +C SET = 0, THERE WILL BE NO OPTIMIZATION, AND THE STARTING DOSES WILL +C BE THE DESIRED DOSES TO BE USED. + +C 2. ADDITONAL INFORMATION IS ADDED TO THE DOSEROUTxxxx OUTPUT FILE. +C THE PARAMETER VALUES FOR EACH OF THE GRID POINTS USED FOR THE +C CALCULATION OF THE OBSERVED VALUES IS NOW INCLUDED.` + +C 3. IN SUBROUTINE AFTERCOMMA, OPEN(57) IS REPLACED BY +C OPEN(57, FILE='FILE57JUNK'). THE REASON IS THAT WHEN THIS PROGRAM IS +C COMPILED/LINKED WITH gfortran, IT RANDOMLY PRODUCES AN ERROR RELATED +C TO BEING UNABLE TO OPEN FILE 57. OPENING 57 AS A NAMED FILE MAY + +C REDUCE OR ELIMINATE THIS ERROR. + + +C----------------------------------------------------------------------- + +C BESTDOS110.FOR 5/14/13 + +C BESTDOS110 HAS ONE CHANGE FROM BESTDOS109. IN BESTDOS109, THE BLOCK + +C OF PREDICTED (SIMULATED) VALUES AND AUCs INCLUDED ALL THE DOSE +C AND OBSERVATION TIMES THAT WERE IN BOTHFILES.ZPJ (IF THERE WAS A +C "PAST" HISTORY), OR THE DOSE AND OBSERVATION TIMES IN THE "FUTURE" +C IF THERE WAS NO PAST HISTORY. EITHER WAY, THE OBSERVATION TIMES OF +C THE "PAST" WERE NOT INCLUDED. IN BESTDOS110, HOWEVER, THE +C OBSERVATION TIMES FROM THE "PAST" WILL ALSO BE INCLUDED IN THE +C SIMULATED VALUES. THIS REQUIRED CHANGES IN MAIN, MAKETMP, AND +C CALCTPRED, WHERE VALUES FOR M41 (AND TIM41(.)) ARE NOW SHARED. + +C----------------------------------------------------------------------- + +C BESTDOS109.FOR 5/12/13 + +C BESTDOS109 HAS THE FOLLOWING CHANGE TO BESTDOS108: + +C IN EACH BLOCK OF PREDICTED VALUES AND AUCs WHICH ARE WRITTEN TO THE +C OUTPUT FILE, DOSEROUTxxxx, EXTRA LINES OF DATA ARE ADDED AS NEEDED TO +C MAKE SURE THAT THE TIMES INCLUDE ALL OBSERVATION TIMES AND ALL DOSE +C TIMES. LOTS OF CODE CHANGES ARE MADE IN SUBROUTINE CALCTPRED, AND +C IN MAIN WHERE THESE VALUES ARE WRITTEN TO THE OUTPUT FILE. + +C NOTE THAT ALL THE CODE RELATED TO STEADY STATE DOSE SETS, AND TIME +C RESETS HAS NOW BEEN REMOVED FROM THIS PROGRAM. + + +C----------------------------------------------------------------------- + +C BESTDOS108.FOR 4/24/13 + +C BESTDOS108 HAS THE FOLLOWING CHANGES TO BESTDOS107: + +C 1. CORDLAST IS DIMENSIONED AS AN ARRAY IN THIS MODULE. SINCE IT IS AN +C ARGUMENT TO NPAGFULL, WHERE IT IS DIMENSIONED, IT SHOULD ALSO BE +C DIMENSIONED IN THIS MODULE. SINCE NO INFORMATION IS PASSED BETWEEN +C THE TWO MODULES (IT IS ONLY PASSED AS AN ARGUMENT SO IT CAN BE +C VARIABLY DIMENSIONED0, THIS OVERSIGHT DID NOT CAUSE A PROBLEM WHEN +C THIS PROGRAM WAS COMPILED/LINKED BY LAHEY FORTRAN; BUT IT DOES CAUSE +C A PROBLEM WHEN gfortran COMPILES/LINKS THIS PROGRAM. + +C 2. TWO CALLS TO READBLOCK2 IN SUBROUTINE VERIF1 HAVE BEEN CHANGED TO +C HAVE ARGS. OF C0P,...,C3P, RATHER THAN C0,...,C3 BECAUSE THESE +C ARGUMENTS ARE SUPPOSED TO BE ARRAYS. THE ACTUAL VALUES SUPPLIED TO +C READBLOCK2 AT THIS POINT ARE UNIMPORTANT, BUT MAKING THE ARGUMENTS +C ARRAYS REMOVES A WARNING WHEN THIS PROGRAM IS COMPILED BY gfortran. + +C 3. TWO CALLS TO STACK IN MAIN USE TMPFILE AS AN ARGUMENT, BUT TMPFILE +C IS *13 RATHER THAN *20, WHICH IS THE SIZE OF THE RECEIVING ARGUMENT. + +C SO PATFIL*20 IS ADDED TO THIS MAIN MODULE, SET = TMPFILE BEFORE THE +C CALLS TO STACK, AND REPLACES TMPFILE AS THE ARGUMENT IN THE CALLS TO +C SUBROUTINE STACK. + +C----------------------------------------------------------------------- + +C BESTDOS107.FOR 4/7/13 + +C BESTDOS107 HAS THE FOLLOWING CHANGES FROM BESTDOS106: + +C THE OUTPUT FILE WILL INCLUDE MORE INFORMATION. FOR EACH GRID PT. +C IN THE PARAMETER DENSITY, NOT ONLY WILL ALL THE TARGET OBSERVATIONS +C BE WRITTEN (AS IN PREVIOUS PROGRAMS), BUT ALSO ALL OBSERVATIONS WILL +C BE WRITTEN EVERY IDELTA MINUTES (IDELTA = 15 BY DEFAULT, BUT CAN BE +C CHANGED BY THE USER); AND THE SAME APPLIES TO AUCs. AND, THESE SAME +C VALUES WILL BE WRITTEN FOR THE WEIGHTED MEAN OVER ALL THE GRID POINTS +C IN THE PARAMETER DENSITY. + +C THIS MEANS THAT idm3x14.f WILL NOW BE LINKED TO THIS PROGRAM SO THAT +C SUBROUTINE IDCALCYY AN BE CALLED JUST AS IT IS IN npageng22.f TO +C FIND PREDICTED VALUES IDELTA MINUTES APART. + +C NOTE THAT FORMAT 1416 IN MAIN IS ADDED TO WARN THE USER THAT THIS +C PROGRAM IS NOT COMPATIBLE WITH STEADY STATE DOSE SETS OR TIME +C RESETS. + +C----------------------------------------------------------------------- + +C BESTDOS106.FOR 3/26/13 + +C BESTDOS106 HAS THE FOLLOWING CHANGES FROM BESTDOS105: + +C 1. RATHER THAN BEING LINKED WITH NPAGBAY.FOR, IT WILL BE LINKED WITH +C NPAGFULL.FOR. THE DIFFERENCE IN THE TWO ROUTINES IS THAT, GIVEN THE +C INPUT DENSITY IN NPAGDENFILE, NPAGBAY CALCULATES THE 0-CYCLE +C BAYESIAN POSTERIOR OF A SUBJECT, WHEREAS NPAGFULL CALCULATES THE FULL +C POSTERIOR OF THE SUBJECT, UP TO A MAXIMUM OF MAXCYC CYCLES. + +C NOTE THAT IN ADDITION TO NPAGFULL.FOR, THIS PROGRAM WILL BE LINKED +C WITH BLASNPAG.FOR (WHICH IS NEEDED BY NPAGFULL.FOR) ... AND SEE +C OTHER MODULES BELOW. + +C 2. THIS PROGRAM HAS BEEN BROUGHT UP TO THE LEVEL OF THE OTHER +C POPULATION PROGRAMS (CURRENTLY NPAG110.FOR/npageng22.f AND +C IT2B108.FOR/it2beng22.f), EXCEPT IT STILL DOES NOT ACCOMMODATE +C STEADY STATE DOSES. + +C IN PARTICULAR THIS PROGRAM WILL BE LINKED WITH IDM1X14.FOR, RATHER +C THAN IDM1X6.FOR, SHIFT9.FOR, RATHER THAN SHIFT6.FOR; AND + +C CALCBST10.FOR, RATHER THAN CALCBST9.FOR. + + +C NOTE THAT USERS SHOULD START USING TSTMULTK.FOR RATHER THAN +C TSTMULTI.FOR. SEVERAL FORMATS IN THE PROGRAM IN MAIN AND VERIF1 +C NOW REFER TO TSTMULTK.FOR RATHER THAN TSTMULTI.FOR. + +C ALSO ALL DIMENSIONS OF 500 RELATED TO DOSES HAVE BEEN CHANGED TO +C 5000. + +C 3. A BUG IS CORRECTED IN SUBROUTINE CSVCHANGE. PREVIOUSLY, IF A .CSV +C FILE HAD AN IDEVENT = 4 WITH IADDL > 0 (I.E., REPEATED DOSES STARTING + +C WITH A DOSE RESET EVENT), CSVCHANGE WOULD IMPROPERLY WRITE IADDL +C REPEATED DOSE LINES TO FILE 66 ALL WITH IDEVENT = 4. IN FACT, THESE +C REPEATED LINES MUST, OF COURSE, HAVE IDEVENT = 1 (SINCE THEY ARE +C REGULAR DOSE LINES, NOT MORE DOSE RESET LINES). + + + +C SUMMARY: THIS PROGRAM WILL BE LINKED WITH NPAGFULL.FOR, BLASNPAG.FOR, +C CALCBST10.FOR, SHIFT9.FOR, IDM1X14.FOR, AND THE DESIRED MODEL FILE. + +C----------------------------------------------------------------------- + +C BESTDOS105.FOR 3/2/13 + +C BESTDOS105 HAS THE FOLLOWING CHANGES FROM BESTDOS104: + +C IN BESTDOS104, IPRIOR WAS 1 (WHICH MEANS THAT THE USER HAD A .MM +C FILE TO BE USED DIRECTLY AS THE DENSITY FOR THE OPTIMIZATION) OR +C IPRIOR = 0 (WHICH MEANS THAT THE USER STARTED WITH A JOINT DENSITY +C FROM A PREVIOUS NPAG RUN, DENxxxx, ALONG WITH A FILE GIVING INFO +C FROM A SUBJECT'S PAST, PASTFILEIN; AND THEN SUBROUTINE NPAGBAY WOULD +C BE CALLED TO OBTAIN THE BAYESIAN POSTERIOR OF THE NEW PATIENT, WHICH +C IS THEN THE DENSITY FOR THE OPTIMIZATION). SEE BESTDOS101.FOR NOTES. +C IN EITHER CASE, THE PROGRAM WOULD THEN OPTIMIZE THE DOSES TO GIVE +C THE OBSERVED VALUES (AS CLOSELY AS POSSIBLE) IN THE FILE, +C FUTUREFILEIN. + +C IN BESTDOS105, IPRIOR WILL NO LONGER BE USED BECAUSE THERE WILL NO +C LONGER BE AN IPRIOR = 1 OPTION (I.E., THE USER WILL NEVER START WITH +C A DENSITY READY TO USE FOR THE OPTIMIZATION; INSTEAD HE WILL ALWAYS +C START WITH A DENxxxx FILE FROM AN NPAG RUN ON A POPULATION). BUT WHAT +C WAS THE OLD IPRIOR = 0 OPTION, WILL BE CHANGED AND EXPANDED TO ALLOW +C THE FOLLOWING 3 CASES: + +C a. THE USER WILL HAVE A "PAST" FILE (PASTFILEIN) AND IT WILL CONTAIN +C DOSES AND OBSERVATIONS FROM THE PATIENT'S PAST. +C b. THE USER WILL HAVE A "PAST" FILE (PASTFILEIN) BUT IT WILL ONLY +C CONTAIN DOSES (I.E., NO OBSERVATIONS) FROM THE PATIENT'S PAST. +C c. THE USER WILL NOT HAVE A "PAST" FILE (PASTFILEIN). NOTE THAT IN +C THIS CASE, INCLUDPAST (A NEW PARAMETER) WILL BE 0. + +C IN CASE a., THE PROGRAM WILL RUN SIMILARLY TO BESTDOS104 - IT WILL +C USE SUBROUTINE NPAGBAY TO OBTAIN THE BAYESIAN POSTERIOR DENSITY FOR +C THE PATIENT BASED ON DENxxxx AND PASTFILEIN, AND THIS DENSITY WILL +C BE THE ONE USED FOR THE OPTIMIZATION. IN CASES b. AND c., DENxxxx +C WILL NOT BE UPDATED (SINCE THERE ARE NO "PAST" OBSERVATIONS FOR THE +C PATIENT), BUT WILL ITSELF BE THE DENSITY USED FOR THE OPTIMIZATION. + +C NOTE THAT IN CASE c., THE LOGIC WILL PROCEED SIMILAR TO THE + +C IPRIOR = 1 CODE IN BESTDOS104; I.E., THE DENSITY TO BE USED FOR THE +C OPTIMIZATION WILL BE READ FROM DENxxxx AND THEN THE OPTIMIZATION WILL +C TAKE PLACE OVER THE DOSES IN FUTUREFILEIN (USING THE OBSERVED VALUES +C IN FUTUREFILEIN AS TARGETS). BUT IN CASES a. AND b., THE LOGIC WILL +C BE DIFFERENT THAN THAT FOR IPRIOR = 0 IN BESTDOS104. NOW, THE FILE +C IN FUTUREFILEIN IS CONCATENATED AT THE END OF THE "PAST" FILE, +C PASTFILEIN (ACTUALLY ONLY THE DOSES, NOT THE OBSERVED VALUES OF +C PASTFILEIN ARE NEEDED), WITH ALL ITS TIMES INCREASED BY "TNEXT" HOURS +C (TNEXT IS A NEW VALUE WHICH IS INPUT TO THE RUN IN THE INSTRUCTION +C FILE OR BY KEYBOARD ENTRY). THEN THE OPTIMUM DOSES IN THE "FUTURE" +C ARE FOUND TO GIVE THE OBSERVED VALUES IN THE "FUTURE", BUT GIVEN THAT +C THE "PAST" DOSES IN PASTFILEIN OCCURRED FIRST. I.E., WITH IPRIOR = 0 +C IN BESDOS104, IT WAS ASSUMED THAT ALL THE COMPARTMENT AMOUNTS STARTED +C AT 0 (OR WERE GIVEN BY SUBROUTINE GETIX) WHEN FUTUREFILEIN WAS +C OPTIMIZED OVER TO GIVE THE BEST DOSES. NOW, THE COMP. AMOUNTS AT THE +C START OF THE "FUTURE" WILL BE WHATEVER THE PROGRAM SIMULATES THEM TO +C BE AT THE TIME, TNEXT. NOTE THAT THE PROGRAM WILL KNOW TO OPTIMIZE +C ONLY OVER THE DOSES IN THE "FUTURE" OF THE PATIENT, TO GIVE THE +C OBSERVED VALUES IN THE "FUTURE" ... USING THE DOSES WHICH WERE IN THE + +C "PAST" AS GIVEN VALUES. + +C ALSO, SINCE THE INFORMATION IN THE INSTRUCTION FILE HAS BEEN CHANGED, +C THE NEW CODE FOR A SAVED INSTRUCTION FILE WILL BE BESTDOS MAR_13, AND +C NO PREVIOUS VERSIONS OF THE INSTRUCTION FILE WILL BE ALLOWED (I.E., +C IT WILL NOW ALWAYS BE ASSUMED THAT THE USER STARTS WITH AN +C NPAGDENFILE (DENSITY FROM AN NPAG RUN), WHICH MAY OR MAY NOT BE +C UPDATED (DEPENDING ON THE VALUES OF INCLUDPAST AND IPRIOROBS) AND +C WILL NEVER HAVE A MATLAB TYPE FILE (THE OLD IPRIOR = 1 OPTION) WITH +C DENSITY VALUES. + +C NOTE THAT I HAD TO INCLUDE MAXOBDIM AS A CALLING ARGUMENT TO VERIF1 +C SINCE IT MUST PROVIDE THIS DIMENSION TO SUBROUTINE INSPECTOBS. + + + +C NOTE THAT THE FOLLOWING TWO CHANGES ARE NOT IN THIS PROGRAM, BUT WILL +C BE PUT INTO THE NEXT VERSION OF THIS PROGRAM + +C - THE OUTPUT FILE WILL INCLUDE MORE INFORMATION. FOR EACH GRID +C PT. IN THE PARAMETER DENSITY, NOT ONLY WILL ALL THE TARGET +C OBSERVATIONS BE WRITTEN (AS IN PREVIOUS PROGRAMS), BUT ALSO ALL +C OBSERVATIONS WILL BE WRITTEN EVERY IDELTA MINUTES (IDELTA = 15 BY +C DEFAULT, BUT CAN BE CHANGED BY THE USER); AND THE SAME APPLIES TO +C AUCs (SINCE TIME 0 AND SINCE THE LAST DOSE). AND, THESE SAME +C VALUES WILL BE WRITTEN FOR THE WEIGHTED MEAN OVER ALL THE GRID +C POINTS IN THE PARAMETER DENSITY. + +C - AT THE END OF THE RUN, THE USER WILL SEE WHAT THE FUTURE OPTIMUM +C DOSES ARE, AND THEN BE ABLE TO CHANGE THEM AND SEE WHAT THE + +C RESULTING OBSERVED VALUES AND AUCs IN THE FUTURE WOULD BE. + +C----------------------------------------------------------------------- + +C BESTDOS104.FOR 2/17/13 + +C BESTDOS104 HAS THE FOLLOWING CHANGES TO BESTDOS103A: + +C THIS VERSION OPTIMIZES OVER ALL DOSES, BOLUSES AS WELL AS IV'S. +C BESTDO103 ASSUMED THAT THE BOLUSES WERE FIXED AT THE VALUES IN THE +C PATIENT'S DOSAGE REGIMEN, AND THE OPTIMIZATION WAS TO TAKE PLACE ONLY +C OVER THE IV'S. BUT BESTDOS104 OPTIMIZES OVER ALL DOSES. + +C THE REQUIRED CHANGES ARE MADE IN MAIN AND FILRED (AND NOTE THAT +C SIG HAS BEEN ADDED AS A CALLING ARGUMENT TO FILRED) OF THIS MODULE, +C AND IN CALCBST8.FOR, UPDATED FROM CALCBST7.FOR. + +C AND NOTE THAT THE FORMAT OF HOW THE BEST DOSES ARE WRITTEN TO +C DOSEROUTxxxx IS CHANGED. + +C----------------------------------------------------------------------- + +C BESTDOS103A.FOR 2/10/13 + +C BESTDOS103A HAS THE FOLLOWING CHANGES FROM BESTDOS103: + +C CAUTION: THIS PROGRAM DOES ALLOW THE NEW .CSV FORMAT AS DESCRIBED +C BELOW. BUT THIS IS ONLY TO ALLOW IT TO BE RUN WITH PATIENTS WHICH +C HAVE THEIR INFO IN THIS FORMAT, BUT DO NOT ACTUALLY HAVE STEADY STATE +C DOSES. THOSE PATIENTS WHICH HAVE STEADY STATE DOSE SETS WILL NOT +C BE RUNNABLE WITH THIS PROGRAM SINCE NEWER CODE IS REQUIRED IN THE +C NPAGBAY.FOR, SHIFT6.FOR, AND IDM1X6.FOR MODULES (THESE MODULES WERE +C ALL COMPLETELY BEFORE 6/15/11, AND THE STEADY STATE DOSE SETS WERE +C PUT INTO THE POPULATION PROGRAM STARTING WITH NPAG104.FOR, WHICH +C IS DATED 1/18/12. + +C SO IF THE USER TRIES TO USE A PATIENT WITH ADDL > 0 OR -1, THE +C PROGRAM WILL PRINT A MESSAGE AND STOP (SEE FORMAT 321 IN +C SUBROUTINE CSVCHANGE). + +C 1. IT ALLOWS A NEW VERSION OF THE .csv FILE. THIS FILE WILL HAVE +C THE CODE,"POPDATA DEC_11" AT THE TOP, RATHER THAN "POPDATA APR_11". +C THIS NEW .csv FILE WILL HAVE TWO EXTRA COLUMNS, ADDL AND II, WHICH +C ALLOW THE USER TO SPECIFY THAT THE CURRENT DOSE LINE IS TO BE +C REPLICATED ADDL TIMES AT AN INTERDOSE INTERVAL OF II. IF ADDL IS +C MISSING, IT IS ASSUMED TO BE 0 (WHICH MEANS THE LINE IS NOT TO BE +C REPLICATED). IF ADDL = -1, IT INDICATES A STEADY STATE DOSE SET IS +C BEGINNING WITH THAT LINE. + +C TO HANDLE THE NEW .csv FILE, A NEW SUBROUTINE, CSVCHANGE, WILL BE +C CALLED (AFTER SUBROUTINE NEWCSV IS CALLED AND BEFORE READBLOCK IS +C CALLED) TO CHANGE THE NEW .csv FILE INTO THE CORRESPONDING ONE +C WITH THE OLD FORMAT. THIS WILL MINIMIZE THE CHANGES TO SUBROUTINE +C READBLOCK, WHICH WILL STILL NEED TO BE CHANGED TO DEAL WITH +C NEGATIVE DOSE TIMES (WHICH WILL NOW INDICATE THE BEGINNING OF A +C STEADY STATE DOSE SET) - SEE CODE IN READBLOCK. + +C ALSO NOTE THAT CSVCHANGE CONVERTS SCRATCH FILE 67 TO SCRATCH FILE +C 66, WHICH MEANS THAT ALL THE READ(67,..) STATEMENTS IN READBLOCK ARE +C NOW CHANGED TO READ(66,...) STATEMENTS. SIMILARLY, THE READ(67,...) +C IN SUBROUTINE GETMAXTIM IS CHANGED TO READ(66,...). + +C SOME NOTES REGARDING THE NEW .csv FORMAT: + +C a. THE COLUMNS WILL NOW BE: +C ID,EVID,TIME,DUR,DOSE,ADDL,II,INPUT,OUT,OUTEQ,C0,C1,C2,C3,Covs if any + +C b. ADDL AND II ARE ONLY RELEVANT FOR EVID=1 AND EVID=4. FOR EVID=0, +C (OBSERVATIONS) THEY ARE IGNORED. + +C c. ADDL CONTAINS THE NO. OF ADDITIONAL DOSES TO GIVE, AT THE +C INTERDOSE INTERVAL OF II. + +C d. If ADDL IS MISSING FOR AN EVID=1 OR EVID=4 EVENT, IT IS ASSUMED +C TO BE 0 --> NO ADDITIONAL DOSES ARE GIVE. IN THIS CASE, II IS +C IRRELEVANT. + +C e. IF ADDL > 0, THEN ADDL ADDITIONAL DOSES ARE GIVEN (I.E., A TOTAL +C OF ADDL + 1) AT INTERVAL II. A MISSING II IN THIS CASE WILL RESULT +C IN THE PROGRAM STOPPING WITH AN ERROR MESSAGE TO THE USER. + +C f. ADDL > 0 CAN OCCUR ON ANY DOSE EVENT, BUT ADDL = -1 (A STEADY +C STATE DOSE INDICATOR) CAN ONLY OCCUR AT T = 0 AT THE BEGINNING OF +C A PATIENT'S FILE, OR AT A DOSE RESET TIME. + +C 2. IN SUBROUTINE TIMESET, THE FIRST TIME IN THE DOSAGE BLOCK FOR EACH +C SUBJECT IS NO LONGER TESTED TO MAKE SURE IT IS 0. THE REASON, OF +C COURSE, IS THAT NOW THE FIRST TIME MAY BE NEGATIVE (WHICH SIGNIFIES +C THAT THE DOSAGE REGIMEN BEGINS WITH A STEADY STATE OF DOSES). + +C 3. A NEW SUBROUTINE CONVERTCSV IS CALLED BEFORE EACH CALL TO +C SUBROUTINE NEWCSV TO CONVERT, IF NECESSARY, A "EUROPEAN" VERSION OF +C A .CSV FILE TO THE FORM READBLOCK EXPECTS. IN THE "EURO" VERSION, THE +C FIELD SEPARATORS ARE SEMICOLONS, RATHER THAN COMMAS, AND THE +C CHARACTER USED TO SEPARATE THE WHOLE PART OF A NUMBER FROM THE +C FRACTIONAL PART IS A COMMA, RATHER THAN A PERIOD. TO DO THIS REQUIRES +C READING THE SECONDS LINE OF THE .CSV FILE (THE FIRST LINE HAS THE +C VERSION CODE) AND CHECKING FOR SEMICOLONS. IF THERE ARE ANY, THEN THE +C FILE IS CHANGED SO THAT, IN ORDER, ALL COMMAS ARE CHANGED TO PERIODS, +C AND THEN ALL SEMICOLONS ARE CHANGED TO COMMAS. NOTE THAT, EVEN IN THE +C "EURO" VERSION, IT WILL STILL BE ASSUMED THAT A DOT REPRESENTS +C A MISSING (OR UNNEEDED) VALUE. + +C NOTE THAT BLOCKPAT IS NOW OPENED AS SCRATCH FILE 87. THEN CONVERTCSV +C WRITES THIS FILE AS THE CORRECTED VERSION TO SCRATCH FILE 77. THEN, +C ROUTINE NEWCSV CONVERTS THIS FILE TO SCRATCH FILE 67. THEN ROUTINE +C CSVCHANGE CONVERTS THIS FILE TO SCRATCH FILE 66, WHICH IS READ BY +C ROUTINE READBLOCK. + +C----------------------------------------------------------------------- + +C BESTDOS103.FOR 8/15/11 + +C BESTDOS103 HAS THE FOLLOWING CHANGES TO BESTDOS102: + +C 1. THE ACTIVE (SALT) FRACTION, AF, WILL NOW BE A VECTOR. PREVIOUSLY, +C IT WAS ASSUMED THAT ALL DRUGS HAD THE SAME AF; NOW EACH DRUG WILL +C HAVE ITS OWN. + +C THE ABOVE CHANGE MEANS THAT THE NEW VERSION OF THE INSTRUCTION FILE +C (OR 'GUICMDS.INX' IF IT EXISTS IN THE WORKING DIRECTORY) WILL HAVE +C A NEW CODE, 'BESTDOS SEP_11', AND BE ACCOMPANIED BY A NEW ICODE = 4. +C THEN AS THE INSTRUCTIONS ARE BEING READ IN, IF ICODE = 4, THE PROGRAM +C WILL KNOW TO READ IN AF(I),I=1,NDRUG, RATHER THAN JUST AF. THIS ALSO +C REQUIRES CHANGES WHERE INSTRUCTION FILE IS BEING SAVED FOR A + +C SUBSEQUENT RUN. + +C NOTE THAT IN OLDER INSTRUCTION FILES, ALL AF(I), I=1,NDRUG, WILL +C BE SET = THE INPUT VALUE OF AF (NOW CALLED AFSCALAR). + +C NOTE THAT THE OUTPUT FILE WILL ALSO NOW HAVE AF(I),I=1,NDRUG WRITTEN +C TO IT, RATHER THAN JUST AF. + + +C NOTE THAT SUBROUTINE GETNUMEQ HAS BEEN EXPANDED TO ALSO OBTAIN THE +C NO. OF DRUGS, NDRUG, SINCE THIS VALUE IS NEEDED BEFORE +C AF(I),I=1,NDRUG ARE READ VIA THE KEYBOARD. ALSO GETNUMEQ IS NOW +C CALLED BEFORE VERIFI1 IS CALLED TO OBTAIN NDRUG SO THAT IF ONLY +C AFSCALAR WAS READ IN (I.E., IN AN OLDER INSTRUCTION FILE), ALL THE +C AF(I),I=1,NDRUG CAN BE SET = AFSCALAR. + +C 2. CODE IN SUBROUTINE STACK IS CHANGED WHERE THE RS(.,.) VALUES ARE +C MULTIPLIED (NOW) BY AF(.). + +C----------------------------------------------------------------------- + +C BESTDOS102.FOR 6/22/11 + +C BESTDOS102 HAS THE FOLLOWING CHANGES TO BESTDOS101: + +C 1. SUBROUTINE GETERRGAM IS REMOVED BECAUSE IERRMOD AND GAMLAM ARE +C NOW INPUT FROM THE USER VIA THE INSTRUCTION FILE OR KEYBOARD, ALONG +C WITH OTHER INPUT INFO. + +C NOTE THAT I CORRECTED A SUBTLE BUG IN THE CODE REGARDING GAMLAM0, +C THOUGH THIS BUG REMAINS FOR NOW IN THE NPAG100 PROGRAM (IF MAXCYC +C = 0). TECHNICALLY, WHEN THE BAYESIAN DENSITY FOR A SET OF SUBJECTS +C IS FOUND FROM A PRIOR DENSITY, AND IERRMOD .GE. 2, THE VALUE OF +C GAMLAM USED SHOULD BE THE FINAL ESTIMATE AT THE END OF THE +C PRIOR RUN, NOT THE INITIAL ESTIMATE WITH WHICH THE NPAG RUN +C STARTED. FOR EXAMPLE, IF IERRMOD = 2 AND GAMLAM0 = 1, BUT THE FINAL +C ESTIMATE FOR GAMMA = 5, IT MEANS THAT THE ASSAY C'S USED WOULD HAVE +C BEEN BETTER IF THEY HAD BEEN MULTIPLIED BY 5 FROM THEIR ORIGINAL +C VALUES. AND THIS INFORMATION SHOULD BE USED GOING FORWARD WHEN + +C GETTING THE BAYESIAN POSTERIORS FOR A NEW SET OF SUBJECTS. IN +C BESTDOS102, IT IS MADE CLEAR WHEN THE USER ENTERS GAMLAM, HE IS +C ENTERING THE FINAL ESTIMATED VALUE FROM THE ORIGINAL NPAG RUN ON THE +C ENTIRE POPULATION, NOT THE INITIAL ESTIMATE AS IS IMPLIED IN +C BESTDOS101. TO EMPHASIZE THIS, THE TERM USED IS GAMLAM, NOT GAMLAM0. + + +C 2. WHEN THE PROGRAM IS RUN, IT WILL FIRST SEARCH FOR THE FILE, +C 'GUICMDS.INX' IN THE SAME DIRECTORY AS BESTDOS102.EXE. IF IT FINDS +C THIS FILE, IT WILL OPEN IT AND READ IN ALL THE INPUT INSTRUCTIONS, +C AND RUN WITH NO USER INTERACTION AT ALL. IF THE FILE DOES NOT EXIST, +C THE PROGRAM WILL PROCEED AS BEFORE, ASKING THE USER TO INPUT +C INSTRUCTIONS VIA AN INSTRUCTION FILE OR THE KEYBOARD. + +C NOTE THAT IF 'GUICMDS.INX' EXISTS, THE FINAL ARGUMENT (WHICH IS NEW) +C TO READBLOCK2 IS 1 (SEE CODE IN SUBROUTINE READBLOCK2 REGARDING IGUI +C AND READING ICOVTYPE IN THAT CASE). + +C 3. THE PATH IS NOW ALSO INCLUDED IN THE OUTPUT FILE. + +C----------------------------------------------------------------------- + +C BESTDOS101.FOR 6/17/11 + +C BESTDOS101 IS A MAJOR REVISION TO BESTDOS100. THIS NEW PROGRAM ALLOWS +C AN ADDITIONAL LEVEL OF COMPLEXITY TO THE ANALYSIS. IN BESTDOS100, THE +C USER ALREADY HAD AVAILABLE HIS PRIOR JOINT DENSITY FILE (SEE CODE FOR +C MATFIL). + +C IN BESTDOS101, HOWEVER, THE USER MAY NOT ALREADY HAVE THIS INFO. +C INSTEAD, HE MAY START WITH A JOINT DENSITY FROM AN NPAG RUN, ALONG +C WITH A "PAST HISTORY" FOR A NEW SUBJECT (EITHER A WORKING COPY FILE +C OR A .CSV FILE). IN THIS CASE, THE PROGRAM WILL CALL A SHORTENED +C VERSION OF npagengxx.F (NPAGBAY) WHICH WILL OBTAIN THE BAYESIAN +C POSTERIOR JOINT DENSITY OF THIS NEW SUBJECT ... WHICH WILL THEN BE +C THE PRIOR JOINT DENSITY FILE FOR THE BEST DOSE CALCULATIONS. + +C NOTE THAT IN THIS LATTER CASE, THE NEW SUBJECT'S "PAST HISTORY" INFO + +C (I.E., THE DOSING REGIMEN AND OBSERVED VALUE TIMES AND LEVELS) MAY +C BE DIFFERENT THAN THE REGIMEN OVER WHICH THE BEST DOSES WILL BE +C OBTAINED IN THE FUTURE. THIS MEANS THAT THE "FUTURE" INFO FOR THIS +C NEW SUBJECT WILL HAVE TO BE ENTERED SEPARATELY FROM THE "PAST" INFO, +C AND THIS MEANS THAT THE INSTRUCTION FILE WILL BE EXPANDED TO INCLUDE +C THIS INFO. BECAUSE OF THIS, THE INSTRUCTION FILE WILL HAVE A NEW + +C CODE, BESTDOS JUL_11. + +C NOTE THAT VODTOT.FOR WILL NO LONGER BE LINKED INTO THIS PROGRAM +C SEPARATELY. INSTEAD, THE MODULE NPAGBAY WILL CONTAIN A VERSION OF +C VODTOT.FOR THAT HAS A FEW CHANGES TO BE COMPATIBLE WITH ANDREAS' +C INTEL COMPILER. + +C NOTE ALSO THAT NPAGBAY REQUIRES SUBROUTINE SUBRES WHICH CALLS +C SUBROUTINE IDPC, AND THIS MEANS THAT MODULE IDM1X6.FOR (THE SAME +C AS idm1x6.f IN npageng13.f) WILL NOW BE LINKED TO THIS PROGRAM. +C BECAUSE OF THIS, AND THE FACT THAT IDM1X6.FOR HAS ROUTINES USERANAL + +C AND JACOB, CALCBST6.FOR WILL BE REPLACED BY CALCBST7.FOR, WHICH +C DOES NOT HAVE THESE ROUTINES. + +C SO HERE ARE THE MAJOR STEPS OF THIS PROGRAM: + + + +C 1. USER ENTERS A MODEL FILE WHICH IS ALREADY LINKED WITH THIS +C PROGRAM. + +C 2. USER SELECTS WHETHER HE ALREADY HAS PRIOR DENSITY (IPRIOR = 1 +C --> YES; IPRIOR = 0 --> NO). + +C 3. IF IPRIOR = 1, THE PROGRAM USES THE SAME LOGIC AS IN +C BESTDOS100. + +C 4. IF IPRIOR = 0, USER ENTERS THE JOINT DENSITY FILE FROM A +C PREVIOUS NPAG RUN, ALONG WITH INFO WITH ANOTHER SUBJECT'S "PAST" +C DATA (VIA EITHER A WORKING COPY FILE OR .CSV FILE). + +C THEN NEW SUBROUTINE NPAGBAY (BASED ON THE CODE IN npageng13.f +C WHEN MAXCYC = 0) IS CALLED TO OBTAIN THE BAYESIAN POSTERIOR OF +C THE NEW PATIENT; THIS IS THE PRIOR DENSITY USER WOULD HAVE +C ENTERED DIRECTLY IN STEP 2 IF IPRIOR WAS = 1. + +C----------------------------------------------------------------------- + +C BESTDOS100.FOR 6/4/11 + +C BESTDOS100 HAS THE FOLLOWING CHANGES FROM BESTDOS8: + +C 1. IT IS BROUGHT TO THE LEVEL OF THE OTHER '100' PROGRAMS, NPAG100, +C IT2B100, AND MONT100.FOR. IN PARTICULAR, NEW SUBROUTINES READBLOCK2, +C ETC. ARE ADDED SO THAT THE DOSE REGIMEN, AND OBSERVED VALUE BLOCK +C CAN BE INPUT VIA A .CSV FILE, RATHER THAN A WORKING COPY FILE. THE +C FORMAT OF THIS .CSV FILE WILL BE THE UPDATED ONE REFERRED TO IN THE +C COMMENTS AT THE TOP OF THE OTHER '100' PROGRAMS SPECIFIED ABOVE. + + +C 2. WT AND CCR ARE NO LONGER TREATED AS SPECIAL COVARIATES. SO +C ALL OCCURRENCES OF 2 + NADD WILL NOW BE REPLACED BY NADD. THIS ALSO +C MEANS THAT THE MODEL FILE MUST NOW BE AN EDITED VERSION OF THE +C TEMPLATE MODEL FILE, TSTMULTI.FOR (UPDATED FROM TSTMULTH.FOR. + +C 3. SHIFT5.FOR WILL BE REPLACED BY SHIFT6.FOR (SAME AS SHIFT6.F IN +C npageng13.f PROGRAM), WHICH IS REQUIRED FOR THE CHANGES RELATED TO +C WT AND CCR NO LONGER BEING CONSIDERED SPECIAL COVARIATES. NOTE THAT +C THE OTHER MODULES, CALCBST6.FOR AND VODTOT.FOR, ARE UNCHANGED. + + +C 4. THERE WILL BE A NEW CODE FOR THE INSTRUCTION FILE, +C 'TESTDOS JUN_11', AND ALL PREVIOUS VERSIONS OF INSTRUCTION FILES WILL +C NO LONGER BE ALLOWED. THE MAIN DIFFERENCES ARE THAT MORE INFO WILL BE +C STORED (INCLUDING THE MODEL FILENAME, THE O.D.E. TOLERANCES, AND THE +C NAME OF THE FILE WHICH HAS THE APRIORI DENSITY), AND THE FILE WILL +C ALSO HAVE TEXT DESCRIBING WHAT INFO IS INPUT. + +C 5. THE OUTPUT FILE WILL NO LONGER BE HARDCODED TO BE TAR_ACH.CON. +C INSTEAD IT WILL BE DOSEROUTxxxx, WHERE xxxx WILL BE READ FROM +C FILE EXTNUM. AND THE TOP OF THE OUTPUT FILE WILL BE A RESTATEMENT +C OF ALL INSTRUCTIONS AS USUAL BEFORE THE OUTPUT VALUES WILL BE +C WRITTEN. + +C 6. A NEW FLAG, CALLED IPRINTOUT, IS HARDCODED TO BE 1, WHICH MEANS +C THAT THE OUTPUT INFO (SEE FORMAT 1234 IN SUBROUTINE ELDERY) IS +C PRINTED TO THE SCREEN AS USUAL. THIS IS DONE IN ANTICIPATION OF THIS +C PROGRAM BEING RUN AS AN "ENGINE" CALLED BY ANDREAS' GUI. IN THAT +C CASE, IPRINTOUT CAN BE RESET = 0, WHICH WILL SUPPRESS THE INFO IN + +C FORMAT 1234 FROM BEING WRITTEN TO THE SCREEN. + + +C 7. ALL THE PAUSE STATEMENTS ARE NOW CHANGED TO CALL PAUSE STATEMENTS, +C AND NEW SUBROUTINE PAUSE IS ADDED TO THE PROGRAM. THIS IS DONE SINCE +C A REGULAR PAUSE STATEMENT CAUSES WARNINGS WHEN THIS PROGRAM IS +C COMPILED AND LINKED USING gfortran (AND FORCES THE USER TO TYPE "go" +C INSTEAD OF SIMPLY HITTING THE ENTER KEY). + +C----------------------------------------------------------------------- + +C BESTDOS8.FOR 1/27/11 + +C BESTDOS8 HAS THE FOLLOWING CHANGES FROM BESTDOS7: + +C 1. FORMATS 919 AND 5001 ARE CHANGED TO EXPLAIN TO THE USER THAT HIS +C FORTRAN MODEL FILE, LINKED INTO THIS PROGRAM, MUST BE AN EDITED +C VERSION OF TSTMULTH.FOR. THE PREVIOUS LANGUAGE WAS OUTDATED (SINCE +C THE BOXES PROGRAM HAS NOT BEEN UP TO DATE FOR A LONG TIME). + + +C 2. IT IS COMPILED WITH CALCBST6.FOR, RATHER THAN CALCBST5.FOR, AND +C A MODEL FILE BASED ON TSTMULTH.FOR, RATHER THAN TSTMULTG.FOR. THE +C OTHER PERMANENT MODULES, SHIFT5.FOR, VODTOT.FOR, ARE UNCHANGED. + +C NOTE THAT IN CALCBST6.FOR, THE CHANGES ARE IN SUBROUTINE GETPRED, +C AND, IN ADDITION TO CORRECTING A COUPLE OF BUGS, MAKE THIS PROGRAM +C COMPATIBLE WITH TSTMULTH.FOR, AS INDICATED ABOVE. + +C 3. THE CALL TO SUBROUTINE DETECT IS COMMENTED OUT. THE REASON IS +C THAT IT WILL NOW BE ASSUMED THAT THE USER CREATES HIS MODEL FILE +C FROM THE TEMPLATE MODEL FILE (CURRENTLY TSTMULTH.FOR) AND SO IT +C WILL AUTOMATICALLY HAVE THE CORRECT DECLARATION STATEMENTS AT THE +C TOP OF EACH SUBROUTINE. PLUS, THIS WILL PREVENT THIS PROGRAM FROM +C STRIPPING AWAY SPECIAL DECLARATION STATEMENTS THE USER MAY NEED TO +C ADD TO THE ROUTINES FOR SPECIAL CASE ANALYSES. + +C NOTE THAT SUBROUTINE DETECT, AND THE ROUTINES IT CALLS, WILL BE LEFT +C IN THE CODE FOR NOW (IN CASE THEY, OR MODIFIED VERSIONS OF THEM ARE +C NEEDED IN A FUTURE VERSION OF THIS PROGRAM). + +C----------------------------------------------------------------------- + +C BESTDOS7.FOR 10/15/09 + +C BESTDOS7 IS A MAJOR ENHANCEMENT TO BESTDOS6, AS FOLLOWS: + +C 1. BESTDOS6 IS LIMITED TO ONE OUPUT EQUATION AND ONE DRUG; BESTDOS7 +C ALLOWS MULTIPLE OUTPUTS AND MULTIPLE DRUGS ... TO THE LEVEL OF THE +C MULTIPLE DRUG BIG NPAG PROGRAM, NPBIG15C.FOR/bigmlt4.f. + +C 2. SEVERAL SUBROUTINES IN THIS PROGRAM ARE NOW REPLACED BY THE +C CORRESPONDING VERSIONS FROM THE CURRENT BIG NPAG POPULATION PROGRAM, +C NPBIG15C.FOR, OR ARE MODIFICATIONS OF ROUTINES FROM NPBIG15C.FOR, BUT +C ADJUSTED TO FIT THE CODE OF THIS PROGRAM. THESE ROUTINES INCLUDE: +C GETPATH, FULLNAME, PUTASS, FILRED, STACK, USERPREP, CHECKLIN, +C WRITEDIF, WRITESYM, WRITEOUT, AND SKIPLINE. SOME OF THE CHANGED CODE + +C IS MINOR (E.G., *72 BECOMES *1000); OTHER IS MAJOR. + +C NOTE THAT IN SUBROUTINE PUTASS, SUBROUTINE USECS IS NO LONGER NEEDED, +C AND SO SUBROUTINE USECS IS REMOVED FROM THE PROGRAM. + +C NOTE THAT A VERSION OF SUBROUTINE GETNUMEQ FROM NPBIG15C.FOR IS + +C ADDED TO THIS PROGRAM (IT IS CALLED BY MAIN). + +C 3. NOTE THAT THIS PROGRAM WILL REQUIRE A NEW CODE FOR THE INSTRUCTION +C FILE (TESTDOS NOV_09) SINCE THE INPUT INFO WILL BE DIFFERENT FROM +C THAT OF THE PREVIOUS PROGRAM. + + +C 4. NOTE THAT THE FORMAT FOR THE PATIENT DATA FILE WILL NOW HAVE TO BE +C THE MULTIPLE DRUG WORKING COPY FORMAT. I.E., NO BLOCK FORMAT WILL BE +C ALLOWED (UNLIKE IN NPBIG15C.FOR, THE POPULATION PROGRAM). + +C 5. THIS MODULE IS LINKED WITH CALCBST5.FOR, WHICH IS AN UPDATE FROM + +C CALCBST4.FOR. + +C 6. THIS MODULE WILL BE LINKED WITH SHIFT5.F, RATHER THAN SHIFT2.F, +C SINCE THE TEMPLATE MODEL FILE IS NOW CHANGED TO BE TSTMULTG.FOR +C (SEE DETAILS IN NPBIG15C.FOR). + +C 7. THIS PROGRAM NO LONGER LINKS IN CONVRTLO.FOR. IT IS UNNEEDED. + +C----------------------------------------------------------------------- + +C BESTDOS6.FOR 3/1/08 + +C BESTDOS6 HAS THE FOLLOWING CHANGES TO BESTDOS5: + +C 1. IN SUBROUTINE PUTASS, AT LABEL 25, THE FREE FORMAT WRITING +C LINE ... 25 WRITE(27,*) 'ASSAY COEFFICIENTS FOLLOW:' +C IS REPLACED BY A FIXED FORMAT. THIS PREVENTS EXTRA COMMAS +C BEING WRITTEN TO THE LINE WITH SOME COMPILERS. + +C 2. THIS MODULE IS LINKED WITH CALCBST4 CONVRTLO SHIFT2 VODTOT + +C AND THE USER-SUPPLIED MODEL FILE. ALL THE ROUTINES ARE THE SAME +C AS IN BESTDOS5, EXCEPT CALCBST4, WHICH IS CHANGED FROM CALCBST3 +C (DOSES ARE PREVENTED FROM BEING NEGATIVE IN SUBROUTINE CALCS. + +C----------------------------------------------------------------------- + +C BESTDOS5.FOR 9-8-03 + +C BESTDOS5 HAS THE FOLLOWING CHANGE FROM BESTDOS4: + + +C THE BEST SET OF DOSES TO MINIMIZE THE EXPECTED WEIGHTED SUM OF +C SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET CONCENTRATIONS, +C AS WELL AS THE THIS SUM OF SQUARES, AS CALCULATED BY THE CALL TO + +C SUBROUTINE ELDERY, ARE ALSO PUT INTO THE OUTPUT FILE, TAR_ACH.CON +C (PREVIOUSLY THEY WERE JUST WRITTEN TO THE SCREEN). + +C----------------------------------------------------------------------- + + +C BESTDOS4.FOR 01-05-03 + +C BESTDOS4 IS A MAJOR VARIATION OF BESTDOS3. THE MAJOR CHANGE IS THAT +C THIS PROGRAM NOW ALLOWS GENERAL MODELS WHICH CAN BE DESCRIBED BY +C DIFFERENTIAL EQUATIONS AND OUTPUT EQUATION(S) CODED BY THE USER +C INTO SUBROUTINES DIFFEQ AND OUTPUT OF FILE, npemdriv.f. I.E., THE + +C MODEL IS NO LONGER LIMITED TO THE STANDARD 3-COMPARTMENT LINEAR +C MODEL. + +C BESTDOS4 WILL BE COMPILED AND LINKED WITH CALCBST3, CONVRTLO, +C SHIFT2.F, VODTOT.F, AND npemdriv.f (WHICH THE USER EDITS AND + +C COMPLETES - npemdriv.f WILL THEN BE RENAMED SOMETHING WITH A +C .FOR EXTENSION). + +C THE CODING CHANGES REQUIRED ARE AS FOLLOWS: + + +C 1. THE I/O IS CHANGED TO BE LIKE THE OTHER "BIG" PROGRAMS (BIG NPAG + +C AND BIG IT2B), WHICH DON'T HAVE MENUS. IN PARTICULAR, THIS PROGRAM +C IS ESSENTIALLY AT THE "LEVEL" OF NPBIG10B.FOR, WHICH MEANS THAT +C ONLY A SINGLE DRUG IS ALLOWED. HOWEVER, FOR NOW, ONLY ONE OUTPUT +C EQUATION IS ALLOWED (I.E., NPBIG10B ALLOWS MULTIPLE OUTPUT EQUATIONS + +C BUT THIS PROGRAM IS LIMITED TO JUST ONE). + +C 2. THIS PROGRAM IS LINKED WITH CALCBST3.FOR (UPDATED FROM +C CALCBST2.FOR). + +C 3. NEW COMMON/FROMBEST PROVIDES THE VALUES NEEDED BY CALCBST3.FOR +C WHEN IT CALLS NEW SUBROUTINE MAKEVEC. + + +C 4. SUBROUTINE GETCOVAR IS NO LONGER NEEDED SINCE THE USER CODES +C DIRECTLY INTO SUBROUTINES DIFFEQ, OUTPUT, AND SYMBOL WHICH +C DESCRIPTORS ARE TO BE USED. + +C 5. ALL DIMENSIONS OF 150 ARE CHANGED TO 594 - TO MAKE THESE +C DIMENSIONS CONSISTENT THROUGHOUT THE PROGRAM. ALSO, THE DIMENSIONS +C FOR PAR AND PARFIX ARE CHANGED TO BE THE SAME AS IN NPBIG10B.FOR. +C IDES(16), NIND(29), AND DESCR(26)*20 ARE REMOVED. IRAN(25) IS ADDED, +C AS IS FORFILE*20. + +C 6. REMOVED COMMON/TOPAR SINCE IT IS NOW NOT APPLICABLE (I.E., IT +C PASSES TO MODULE PARADP17.FOR INFO FOR MENUS 1 AND 2 IN THE +C 3-COMPARTMENT LINEAR MODEL). NOTE THAT PARADP17.FOR IS NO LONGER +C LINKED WITH THIS PROGRAM. + +C 7. NEW I/O WHICH IS SIMILAR TO THAT IN NPBIG10B.FOR IS USED. IN +C PARTICULAR, ALL REFERENCES TO MENUS, NPAR, NFIX ARE REMOVED. BUT +C I/O FOR THE O.D.E. TOLERANCES ARE INCLUDED. + +C 8. ALL REFERENCES TO SUBROUTINES PARNAM AND PARNAM2 ARE ELIMINATED. + +C 9. IN NPBIG10B.FOR, GETNUMEQ IS CALLED TO GET NUMEQT, THE NO. OF + +C OUTPUT EQS. IN THIS PROGRAM, WE WILL ASSUME FOR NOW THAT NUMEQT +C =1, SO GETNUMEQ IS NOT INCLUDED IN THIS PROGRAM. + +C 10. SUBROUTINES DETECT, CHECKLIN, SKIPLINE, WRITEDIF, WRITEOUT, AND +C WRITESYM ARE INCLUDED (FROM NPBIG10B.FOR), BUT IVERS IS HARDCODED +C = 0 (SINCE IT WILL BE ASSUMED THAT ONLY THE BETA VERSION IS +C AVAILABLE FOR NOW). + +C 11. SUBROUTINE USERPREP IS ADDED (FROM NPBIG10B.FOR). + +C 12. NBI IS REMOVED AS AN ARGUMENT TO SUBROUTINE STACK. + +C 13. SUBROUTINE FILRED IS CHANGED TO BE LIKE THAT IN MODULE, +C bignpaglap1.f (THE .f FILE WHICH IS COMPATIBLE WITH NPBIG10B.FOR). +C IN PARTICULAR, TIM AND YO DIMENSIONS WILL CHANGE TO (594) AND +C (594,6), RESPECTIVELY; COMMON/DESCR IS BE INCLUDED; AND NTLAG IS NOW +C A PART OF COMMON/CNST. ALSO, AGE, ISEX, HEIGHT, AND IETHFLG ARE +C REMOVED FROM THE ARGUMENT LIST (SINCE COMMON/TOPAR IS N/A). + +C 14. SUBROUTINES PRINTMENU, GETIND, AND PRINTCOV ARE REMOVED. + +C 15. THE IKAMS1/IKAMS2 LOGIC TO CHECK ON COMPATIBILITY BETWEEN BOLUS +C INPUTS AND KA IS REMOVED SINCE WITHOUT INDICES, THERE IS NO WAY TO +C KNOW IF KA IS A PARAMETER. + +C 16. THE CODE FOR A SAVED INSTRUCTION FILE HAS BEEN CHANGED TO +C 'TESTDOS NOV_02'. + +C 17. THE MAXIMUM NO. OF GRID POINTS WHICH CAN BE USED (I.E., THE NO. +C OF GRID POINTS READ IN FROM THE MATLAB FILE BY BESTDOS4.FOR) IS +C CURRENTLY SET = MAXGRD = 5003. + +C 18. IN SUBROUTINE ELDERY, A NEW WRITE STATEMENT (SEE FORMAT 1234) IS +C PUT IN TO GIVE USER SOME INDICATION OF HOW CLOSE TO CONVERGENCE THE +C PROGRAM IS. + +C----------------------------------------------------------------------- + +C BESTDOS3.FOR 6-19-02 + +C BESTDOS3 IS THE SAME AS BESTDOS2 EXCEPT THAT THE LIMITATION ON THE +C MAXIMUM NO. OF DOSES (SEE FORMAT 103) HAS BEEN RESET TO 500 WHICH +C IS CORRECT (I.E., THE ONLY LIMITATION IS THE SIZE OF THE START +C AND STEP VECTORS IN THIS ROUTINE, AND SIMILAR ARRAYS IN OTHER +C ROUTINES - NOT THE ARBITRARY VALUE OF 7). NOTE THAT MAXDIM = 7 +C MEANS THAT THE MAXIMUM NO. OF MODEL PARAMETER IS 7, BUT THIS IS + +C UNRELATED TO THE MAXIMUM NO. OF DOSES ALLOWED. + +C ALSO NOTE THAT A NEW PARAMETER STATEMENT IN SUBROUTINE ELDERY IS +C NEEDED TO RESET THE DIMENSIONS OF THOSE ARRAYS WHICH ARE NOT + +C CALLING ARGUMENTS AND THEREFORE CANNOT HAVE THEIR DIMENSIONS SET +C BY THE PASSED PARAMETER N. + +C----------------------------------------------------------------------- + + +C BESTDOS2.FOR 9-29-01 + +C BESTDOS2 IS A SLIGHT EXTENSION TO BESTDOSE. THE DIFFERENCE IS THAT, +C FOR EACH GRID POINT IN THE INPUT DENSITY, THE ACHIEVED CONCENTRATIONS +C FOR THE CURRENT BEST SET OF DOSES (I.E., THOSE GIVING THE MINIMUM +C EXPSUM IN SUBROUTINE CALCS, CALLED BY ELDERY) ARE STORED IN +C COMMON/PREDVAL. THESE VALUES WILL BE STORED INTO THE FILE +C TAR_ACH.CON BEFORE THIS PROGRAM CLOSES. + +C----------------------------------------------------------------------- + +C BESTDOSE.FOR 8-24-01 + +C BESTDOSE IS A MAJOR EXTENSION TO TESTDOSE. TESTDOSE CALCULATED A + +C SINGLE EXPECTED WEIGHTED SUM OF SQUARES (SEE BELOW) FOR A +C HARDCODED SET OF DOSE VALUES AND WEIGHTS (THE TARGET CONCENTRAIONS +C WERE THOSE READ AS OBSERVED VALUES FROM A PATIENT DATA FILE). +C BESTDOSE CALLS ELDERY (WHICH USES THE NELDER MEED ALGORITHM) TO FIND +C THE BEST SET OF DOSES TO MINIMIZE THIS EXPECTED WEIGHTED SUM OF +C SQUARES, GIVEN: +C 1. A PATIENT DATA FILE WITH THE REQUIRED DOSE TIMES, OBSERVATION +C TIMES, AND TARGET CONCENTRATIONS (= OBSERVED VALUES), AND + + +C 2. A PRIOR DENSITY FILE WITH PARAMETER VALUES AND CORRESPONDING +C DENSITIES. + +C BESTDOSE IS COMPILED AND LINKED WITH CALCBEST, PARADP17, CONVRTLO + +C??? ACTUALLY MAXDIM IS UNRELATED TO MAX. NO. OF DOSES. SEE COMMENTS +C AT TOP OF BESTDOS3.FOR. +C FOR NOW, BESTDOSE.FOR (AUGUST, 2001), THE MAX. NO. OF DOSES IS +C LIMITED TO 7. TO RAISE IT, WILL HAVE TO INCREASE THE DIMENSIONS IN +C SUBROUTINE ELDERY, AND INCREASE MAXDIM IN THE THREE PARAMETER +C STATEMENTS IN CALCBEST.FOR. + +C----------------------------------------------------------------------- + +C TESTDOSE.FOR 1-26-01 + + +C TESTDOSE IS A VARIATION OF TESTDRV2. TESTDRV2 CALCULATED THE +C EXPECTED VALUE OF THE FISHER INFORMATION MATRIX, GIVEN A CANDIDATE +C VECTOR OF OBSERVATION TIMES (AND A PATIENT DATA FILE WITH THE DOSAGE +C REGIMEN, AND A PRIOR DENSITY FILE). + + + +C TESTDOSE CALCULATES THE EXPECTED WEIGHTED SUM OF SQUARES OF +C DIFFERENCES BETWEEN OBSERVED AND TARGET CONCENTRATIONS, GIVEN A +C CANDIDATE VECTOR OF DOSE AMOUNTS (DOSE TIMES AND OBSERVATION TIMES +C AND TARGET CONCENTRATIONS ARE GIVEN IN A PATIENT DATA FILE; ALSO A +C PRIOR DENSITY FILE IS GIVEN). + +C THIS PROGRAM MUST BE COMPILED AND LINKED WITH CONVRTLO.FOR, +C PARADP17.FOR, AND CALCS + +C----------------------------------------------------------------------- + +C PROCEDURE: + +C 1. THIS PROGRAM WILL READ FROM THE USER, VIA THE KEYBOARD, OR AN +C INPUT FILE, (NVAR,MENU,NPAR,NOFIX,NFIX,VALFIX,IDES,NCOV). THESE +C VALUES, ALONG WITH AGE, HEIGHT, ISEX, IETHFLG FROM THE PATIENT DATA +C FILE (SEE NO. 2 BELOW) WILL BE PASSED VIA COMMON/TOPAR TO THE PARDEF +C ROUTINE (WHICH IS PART OF THE PARADP17 MODULE). + +C 2. IT WILL THEN READ IN A PATIENT DATA FILE. IF IT IS A +C USC*PACK FILE, IT WILL BE CONVERTED TO A WORKING COPY FILE WITH + +C THE DESIRED ASSAY COEFFICIENTS IN IT. THIS FILE WILL BE PUT INTO +C FILE 27. THEN BEFORE CALCS IS CALLED, SUBROUTINE FILRED + +C WILL BE CALLED. FILRED READS IN THE ASSAY COEFFICIENTS, ALONG WITH +C AGE, HEIGHT, ISEX, AND IETHFLG (SEE NO. 2 ABOVE) AND PUTS THE +C REQUIRED DOSAGE INFO INTO THE REQUIRED COMMONS (ALL THIS INFO IS +C NEEDED BY THE CALCS MODULE). + +C NOTE THAT FILRED WILL BE CALLED JUST ONCE TO ESTABLISH ALL THE VALUES +C (DOSE TIMES, OBSERVATION TIMES, ETC.) INTO THE REQUIRED COMMONS. +C THEN, EACH TIME A NEW DOSAGE CANDIDATE VECTOR IS USED, THE VALUES OF +C THESE NEW DOSES WILL BE STORED INTO THE RS VECTOR IN COMMON/OBSER +C BY SUBROUTINE WSUMSQ IN MODULE CALCS (I.E., FILRED WILL NOT HAVE +C TO BE CALLED AGAIN SINCE ALL THE VALUES ALREADY STORED INTO ITS +C COMMONS STAY THE SAME EXCEPT FOR THE RS VECTOR WHICH WILL BE STORED +C AS INDICATED ABOVE). + +C----------------------------------------------------------------------- + + PARAMETER(MAXGRD=5003, MAXDIM=25, MAXOBDIM=150, MAXSUB=1, + 1 MAXNUMEQ = 7) + + IMPLICIT REAL*8(A-H,O-Z) + + DIMENSION DENSITY(MAXGRD,MAXDIM+1),YO(MAXOBDIM,MAXNUMEQ), + 1 START(5000),STEP(5000),VALFIX(20),RS(5000,34),DOSEBEST(5000), + 2 PREDMIN(MAXGRD,594,MAXNUMEQ),IRAN(32),ATOL(20),C0P(MAXNUMEQ), + 3 C1P(MAXNUMEQ),C2P(MAXNUMEQ),C3P(MAXNUMEQ),IASS(MAXNUMEQ), + 4 C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ),C3(MAXNUMEQ), + 5 SIG(5000),WORKK(MAXGRD),WORK(MAXGRD),CORDEN(MAXGRD,MAXDIM+1), + 6 AB(30,2),VALFIXX(20),AF(7),PYJGX(MAXSUB,MAXGRD), + 7 DENSTOR(MAXGRD,4),THETA(30),PX(32),BS(5000,7),TIM(594), + 8 TPRED(72000),YOO(594,MAXNUMEQ),YYPRED(72000,MAXNUMEQ), + 9 CORDLAST(MAXGRD,MAXDIM+1),TIM41(594),CORD1(MAXGRD,MAXDIM+1), + 1 PREDMIN1(MAXGRD,594,MAXNUMEQ),DENSITY1(MAXGRD,MAXDIM+1), + 2 DOSEBEST1(5000),YBAR(72000,MAXNUMEQ),AUCBAR(72000,MAXNUMEQ), + 3 TPREDREL(72000) + + + CHARACTER PAR(30)*11,FILNFO*20, + 1 SAVFIL*20,PARFIX(20)*11,CODE*14,PATH*60,TMPFILE*13, + 2 PATHFILE*73,MATFIL*20,FORFILE*20,FUTUREFILEIN*20,OUTFIL*20, + 3 NAME*4,NPAGDENFILE*20,PASTFILEIN*20,ESTNAM*6,TMPFILE1*13, + 4 TMPFILE2*13,PATFIL*20,ERRFIL*20,PARRANFIX(20)*11 + + EXTERNAL CALCS + + COMMON/TOCALC/DENSITY,BIASWEIGHT,NOBSER,NUMEQT,NGRD,NVARR,NDD41 + COMMON/PREDVAL/PREDMIN,EEXPSUMMIN,SUMMIN,BIASMIN + COMMON/FROMBEST/NOFIX,IRAN,VALFIX + COMMON/TOUSER/NDIM,MF,RTOL,ATOL + COMMON/OBSER/ TIM,SIG,RS,YOO,BS + COMMON/TOCALCTP/M41,TIM41 + COMMON/TOSUMSQ/ITARGET,NVAR,NOFIXXX,NDIMMM,IDELTA,TNEXT + COMMON/ERROR/ERRFIL + + +C NOTE THAT COMMON/TOSUMSQ VALUES ARE PROVIDED FROM MAIN TO +C SUBROUTINE WSUMSQ (WHICH IS CALLED BY SUBROUTINE CALCS). + + +C COMMON/TOCALC IS SUPPLIED TO SUBROUTINE CALCS WHICH IS THE ROUTINE +C CALLED BY ELDERY. + +C COMMON/PREVAL CONTAINS PREDMIN WHICH CONTAINS THE PREDICTED VALUES +C FOR EACH GRID POINT FOR THE BEST SET OF DOSES SO FAR (AS DETERMINED +C BY SUBROUTINE ELDERY). ALSO, EEXPSUMMIN IS THE MINIMUM ACHIEVED +C COST FUNCTION, WHICH IS A FUNCTION OF SUMMIN AND BIASMIN. + +C COMMON/FROMBEST IS PROVIDED TO SUBROUTINE CALCS. THESE VALUES ARE +C NEEDED IN THE CALL TO MAKEVEC IN THAT ROUTINE. + + +C COMMON/TOUSER IS SUPPLIED TO SUBROUTINE USERANAL IN CALCBST_.FOR. + +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. + +C----------------------------------------------------------------------- + + 2 FORMAT(A20) + 222 FORMAT(A3) + 2222 FORMAT(A5) + 2221 FORMAT(A60) + + + 138 FORMAT(/' PLEASE ENTER ONE OF THE REQUESTED VALUES: ') + + +C ENTER ALL INSTRUCTIONS FROM 'GUICMDS.INX' WITH NO USER INTERACTION +C IF THIS FILE EXISTS IN THE WORKING DIRECTORY. OTHERWISE, PROCEED AS +C IN PREVIOUS PROGRAMS, ASKING THE USER FOR THE PATH AND THEN OBTAINING +C INPUT INFO EITHER VIA AN INPUT FILE OR THE KEYBOARD. + + + OPEN(23,FILE='GUICMDS.INX',ERR=1210,STATUS='OLD') + +C TO GET HERE, THE FILE, 'GETCMDS.INX' EXISTS IN THE WORKING +C DIRECTORY. READ ALL INPUT DATA IN THIS FILE, WHICH WAS FILLED FROM A +C GUI DRIVING THIS PROGRAM. NOTE THAT THIS FILE HAS ALL THE INFORMATION +C OF A STANDARD INSTRUCTION FILE, BUT ALSO INCLUDES THE PATH AT THE +C TOP, SINCE THE PATH CANNOT BE PROVIDED TO THE PROGRAM REAL TIME, AS +C THERE IS NO USER INTERACTION IF "GUICMDS.INX" IS READ. + +C THE 1ST LINE IN THE FILE IS THE CODE WHICH GIVES THE VERSION NO. OF +C THE PROGRAM. + + READ(23,7123) CODE + + ICODE = 0 +C IF(CODE .EQ. 'BESTDOS JUN_11') ICODE = 01 +C IF(CODE .EQ. 'BESTDOS JUL_11') ICODE = 02 +C IF(CODE .EQ. 'BESTDOS AUG_11') ICODE = 03 +C IF(CODE .EQ. 'BESTDOS SEP_11') ICODE = 04 + IF(CODE .EQ. 'BESTDOS MAR_13') ICODE = 05 + IF(CODE .EQ. 'BESTDOS APR_13') ICODE = 06 + IF(CODE .EQ. 'BESTDOS MAY_13') ICODE = 07 + IF(CODE .EQ. 'BESTDOS JUN_13') ICODE = 08 + IF(CODE .EQ. 'BESTDOS SEP_13') ICODE = 09 + IF(CODE .EQ. 'BESTDOS OCT_13') ICODE = 10 + + IF(ICODE .EQ. 0) THEN + + WRITE(*,9124) + 9124 FORMAT(/' "GUICMDS.INX" IS NOT AN UP-TO-DATE GUI FILE FOR '/ + 1' THIS PROGRAM. '/) + WRITE(*,9126) + 9126 FORMAT(/' CONSIDER TRYING ONE OF THE FOLLOWING 2 OPTIONS:'// + 3' 1. USE A SAVED INSTRUCTION FILE FROM A PREVIOUS DOS RUNNING '/ + 4' OF THIS PROGRAM. THE 1ST LINE OF THE SAVED FILE MUST HAVE '/ + 5' BESTDOS XXX_XX, WHERE XXX_XX IS MAR_13 OR A MORE RECENT DATE. + 6'// + 6' 2. ENTER DATA FROM THE KEYBOARD AS YOU RUN THE PROGRAM UNDER DOS + 7.'/) + +C CANNOT WRITE THIS ERROR MESSAGE TO ERRFIL SINCE ERRFIL CAN'T BE +C ESTABLISHED TILL THE PATH IS OBTAINED BELOW. + + + CALL PAUSE + STOP + + ENDIF + +C SKIP THIS LINE. IT CONTAINS 'PATH' + READ(23,*) + READ(23,2221) PATH + +C FIND xxxx, WHICH WILL BE THE 4-DIGIT EXTENSION ASSIGNED TO +C THE OUTPUT FILE AND ERROR FILE NAMES BELOW. NOTE THAT xxxx IS +C THE 4-CHARACTER REPRESENTATION OF THE INTEGER +C CURRENTLY IN THE FILE, EXTNUM, IN THE WORKING DIRECTORY. GET THIS +C INTEGER NOW, AND REPLACE IT BY 1 MORE (UNLESS IT IS 9999, IN WHICH +C CASE, REPLACE IT BY 1), AND THEN CLOSE EXTNUM. NOTE THAT AS OF +C BESTDOS119.FOR, THE ACTUAL OUTPUT FILE IS OPENED LATER IN THE CODE. +C FOR NOW, JUST ESTABLISH 'NAME'. + +C AS OF BESTDOS119.FOR, THE READING OF EXTNUM TO GET 'NAME' MUST BE +C DONE IN THIS PART OF THE CODE ALSO. THE REASON IS THAT 'NAME' IS +C NEEDED TO ESTABLISH ERRFIL, WHICH WILL NOW BE WRITTEN TO IF THE +C PROGRAM TERMINATES ABNORMALLY. + +C OPEN FILE EXTNUM AND READ THE NO. THERE. + + TMPFILE = ' ' + TMPFILE = 'EXTNUM' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(25,FILE=PATHFILE,STATUS='OLD') + READ(25,*) INUM + +C OBTAIN THE CHARACTER*4 EQUIVALENT TO INUM. + + CALL EQUIV(INUM,NAME) + + +C REPLACE THE NO. IN 'EXTNUM' BY INUM+1 (EXCEPT INUM=9999 IS +C TO BE REPLACED BY 1). + + JNUM=INUM+1 + IF(JNUM .EQ. 10000) JNUM=1 + BACKSPACE(25) + WRITE(25,*) JNUM + CLOSE(25) + +C ESTABLISH ERRFIL, WHICH WILL CONTAIN THE SAME MESSAGE THAT +C IS WRITTEN TO THE SCREEN IN CASE THE PROGRAM STOPS ABNORMALLY. + + ERRFIL = 'ERROR'//NAME + + +C SKIP THIS LINE. IT CONTAINS 'MODEL FILENAME ' + READ(23,*) + READ(23,2) FORFILE + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + + TMPFILE = ' ' + TMPFILE = FORFILE + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(28,FILE=PATHFILE,ERR=9050,STATUS='OLD',POSITION='APPEND') + GO TO 9030 + 9050 WRITE(*,5316) PATHFILE + WRITE(*,9126) + + OPEN(47,FILE=ERRFIL) + WRITE(47,5316) PATHFILE + WRITE(47,9126) + CLOSE(47) + + CALL PAUSE + STOP + + 9030 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,3) + + CLOSE(28) + +C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: + +C NDIM = NO. OF STATES FOR THE O.D.E. +C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. +C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). +C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. +C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE +C TO BE SET BY THE USER. +C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. +C IRAN(I) = 1 IF PARAMATER I IS RANDOM; +C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. + + +C SKIP THIS LINE. IT CONTAINS 'NPAG DENSITY FILE' + READ(23,*) + READ(23,2) NPAGDENFILE + +C NPAGDENFILE CONTAINS THE NAME OF AN NPAG DENSITY FILE; VERIFY THAT +C THIS FILE EXISTS. + + TMPFILE = ' ' + TMPFILE = NPAGDENFILE + + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + + OPEN(67,FILE=PATHFILE,ERR=9040,STATUS='OLD') + GO TO 9055 + 9040 WRITE(*,5316) PATHFILE + WRITE(*,9126) + + OPEN(47,FILE=ERRFIL) + WRITE(47,5316) PATHFILE + WRITE(47,9126) + CLOSE(47) + + + CALL PAUSE + STOP + + 9055 CLOSE(67) + + IF(ICODE .EQ. 5) MAXCYC = 500 + + IF(ICODE .GE. 6) THEN + +C SKIP THIS LINE, IT CONTAINS 'MAXCYC' + READ(23,*) + READ(23,*) MAXCYC + ENDIF + + +C SKIP THIS LINE, IT CONTAINS 'INCLUDPAST' + READ(23,*) + READ(23,*) INCLUDPAST + +C SKIP THIS LINE. IT CONTAINS 'IPASTFILE' + READ(23,*) + READ(23,*) IPASTFILE + +C SKIP THIS LINE. IT CONTAINS 'PASTFILEIN' + READ(23,*) + READ(23,2) PASTFILEIN + READ(23,*) +C THE ABOVE LINE WILL CONTAIN ICOVTYPE(.) INFO ONLY IF IPASTFILE = 1 +C AND NCOVA > 0. IF SO, IT WILL BE REREAD IN SUBROUTINE READBLOCK2. IF +C NOT, THIS LINE WILL BE UNNEEDED AND THEREFORE NOT REREAD. SEE CODE +C IN READBLOCK2 REGARDING IGUI. + +C CHECK THAT PASTFILEIN IS AN EXISTING FILE, UNLESS INCLUDPAST = 0, +C IN WHICH CASE THE USER IS NOT SUPPLYING A PAST FILE (NOTE IF +C IPASTFILE = 1, THE PAST FILE IS IN .CSV FORMAT; AND IF IPASTFILE = 0, +C THE PAST FILE IS IN WORKING COPY FORMAT. + +C NOTE THAT, STARTING WITH BESTDOS106.FOR, AN NPAG RUN WILL BE DONE +C WITH UP TO MAXCYC CYCLES WITH THE PRIOR DENSITY FILE NPAGDENFILE, ON +C THE SUBJECT WHOSE PAST INFO IS IN PASTFILEIN, IF INCLUDPAST = 1 AND +C IPRIOROBS = 1 (SEE BELOW). OTHERWISE, THE NPAG DENSITY FILE INPUT +C ABOVE IN NPAGDENFILE WILL CONTAIN THE PARAMETER DENSITY TO BE USED +C IN THE OPTIMIZATION OF DOSES. + + + IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 0) THEN + + TMPFILE = ' ' + TMPFILE = PASTFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=9060,STATUS='OLD') + GO TO 9075 + 9060 WRITE(*,5316) PATHFILE + WRITE(*,9126) + + + OPEN(47,FILE=ERRFIL) + WRITE(47,5316) PATHFILE + WRITE(47,9126) + CLOSE(47) + + + + CALL PAUSE + STOP + 9075 CONTINUE + + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + CLOSE(21) + + + ENDIF + +C ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1 .AND IPASTFILE .EQ. 0) +C CONDITION. + + + +C IF IPASTFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE +C XQZPJ001.PST IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE +C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON +C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR +C THE FIRST SUBJECT. + + IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) THEN + + TMPFILE = ' ' + TMPFILE = PASTFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,STATUS='OLD') + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + CALL CONVERTCSV + + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT + +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE +C READBLOCK2. + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + REWIND(66) + CALL READBLOCK2(PATH,C0,C1,C2,C3,1,1) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + TMPFILE = ' ' + TMPFILE = 'XQZPJ001.PST' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=9085,STATUS='OLD') + GO TO 9080 + 9085 WRITE(*,5466) PATHFILE,PASTFILEIN + WRITE(*,9126) + + OPEN(47,FILE=ERRFIL) + WRITE(47,5466) PATHFILE,PASTFILEIN + WRITE(47,9126) + CLOSE(47) + + + CALL PAUSE + STOP + + 9080 CONTINUE + + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + CLOSE(21) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) CONDITION. + + +C SKIP THIS LINE. IT CONTAINS 'ICSVFILE' + READ(23,*) + READ(23,*) ICSVFILE + +C SKIP THIS LINE. IT CONTAINS 'FUTUREFILEIN' + READ(23,*) + READ(23,2) FUTUREFILEIN + READ(23,*) +C THE ABOVE LINE WILL CONTAIN ICOVTYPE(.) INFO ONLY IF ICSVFILE = 1, +C AND NCOVA > 0. IF SO, IT WILL BE REREAD IN SUBROUTINE +C READBLOCK2. IF NOT, THIS LINE WILL BE UNNEEDED AND THEREFORE NOT +C REREAD. SEE CODE IN READBLOCK2 REGARDING IGUI. + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + IF(ICSVFILE .EQ. 0) THEN + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + + OPEN(21,FILE=PATHFILE,ERR=9140,STATUS='OLD') + GO TO 9155 + 9140 WRITE(*,5316) PATHFILE + WRITE(*,9126) + + OPEN(47,FILE=ERRFIL) + WRITE(47,5316) PATHFILE + WRITE(47,9126) + CLOSE(47) + + CALL PAUSE + STOP + 9155 CLOSE(21) + + ENDIF + + +C IF ICSVFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE +C XQZPJ001.FUT IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE +C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON +C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR +C THE FIRST SUBJECT. + + IF(ICSVFILE .EQ. 1) THEN + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,STATUS='OLD') + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + CALL CONVERTCSV + + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE +C READBLOCK2. + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + REWIND(66) + CALL READBLOCK2(PATH,C0,C1,C2,C3,2,1) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + TMPFILE = ' ' + TMPFILE = 'XQZPJ001.FUT' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=9165,STATUS='OLD') + + GO TO 9170 + + 9165 WRITE(*,5466) PATHFILE,FUTUREFILEIN + WRITE(*,9126) + + OPEN(47,FILE=ERRFIL) + WRITE(47,5466) PATHFILE,FUTUREFILEIN + WRITE(47,9126) + CLOSE(47) + + CALL PAUSE + STOP + + 9170 CLOSE(21) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. + +C SKIP THIS LINE. IT CONTAINS 'TNEXT'. + READ(23,*) + READ(23,*) TNEXT + + IF(ICODE .LE. 6) IDELTA = 15 + + IF(ICODE .GE. 7) THEN + +C SKIP THIS LINE. IT CONTAINS 'IDELTA'. + READ(23,*) + READ(23,*) IDELTA + + ENDIF + + + +C NOTE THAT NOFIX WAS OBTAINED ABOVE IN THE CALL TO USERPREP, BUT IT + +C MUST BE READ IN BELOW SO THE GUI WILL KNOW WHETHER THE +C FOLLOWING LINE CONTAINS FIXED VALUES OR NOT. + +C SKIP THIS LINE. IT CONTAINS 'NOFIX'. + READ(23,*) + READ(23,*) NOFIX + +C SKIP THIS LINE. IT CONTAINS 'VALFIX ARRAY IF NOFIX > 0'. + READ(23,*) + IF(NOFIX .GT. 0) READ(23,*) (VALFIX(I),I=1,NOFIX) + +C CHECK THAT NOFIX .LE. 20. IF NOT, PRINT MESSAGE TO USER AND STOP. + + IF(NOFIX .GT. 20) THEN + + WRITE(*,9177) NOFIX + 9177 FORMAT(/' NOFIX WAS READ IN FROM "GUICMDS.INX" TO '/ + 1' BE ', I3,'. THIS IS > 20, THE MAXIMUM ALLOWED VALUE.'// + 2' PLEASE RERUN THE PROGRAM UNDER DOS WITH KEYBOARD ENTRY, OR USE'/ + 3' AN INSTRUCTION FILE HAVING NOFIX .LE. 20.') + + OPEN(47,FILE=ERRFIL) + WRITE(47,9177) NOFIX + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + +C SKIP THIS LINE. IT CONTAINS 'TOLER'. + READ(23,*) + READ(23,*) TOLER + RTOL = TOLER + + DO I=1,NDIM + ATOL(I) = TOLER + END DO + + MF = 22 + + +C SKIP THIS LINE. IT CONTAINS 'NUMEQT'. + READ(23,*) + READ(23,*) NUMEQT + + +C SKIP THIS LINE. IT CONTAINS 'NUMEQT LINES OF ASSAY COEFFICIENTS'. + READ(23,*) + + DO IEQ=1,NUMEQT + READ(23,*) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + END DO + +C SKIP THIS LINE. IT CONTAINS 'IERRMOD'. + READ(23,*) + + READ(23,*) IERRMOD + +C SKIP THIS LINE. IT CONTAINS 'GAMLAM + READ(23,*) + READ(23,*) GAMLAM + + +C SKIP THIS LINE. IT CONTAINS 'IASS(I),I=1,NUMEQT'. + READ(23,*) + READ(23,*) (IASS(I),I=1,NUMEQT) + +C SKIP THIS LINE. IT CONTAINS 'NDRUG'. + READ(23,*) + READ(23,*) NDRUG + +C SKIP THIS LINE. IT CONTAINS 'AF(I),I=1,NDRUG'. + READ(23,*) + READ(23,*) (AF(I),I=1,NDRUG) + + IF(ICODE .LE. 7) IOPTIMIZE = 1 + + IF(ICODE .GE. 8) THEN + +C SKIP THIS LINE. IT CONTAINS 'IOPTIMIZE'. + READ(23,*) + READ(23,*) IOPTIMIZE + + ENDIF + + + IF(ICODE .LE. 8) BIASWEIGHT = 0.D0 + + IF(ICODE .GE. 9) THEN + +C SKIP THIS LINE. IT CONTAINS 'BIASWEIGHT'. + READ(23,*) + READ(23,*) BIASWEIGHT + + ENDIF + + IF(ICODE .LE. 9) ITARGET = 1 + + IF(ICODE .GE. 10) THEN + +C SKIP THIS LINE. IT CONTAINS 'ITARGET'. + READ(23,*) + READ(23,*) ITARGET + + ENDIF + + + + CLOSE(23) + +C NOW PROCEED TO LABEL 1450 WHICH WILL RUN THE PROGRAM USING ALL THE +C INFO READ IN FROM FILE 39 ... WITH NO USER INTERACTION (I.E., +C SUBROUTINE VERIF1 WILL NOT BE CALLED, AND THE USER WILL NOT BE ASKED +C IF HE WANTS TO SAVE INFORMATION INTO A DIFFERENT INSTRUCTION FILE). + + GO TO 1450 + + + 1210 CONTINUE + +C TO GET HERE MEANS THERE IS NO FILE, 'GUICMDS.INX' IN THE WORKING +C DIRECTORY, SO PROCEED AS USUAL TO OBTAIN INPUT INSTRUCTIONS FROM +C THE USER. + + +C CALL GETPATH TO GET FROM THE USER THE PATH WHERE THE INPUT FILES ARE +C LOCATED (AND WHERE THE OUTPUT FILES WILL GO). NOTE THAT PATH IS THE +C PATH WITH A TRAILING BACKSLASH, AND NOB IS THE NO. OF THE ENTRY WITH +C THE LAST NON-BLANK ENTRY. + + CALL GETPATH(PATH,NOB) + +C FIND xxxx, WHICH WILL BE THE 4-DIGIT EXTENSION ASSIGNED TO +C THE OUTPUT FILE AND ERROR FILE NAMES BELOW. NOTE THAT xxxx IS +C THE 4-CHARACTER REPRESENTATION OF THE INTEGER +C CURRENTLY IN THE FILE, EXTNUM, IN THE WORKING DIRECTORY. GET THIS +C INTEGER NOW, AND REPLACE IT BY 1 MORE (UNLESS IT IS 9999, IN WHICH +C CASE, REPLACE IT BY 1), AND THEN CLOSE EXTNUM. NOTE THAT AS OF +C BESTDOS119.FOR, THE ACTUAL OUTPUT FILE IS OPENED LATER IN THE CODE. +C FOR NOW, JUST ESTABLISH 'NAME'. + +C AS OF BESTDOS119.FOR, THE READING OF EXTNUM TO GET 'NAME' IS MOVED +C HERE, TO THE TOP OF THE CODE. THE REASON IS THAT 'NAME' IS NEEDED +C TO ESTABLISH ERRFIL, WHICH WILL NOW BE WRITTEN TO IF THE PROGRAM +C TERMINATES ABNORMALLY. + + +C OPEN FILE EXTNUM AND READ THE NO. THERE. + + TMPFILE = ' ' + TMPFILE = 'EXTNUM' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(25,FILE=PATHFILE,STATUS='OLD') + READ(25,*) INUM + +C OBTAIN THE CHARACTER*4 EQUIVALENT TO INUM. + + CALL EQUIV(INUM,NAME) + + +C REPLACE THE NO. IN 'EXTNUM' BY INUM+1 (EXCEPT INUM=9999 IS +C TO BE REPLACED BY 1). + + JNUM=INUM+1 + IF(JNUM .EQ. 10000) JNUM=1 + BACKSPACE(25) + WRITE(25,*) JNUM + CLOSE(25) + +C ESTABLISH ERRFIL, WHICH WILL CONTAIN THE SAME MESSAGE THAT +C IS WRITTEN TO THE SCREEN IN CASE THE PROGRAM STOPS ABNORMALLY. + + ERRFIL = 'ERROR'//NAME + + +C AS OF BESTDOS119.FOR, FORMAT 1416 INDICATES THAT STEADY STATE DOSES +C MAY OCCUR IN THE "PAST", BUT ONLY AT THE BEGINNING OF A PATIENT +C FILE; I.E., DOSE RESETS ARE STILL NOT ALLOWED. + + WRITE(*,1416) + 1416 FORMAT(//' ******* WARNING *******'/ + 1' STEADY STATE DOSE SETS AT THE BEGINNING OF THE PATIENT FILE'/ + 2' ARE ALLOWED. BUT IF YOUR PATIENT INFORMATION INCLUDES DOSE '/ + 3' RESETS, PLEASE STOP NOW. IF YOU CONTINUE, YOUR RESULTS WILL BE'/ + 4' UNPREDICTABLE.'/ + 5' ******* WARNING *******'//) + + + + 145 WRITE(*,38) + 38 FORMAT(/' ENTER 0 IF INPUT IS TO BE FROM THE KEYBOARD; '/ + 1' ENTER 1 IF INPUT IS TO BE FROM A FILE: ') + READ(*,*,ERR=145) INOPT + IF(INOPT .NE. 0 .AND. INOPT .NE. 1) GO TO 145 + + + IF(INOPT .EQ. 1) THEN + + WRITE(*,39) + 39 FORMAT(/' ENTER THE NAME OF THE INSTRUCTION FILE; '/ + 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + + READ(*,2) FILNFO + IF(FILNFO(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FILNFO) + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = FILNFO + + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(23,FILE=PATHFILE,ERR=6330,STATUS='OLD') + GO TO 6335 + 6330 WRITE(*,5316) PATHFILE + 5316 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ + 1' ',A73) + GO TO 145 + 6335 CONTINUE + + +C READ ALL INPUT DATA FROM FILE FILNFO, WHICH WAS FILLED FROM A +C PREVIOUS RUNNING OF THIS PROGRAM. + +C THE 1ST LINE IN FILNFO IS THE CODE WHICH GIVES THE VERSION NO. OF +C THE PROGRAM. + + + READ(23,7123) CODE + + + 7123 FORMAT(A14) + + + ICODE = 0 +C IF(CODE .EQ. 'BESTDOS JUN_11') ICODE = 01 +C IF(CODE .EQ. 'BESTDOS JUL_11') ICODE = 02 +C IF(CODE .EQ. 'BESTDOS AUG_11') ICODE = 03 +C IF(CODE .EQ. 'BESTDOS SEP_11') ICODE = 04 + IF(CODE .EQ. 'BESTDOS MAR_13') ICODE = 05 + IF(CODE .EQ. 'BESTDOS APR_13') ICODE = 06 + IF(CODE .EQ. 'BESTDOS MAY_13') ICODE = 07 + IF(CODE .EQ. 'BESTDOS JUN_13') ICODE = 08 + IF(CODE .EQ. 'BESTDOS SEP_13') ICODE = 09 + IF(CODE .EQ. 'BESTDOS OCT_13') ICODE = 10 + + IF(ICODE .EQ. 0) THEN + WRITE(*,7124) + 7124 FORMAT(/' THIS FILE IS NOT AN UP-TO-DATE INSTRUCTION FILE'/ + 1' FOR THIS PROGRAM. '// + 2' YOU HAVE THE FOLLOWING 2 OPTIONS:'// + 3' YOU MAY USE A SAVED INSTRUCTION FILE FROM A PREVIOUS RUNNING '/ + 4' OF THIS PROGRAM. THE 1ST LINE OF THE SAVED FILE MUST HAVE '/ + 5' BESTDOS XXX_XX, WHERE XXX_XX IS MAR_13 OR A MORE RECENT DATE.'// + 6' OR YOU MAY SIMPLY ENTER DATA FROM THE KEYBOARD.'/) + CALL PAUSE + GO TO 145 + ENDIF + +C SKIP THIS LINE. IT CONTAINS 'MODEL FILENAME ' + READ(23,*) + READ(23,2) FORFILE + WRITE(*,1919) FORFILE + 1919 FORMAT(/' HAVE YOU ALREADY LINKED FILE ',A20,' WITH THIS '/ + 1' PROGRAM, AND IS THIS FILE AN EDITED VERSION OF TSTMULTM.FOR?'// + 2' IF NOT, STOP NOW, AND RERUN THE PROGRAM AFTER VERIFYING BOTH '/ + 3' ITEMS ABOVE.'/) + CALL PAUSE + + + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + + 7010 TMPFILE = ' ' + TMPFILE = FORFILE + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(28,FILE=PATHFILE,ERR=7050,STATUS='OLD',POSITION='APPEND') + GO TO 7030 + 7050 WRITE(*,4406) FORFILE + READ(*,2) FORFILE + IF(FORFILE(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FORFILE) + GO TO 7010 + + 7030 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,INOPT) + + + CLOSE(28) + +C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: + +C NDIM = NO. OF STATES FOR THE O.D.E. +C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. +C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). +C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. +C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE +C TO BE SET BY THE USER. +C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. +C IRAN(I) = 1 IF PARAMATER I IS RANDOM; +C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. + +C SKIP THIS LINE. IT CONTAINS 'NPAG DENSITY FILE' + READ(23,*) + READ(23,2) NPAGDENFILE + +C NPAGDENFILE CONTAINS THE NAME OF AN NPAG DENSITY FILE; VERIFY THAT +C THIS FILE EXISTS. + + TMPFILE = ' ' + TMPFILE = NPAGDENFILE + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(67,FILE=PATHFILE,ERR=9440,STATUS='OLD') + GO TO 9455 + 9440 WRITE(*,5316) PATHFILE + + OPEN(47,FILE=ERRFIL) + WRITE(47,5316) PATHFILE + CLOSE(47) + + CALL PAUSE + STOP + 9455 CLOSE(67) + + + IF(ICODE .EQ. 5) MAXCYC = 500 + + IF(ICODE .GE. 6) THEN + +C SKIP THIS LINE, IT CONTAINS 'MAXCYC' + READ(23,*) + READ(23,*) MAXCYC + + ENDIF + + +C SKIP THIS LINE, IT CONTAINS 'INCLUDPAST' + READ(23,*) + READ(23,*) INCLUDPAST + +C SKIP THIS LINE. IT CONTAINS 'IPASTFILE' + READ(23,*) + + READ(23,*) IPASTFILE + +C SKIP THIS LINE. IT CONTAINS 'PASTFILEIN' + READ(23,*) + READ(23,2) PASTFILEIN + +C CHECK THAT PASTFILEIN IS AN EXISTING FILE, UNLESS INCLUDPAST = 0, +C IN WHICH CASE THE USER IS NOT SUPPLYING A PAST FILE (NOTE IF +C IPASTFILE = 1, THE PAST FILE IS IN .CSV FORMAT; AND IF IPASTFILE = 0, +C THE PAST FILE IS IN WORKING COPY FORMAT. + + +C NOTE THAT, STARTING WITH BESTDOS106.FOR, AN NPAG RUN WILL BE DONE +C WITH UP TO MAXCYC CYCLES WITH THE PRIOR DENSITY FILE NPAGDENFILE, ON +C THE SUBJECT WHOSE PAST INFO IS IN PASTFILEIN, IF INCLUDPAST = 1 AND +C IPRIOROBS = 1 (SEE BELOW). OTHERWISE, THE NPAG DENSITY FILE INPUT +C ABOVE IN NPAGDENFILE WILL CONTAIN THE PARAMETER DENSITY TO BE USED + +C IN THE OPTIMIZATION OF DOSES. + + IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 0) THEN + + TMPFILE = ' ' + TMPFILE = PASTFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + + OPEN(21,FILE=PATHFILE,ERR=8460,STATUS='OLD') + GO TO 8475 +8460 WRITE(*,5316) PATHFILE + + OPEN(47,FILE=ERRFIL) + WRITE(47,5316) PATHFILE + CLOSE(47) + + CALL PAUSE + STOP + + 8475 CONTINUE + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE + +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + CLOSE(21) + + ENDIF + +C ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1 .AND IPASTFILE .EQ. 0) +C CONDITION. + + +C IF IPASTFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE +C XQZPJ001.PST IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE +C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON + +C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR +C THE FIRST SUBJECT. + + IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) THEN + + TMPFILE = ' ' + TMPFILE = PASTFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,STATUS='OLD') + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + CALL CONVERTCSV + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO + +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE +C READBLOCK2. + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + REWIND(66) + CALL READBLOCK2(PATH,C0,C1,C2,C3,1,0) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + TMPFILE = ' ' + TMPFILE = 'XQZPJ001.PST' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8485,STATUS='OLD') + GO TO 8480 + 8485 WRITE(*,5466) PATHFILE,PASTFILEIN + + OPEN(47,FILE=ERRFIL) + WRITE(47,5466) PATHFILE,PASTFILEIN + CLOSE(47) + + + CALL PAUSE + STOP + + 8480 CONTINUE + + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR + +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + CLOSE(21) + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE +C IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) CONDITION. + +C SKIP THIS LINE. IT CONTAINS 'ICSVFILE' + READ(23,*) + READ(23,*) ICSVFILE + +C SKIP THIS LINE. IT CONTAINS 'FUTUREFILEIN' + READ(23,*) + READ(23,2) FUTUREFILEIN + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + IF(ICSVFILE .EQ. 0) THEN + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8440,STATUS='OLD') + GO TO 8455 + 8440 WRITE(*,5316) PATHFILE + + OPEN(47,FILE=ERRFIL) + WRITE(47,5316) PATHFILE + CLOSE(47) + + + CALL PAUSE + STOP + + 8455 CLOSE(21) + + ENDIF + + +C IF ICSVFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE +C XQZPJ001.FUT IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE +C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON +C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR +C THE FIRST SUBJECT. + + IF(ICSVFILE .EQ. 1) THEN + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,STATUS='OLD') + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + CALL CONVERTCSV + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE +C READBLOCK2. + + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + REWIND(66) + CALL READBLOCK2(PATH,C0,C1,C2,C3,2,0) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + TMPFILE = ' ' + TMPFILE = 'XQZPJ001.FUT' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8465,STATUS='OLD') + + GO TO 8470 + 8465 WRITE(*,5466) PATHFILE,FUTUREFILEIN + + OPEN(47,FILE=ERRFIL) + WRITE(47,5466) PATHFILE,FUTUREFILEIN + CLOSE(47) + + CALL PAUSE + STOP + + 8470 CLOSE(21) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. + + +C SKIP THIS LINE. IT CONTAINS 'TNEXT'. + READ(23,*) + READ(23,*) TNEXT + + + IF(ICODE .LE. 6) IDELTA = 15 + + IF(ICODE .GE. 7) THEN + +C SKIP THIS LINE. IT CONTAINS 'IDELTA'. + READ(23,*) + READ(23,*) IDELTA + + ENDIF + + +C NOTE THAT NOFIX WAS OBTAINED ABOVE IN THE CALL TO USERPREP, BUT IT +C MUST BE READ IN BELOW SO THE GUI WILL KNOW WHETHER THE +C FOLLOWING LINE CONTAINS FIXED VALUES OR NOT. + +C SKIP THIS LINE. IT CONTAINS 'NOFIX'. + READ(23,*) + + + READ(23,*) NOFIX + +C SKIP THIS LINE. IT CONTAINS 'VALFIX ARRAY IF NOFIX > 0'. + READ(23,*) + IF(NOFIX .GT. 0) READ(23,*) (VALFIX(I),I=1,NOFIX) + +C CHECK THAT NOFIX .LE. 20. IF NOT, PRINT MESSAGE TO USER AND STOP. + + IF(NOFIX .GT. 20) THEN + + WRITE(*,3177) NOFIX + 3177 FORMAT(/' NOFIX WAS READ IN FROM THE INSTRUCTION FILE TO '/ + 1' BE ', I3,'. THIS IS > 20, THE MAXIMUM ALLOWED VALUE.'// + + + 2' PLEASE RERUN THE PROGRAM WITH KEYBOARD ENTRY, OR USE AN '/ + 3' INSTRUCTION FILE HAVING NOFIX .LE. 20.') + + OPEN(47,FILE=ERRFIL) + WRITE(47,3177) NOFIX + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + +C SKIP THIS LINE. IT CONTAINS 'TOLER'. + READ(23,*) + READ(23,*) TOLER + RTOL = TOLER + + DO I=1,NDIM + ATOL(I) = TOLER + + + END DO + + MF = 22 + +C SKIP THIS LINE. IT CONTAINS 'NUMEQT'. + READ(23,*) + READ(23,*) NUMEQT + +C SKIP THIS LINE. IT CONTAINS 'NUMEQT LINES OF ASSAY COEFFICIENTS'. + READ(23,*) + + DO IEQ=1,NUMEQT + READ(23,*) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + END DO + +C SKIP THIS LINE. IT CONTAINS 'IERRMOD'. + READ(23,*) + READ(23,*) IERRMOD + +C SKIP THIS LINE. IT CONTAINS 'GAMLAM + READ(23,*) + READ(23,*) GAMLAM + + +C SKIP THIS LINE. IT CONTAINS 'IASS(I),I=1,NUMEQT'. + READ(23,*) + READ(23,*) (IASS(I),I=1,NUMEQT) + +C SKIP THIS LINE. IT CONTAINS 'NDRUG'. + READ(23,*) + READ(23,*) NDRUG + +C SKIP THIS LINE. IT CONTAINS 'AF(I),I=1,NDRUG'. + READ(23,*) + READ(23,*) (AF(I),I=1,NDRUG) + + + IF(ICODE .LE. 7) IOPTIMIZE = 1 + + IF(ICODE .GE. 8) THEN + +C SKIP THIS LINE. IT CONTAINS 'IOPTIMIZE'. + READ(23,*) + READ(23,*) IOPTIMIZE + + ENDIF + + + + IF(ICODE .LE. 8) BIASWEIGHT = 0.D0 + + IF(ICODE .GE. 9) THEN + +C SKIP THIS LINE. IT CONTAINS 'BIASWEIGHT'. + READ(23,*) + READ(23,*) BIASWEIGHT + + ENDIF + + + IF(ICODE .LE. 9) ITARGET = 1 + + IF(ICODE .GE. 10) THEN + +C SKIP THIS LINE. IT CONTAINS 'ITARGET'. + READ(23,*) + READ(23,*) ITARGET + + ENDIF + + + CLOSE(23) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 1) CONDITION. + + + IF(INOPT .EQ. 0) THEN + + + WRITE(*,919) + 919 FORMAT(/' HAVE YOU ALREADY MADE YOUR FORTRAN MODEL FILE AS AN'/ + 1' EDITED VERSION OF THE TEMPLATE MODEL FILE, TSTMULTM.FOR, AND'/ + 2' HAVE YOU COMPILED AND LINKED THIS FILE INTO THIS PROGRAM?'// + 4' IF NOT, STOP NOW, AND THEN RERUN THIS PROGRAM AFTER DOING SO.'/) + + CALL PAUSE + + +C INPUT THE NAME OF THE FORTRAN FILE BASED ON THE TEMPLATE MODEL +C FILE, TSTMULTM.FOR (AS OF BESTDOS119.FOR), WHICH IDENTIFIES THE +C MODEL AND THE PARAMETERS FOR THE USER'S ANALYSIS. THEN CALL +C SUBROUTINE USERPREP TO INPUT VALUES FROM THIS FILE. + + + WRITE(*,5001) + + + 5001 FORMAT(/' ENTER THE NAME OF THE FORTRAN FILE (EDITED FROM '/ + 1' TEMPLATE MODEL FILE, TSTMULTM.FOR, WHICH YOU LINKED TO THIS'/ + 2' PROGRAM, AND WHICH CONTAINS THE CODE FOR THE MODEL YOU WOULD'/ + 3' LIKE TO ANALYZE: ') + READ(*,2) FORFILE + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + 5010 TMPFILE = ' ' + TMPFILE = FORFILE + + + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(28,FILE=PATHFILE,ERR=50,STATUS='OLD',POSITION='APPEND') + GO TO 30 + 50 WRITE(*,4406) FORFILE + 4406 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ + 1' ',A73/ + 2' ENTER THE CORRECT FILENAME OR ... '/ + 2' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,2) FORFILE + + + IF(FORFILE(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FORFILE) + GO TO 5010 + + 30 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,INOPT) + + + CLOSE(28) + +C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: + +C NDIM = NO. OF STATES FOR THE O.D.E. +C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. +C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). + +C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. +C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE +C TO BE SET BY THE USER. +C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. +C IRAN(I) = 1 IF PARAMATER I IS RANDOM; +C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. + + + 8010 WRITE(*,8013) + 8013 FORMAT(/' THIS PROGRAM REQUIRES AN NPAG DENSITY FROM A PREVIOUS'/ + 1' ANALYSIS OF A POPULATION. THIS NPAG DENSITY WILL BE USED AS'/ + 2' THE PARAMETER DENSITY FOR THE OPTIMIZATION OVER THE DOSES IN'/ + 3' THE "FUTURE" OF THE SUBJECT BEING CONSIDERED IN THIS RUN IF'/ + 4' THERE IS NO "PAST" HISTORY FOR THE SUBJECT, OR IF THE "PAST"'/ + 5' HISTORY INCLUDES NO OBSERVED VALUES.'// + 6' BUT IF THERE IS A "PAST" HISTORY FOR THE SUBJECT, AND IT '/ + 7' INCLUDES OBSERVATIONS, THEN THE NPAG DENSITY WILL BE USED AS'/ + 8' AS A PRIOR DENSITY FOR ANOTHER NPAG RUN WHICH WILL OBTAIN A'/ + 9' POSTERIOR DENSITY FOR THE SUBJECT, AND THIS NEW DENSITY WILL'/ + 1' THEN BE THE DENSITY FOR THE OPTIMIZATION. '// + 1' ENTER THE NAME OF THE FILE WHICH CONTAINS THE NPAG DENSITY'/ + 2' FROM A PREVIOUS ANALYSIS OF A POPULATION (IT WILL PROBABLY'/ + 3' BE DENxxxx, WHERE xxxx WAS THE JOB NUMBER): '// + 4' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,2) NPAGDENFILE + IF(NPAGDENFILE(1:3) .EQ. '-99') + 1 CALL SEEDIR(PATH,NOB,NPAGDENFILE) + + + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = NPAGDENFILE + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8020,STATUS='OLD') + GO TO 8025 + 8020 WRITE(*,5316) PATHFILE + GO TO 8010 + 8025 CLOSE(21) + + + 8030 WRITE(*,8031) + 8031 FORMAT(/' ENTER 1 IF THE CALCULATIONS ARE TO INCLUDE THE "PAST" '/ + 1' HISTORY FOR THE SUBJECT OF THIS RUN;'/ + 2' ENTER 0 OTHERWISE: ') + READ(*,*,ERR=8030) INCLUDPAST + IF(INCLUDPAST .NE. 1 .AND. INCLUDPAST .NE. 0) GO TO 8030 + + IF(INCLUDPAST .EQ. 0) THEN + IPASTFILE = -1 + PASTFILEIN = 'NOT USED' + ENDIF + +8035 IF(INCLUDPAST .EQ. 1) THEN + + WRITE(*,8003) +8003 FORMAT(/' ENTER 1 IF THE FILE WHICH HAS THE "PAST" INFO FOR'/ + 1' THE SUBJECT OF THIS RUN IS A .CSV FILE (IN THIS CASE,'/ + 2' THE INFO FOR THE FIRST SUBJECT IN THE .CSV FILE WILL'/ + 3' BE USED); '/ + 4' ENTER 0 IF THE FILE WHICH HAS THE "PAST" INFO FOR THE SUBJECT'/ + 5' OF THIS RUN IS A WORKING COPY FILE: ') + READ(*,*,ERR=8035) IPASTFILE + IF(IPASTFILE .NE. 1 .AND. IPASTFILE .NE. 0) GO TO 8035 + + IF(IPASTFILE .EQ. 0) THEN + + WRITE(*,1021) + READ(*,2) PASTFILEIN + IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = PASTFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8050,STATUS='OLD') + GO TO 8045 + + 8050 WRITE(*,5316) PATHFILE + GO TO 8030 + + 8045 CONTINUE + + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + CLOSE(21) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 0) CONDITION. + + + IF(IPASTFILE .EQ. 1) THEN + + WRITE(*,8021) + 8021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ + 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ + 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// + 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,2) PASTFILEIN + IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = PASTFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,ERR=8060,STATUS='OLD') + + GO TO 8055 + 8060 WRITE(*,5316) PATHFILE + GO TO 8030 + 8055 CONTINUE + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + + CALL CONVERTCSV + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE + +C READBLOCK2. + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + +C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.PST IN THE +C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN +C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. + + REWIND(66) + + CALL READBLOCK2(PATH,C0,C1,C2,C3,1,0) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + TMPFILE = ' ' + TMPFILE = 'XQZPJ001.PST' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8065,STATUS='OLD') + GO TO 8070 + 8065 WRITE(*,5466) PATHFILE,PASTFILEIN + GO TO 8030 + + 8070 CONTINUE + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + CLOSE(21) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 1) CONDITION. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1) CONDITION. + + + IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN + + + 8080 WRITE(*,8077) + 8077 FORMAT(/' FOR THE NPAG ANALYSIS WHICH WILL OBTAIN THE POSTERIOR'/ + 1' DENSITY (WHICH WILL THEN BE THE DENSITY FOR THE OPTIMIZATION)'/ + 2' SELECT THE MAXIMUM NO. OF CYCLES IT SHOULD RUN. THE DEFAULT'/ + 3' IS A MAXIMUM OF 500 CYCLES. '// + 4' SELECT 1 FOR 500 CYCLE;'/ + 5' SELECT 0 FOR A DIFFERERENT NO. OF MAXIMUM CYCLES: ') + READ(*,*,ERR=8080) MAXCYC + IF(MAXCYC .NE. 1 .AND. MAXCYC .NE. 0) GO TO 8080 + + IF(MAXCYC .EQ. 1) MAXCYC = 500 + + IF(MAXCYC .EQ. 0) THEN + 8090 WRITE(*,8091) + 8091 FORMAT(/' ENTER A POSITIVE NO. FOR THE MAXIMUM NO. OF CYCLES'/ + 1' THE NPAG ANALYSIS SHOULD RUN: ') + READ(*,*,ERR=8090) MAXCYC + IF(MAXCYC .LT. 1) GO TO 8090 + ENDIF + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. + + + + 5020 WRITE(*,5002) + 5002 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN CAN BE INPUT VIA'/ + 1' A (MULTIPLE DRUG) WORKING COPY PATIENT DATA FILE OR A BLOCK '/ + 2' MATRIX .CSV FILE (THE INFO WILL COME FROM THE DATA OF THE'/ + 3' FIRST SUBJECT IN THIS CASE).'// + 5' ENTER 1 TO ENTER INFO USING A .CSV FILE; '/ + 6' ENTER 0 TO ENTER INFO USING A WORKING COPY PATIENT DATA FILE: ') + READ(*,*,ERR=5020) ICSVFILE + IF(ICSVFILE .NE. 1 .AND. ICSVFILE .NE. 0) GO TO 5020 + + + IF(ICSVFILE .EQ. 0) THEN + + WRITE(*,1021) + 1021 FORMAT(/' ENTER THE NAME OF THE WORKING COPY PATIENT DATA FILE.' + 1// + 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,2) FUTUREFILEIN + IF(FUTUREFILEIN(1:3) .EQ. '-99') + 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE + +C CURRENT DIRECTORY). + + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=6440,STATUS='OLD') + GO TO 6455 + 6440 WRITE(*,5316) PATHFILE + GO TO 5020 + 6455 CONTINUE + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 0) CONDITION. + + + IF(ICSVFILE .EQ. 1) THEN + + WRITE(*,3021) + 3021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ + 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ + 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// + 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,2) FUTUREFILEIN + IF(FUTUREFILEIN(1:3) .EQ. '-99') + 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,ERR=5440,STATUS='OLD') + + GO TO 5455 + 5440 WRITE(*,5316) PATHFILE + GO TO 5020 + 5455 CONTINUE + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, + + +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + CALL CONVERTCSV + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF + + +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE +C READBLOCK2. + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + +C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.FUT IN THE +C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN +C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. + + REWIND(66) + + CALL READBLOCK2(PATH,C0,C1,C2,C3,2,0) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + + TMPFILE = ' ' + TMPFILE = 'XQZPJ001.FUT' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=5465,STATUS='OLD') + GO TO 5470 + 5465 WRITE(*,5466) PATHFILE,FUTUREFILEIN + 5466 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ + 1' ',A73/ + 2' WHICH MEANS THAT YOUR .CSV FILE, ',A20,' WAS NOT READ '/ + 3' PROPERLY. PLEASE CHECK THIS FILE TO MAKE SURE IT IS CORRECT.'//) + GO TO 5020 + + + 5470 CONTINUE + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. + +C AT THIS POINT, FILE 21 CONTAINS THE WORKING COPY FILE TO BE USED +C FOR THIS RUN (VIA EITHER THE ICSVFILE .EQ. 0 OR THE ICSVFILE .EQ. 1 +C BLOCK). CALL GETNUMEQ WHICH WILL READ THIS FILE 21 AND OBTAIN +C NUMEQT AND NDRUG. + + CALL GETNUMEQ(NUMEQT,NDRUG) + CLOSE(21) + +C IF INCLUDPAST = 0, IT MEANS THAT THE USER IS PROVIDING NO "PAST" +C HISTORY FOR THE SUBJECT. IN THIS CASE, SET TNEXT = 0.0. OTHERWISE, +C HAVE THE USER ENTER TNEXT. + + IF(INCLUDPAST .EQ. 0) TNEXT = 0.D0 + + IF(INCLUDPAST .EQ. 1) THEN + 8040 WRITE(*,8041) PASTFILEIN,FUTUREFILEIN + 8041 FORMAT(/' YOUR ANALYSIS INCLUDES THE "PAST" HISTORY FOR THE'/ + 1' SUBJECT IN FILE ',A20,' AND THE "FUTURE" IN FILE ',A20/ + 2' IT WILL BE ASSUMED THAT THE "PAST" BEGINS AT TIME = 0, AND THE'/ + 3' "FUTURE" BEGINS AT TIME = TNEXT. IN OTHER WORDS, THE "FUTURE"'/ + 4' FILE SHOULD START AS USUAL WITH TIME = 0, BUT ALL THE TIMES IN'/ + 5' THIS FILE WILL BE INCREASED BY TNEXT HOURS, AND THEN THIS FILE'/ + 6' WILL BE CONCATENATED TO THE "PAST" TO PROVIDE A COMPLETE'/ + 7' DOSING/OBSERVED VALUE PROFILE OF THE SUBJECT.'// + 8' BUT NOTE THAT OPTIMUM DOSES WILL BE FOUND ONLY IN THE "FUTURE"'/ + 9' TO BEST ACHIEVE THE OBSERVED VALUES IN THE "FUTURE" ... BASED'/ + 1' ON THE "PAST" HISTORY. '// + 2' ENTER TNEXT, A POSTIVE NO. OF HOURS, NOW: ') + READ(*,*,ERR=8040) TNEXT + IF(TNEXT .LE. 0.D0) GO TO 8040 + ENDIF + + 8170 WRITE(*,8172) + 8172 FORMAT(/' THE OUTPUT FILE WILL INCLUDE, FOR EACH GRID POINT IN '/ + 1' THE PARAMETER DENSITY (AND THE WEIGHTED MEAN OF THESE GRID'/ + 2' POINTS), SIMULATED OBSERVED VALUES, BASED ON THE OPTIMAL DOSES'/ + 3' WHICH THE PROGRAM CALCULATES.'// + 4' ENTER 1 IF THESE VALUES SHOULD BE SIMULATED EVERY 15 MINUTES'/ + 5' 0 FOR A DIFFERENT NO. OF MINUTES BETWEEN SIMULATED VALUES: + 6 ') + + READ(*,*,ERR=8170) IDELTA + IF(IDELTA .NE. 1 .AND. IDELTA .NE. 0) GO TO 8170 + + IF(IDELTA .EQ. 1) IDELTA = 15 + + + IF(IDELTA .EQ. 0) THEN + + WRITE(*,8173) + 8173 FORMAT(/' ENTER THE NO. OF MINUTES BETWEEN SIMULATED VALUES: ') + READ(*,*,ERR=8170) IDELTA + IF(IDELTA .LE. 0) GO TO 8170 + ENDIF + + +C ENTER THE FIXED VALUES FOR THE PARAMETERS. + + IF(NOFIX .GT. 0) THEN + WRITE(*,4836) + 4836 FORMAT(/' ENTER THE VALUE FOR EACH FIXED PARAMETER: ') + DO I = 1,NOFIX + 4845 WRITE(*,34) PARFIX(I) + 34 FORMAT(/' ',A11,' : ') + 4840 READ(*,*,ERR=4845) VALFIX(I) + END DO + ENDIF + + +C READ IN VALUES FOR MF, RTOL, AND ATOL, WHICH ARE NEEDED FOR THE +C O.D.E. SOLVER USED BY ROUTINE USERANAL. + +C MF = Method flag. Standard values are.. +C 10 for nonstiff (Adams) method, no Jacobian used. +C 21 for stiff (BDF) method, user-supplied full Jacobian. +C 22 for stiff method, internally generated full Jacobian. + +C FOR NOW MF = 22 WILL BE HARDCODED (SINCE THERE IS NO +C JACOBIAN SUBROUTINE (JACOB HAS BEEN TAKEN OUT FOR NOW). + +C 24 for stiff method, user-supplied banded Jacobian. +C 25 for stiff method, internally generated banded Jacobian. +C RTOL = Relative tolerance parameter (scalar). +C ATOL = Absolute tolerance parameter. +C The estimated local error in X(i) will be controlled so as +C to be roughly less (in magnitude) than +C EWT(i) = RTOL*abs(X(i)) + ATOL(i) SINCE ITOL = 2. + +C Thus the local error test passes if, in each component, +C either the absolute error is less than ATOL (or ATOL(i)), +C or the relative error is less than RTOL. +C Use RTOL = 0.0 for pure absolute error control, and +C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error +C control. Caution.. Actual (global) errors may exceed these +C local tolerances, so choose them conservatively. + + + + 915 WRITE(*,913) + 913 FORMAT(/' ENTER 1 TO SET ALL TOLERANCES (FOR THE O.D.E. '/ + 1' SOLVER) TO THE DEFAULT VALUE ... 1.D-4.'/ + 2' ENTER 0 TO SELECT A DIFFERENT VALUE FOR THE TOLERANCES: ') + READ(*,*,ERR=915) ITOL + IF(ITOL .NE. 0 .AND. ITOL .NE. 1) GO TO 915 + + TOLER = 1.D-4 + + + IF(ITOL .EQ. 0) THEN + + 910 WRITE(*,914) + 914 FORMAT(/' ENTER A POSITIVE VALUE FOR THE TOLERANCE PARAMETERS: ') + READ(*,*,ERR=910) TOLER + IF(TOLER .LE. 0.D0) GO TO 910 + + ENDIF + + + RTOL = TOLER + DO I=1,NDIM + ATOL(I) = TOLER + END DO + + MF = 22 + +C ENTER IERRMOD AND GAMLAM HERE. + + CALL SYSTEM('CLS') + + 1110 WRITE(*,118) NPAGDENFILE + 118 FORMAT(//' SELECT HOW YOU MODELED THE ASSAY ERROR FUNCTION IN '/ + 1' THE NPAG RUN YOU DID WHICH PRODUCED THE DENSITY FILE, ',A20// + 1' RECALL THAT SD1 = C0+C1*Y+C2*Y**2+C3*Y**3; THEN ...'// + 2' ENTER 1 IF S.D. = SD1;'/ + 3' ENTER 2 IF S.D. = GAMMA*SD1, WITH GAMMA TO BE ESTIMATED;'/ + 4' ENTER 3 IF S.D. = SQRT(SD1**2 + LAMBDA**2), WITH LAMBDA TO BE ES + 5TIMATED;'/ + 6' ENTER 4 IF S.D. = GAMMA, WITH GAMMA TO BE ESTIMATED: ') + READ(*,*,ERR=1110) IERRMOD + IF(IERRMOD .LT. 1 .OR. IERRMOD .GT. 4) GO TO 1110 + + + IF(IERRMOD .GE. 2) THEN + + ESTNAM = ' GAMMA' + IF(IERRMOD .EQ. 3) ESTNAM = 'LAMBDA' + 225 WRITE(*,223) ESTNAM + 223 FORMAT(/' ENTER THE FINAL ESTIMATE FOR ',A6,' IN THE NPAG RUN: + 1 ') + READ(*,*,ERR=225) GAMLAM + + IF(GAMLAM .LE. 0.D0) THEN + WRITE(*,1223) + 1223 FORMAT(/' THIS VALUE MUST BE POSITIVE. '/) + GO TO 225 + ENDIF + + ENDIF + + + CALL SYSTEM('CLS') + + WRITE(*,119) + 119 FORMAT(//' FOR EACH OUTPUT EQUATION(S), SELECT ONE OF THE FOLLOWIN + 1G'/ + 5' OPTIONS FOR THE ASSAY COEFFICIENTS [C0,C1,C2,C3]: '// + 4' ENTER 1 FOR THE DEFAULT OPTION ...'/ + 5' IF THE PATIENT DATA FILE ALREADY INCLUDES '/ + 6' ASSAY COEFFICIENTS, THOSE COEFFICIENTS WILL BE USED. '/ + 7' OTHERWISE THE COEFFICIENTS YOU ENTER BELOW WILL BE '/ + 8' USED;'/ + 7' ENTER 0 IF YOU WOULD LIKE THE ASSAY COEFFICIENTS TO BE THOSE'/ + 1' YOU ENTER BELOW (WHETHER OR NOT YOUR PATIENT FILE HAS'/ + 2' ASSAY COEFFICIENTS ALREADY: ') + + CALL PAUSE + +C FOR EACH OUTPUT, INPUT IASS AND [C0P,...,C3P]. + + DO 2200 IEQ = 1,NUMEQT + + 1120 WRITE(*,221) IEQ + 221 FORMAT(/' FOR OUTPUT EQUATION ',I1,':'// + 4' ENTER 1 FOR THE DEFAULT OPTION;'// + 7' ENTER 0 TO BE PROMPTED FOR ASSAY COEFFICIENTS: ') + READ(*,*,ERR=1120) IAS + IF(IAS .NE. 0 .AND. IAS .NE. 1) GO TO 1120 + IASS(IEQ) = IAS + + WRITE(*,1119) IEQ + 1119 FORMAT(/' ENTER THE GENERAL VALUES FOR [C0,C1,C2,C3] FOR '/ + 1' OUTPUT EQUATION ',I1,'. THESE ') + IF(IAS .EQ. 1) WRITE(*,1121) + IF(IAS .EQ. 0) WRITE(*,1123) + 1121 FORMAT(' WILL BE USED IF YOUR PATIENT DATA FILE DOES NOT'/ + 1' ALREADY INCLUDE ASSAY COEFFICIENTS: ') + 1123 FORMAT(' WILL BE USED EVEN IF YOUR PATIENT DATA FILE ALREADY'/ + 1' INCLUDES ASSAY COEFFICIENTS: ') + 4140 READ(*,*,ERR=4145) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + GO TO 2200 + 4145 WRITE(*,4146) + 4146 FORMAT(/' SEE ABOVE; PLEASE ENTER FOUR REAL NUMBERS: ') + GO TO 4140 + + + 2200 CONTINUE + + + WRITE(*,2119) + 2119 FORMAT(//' NOTE: DURING THIS PROGRAM, THE PATIENT DATA FILE'/ + + 1' WILL HAVE ITS COEFFICIENTS WRITTEN TO THE END OF THE '/ + 2' WORKING COPY FILE. IF COEFFICIENTS ARE ALREADY THERE'/ + 3' FROM A PREVIOUS RUN, THEY WILL BE OVERWRITTEN.'//) + CALL PAUSE + + +4150 WRITE(*,129) + 129 FORMAT(//' ENTER THE ACTIVE (SALT) FRACTION OF EACH DRUG. AS '/ + + 1' AN EXAMPLE, THE A.F. OF THEOPHYLLINE IS 1.0, WHILE THAT OF'/ + 2' AMINOPHYLLINE IS TYPICALLY BETWEEN .79 AND .85, DEPENDING ON'/ + 3' THE PREPARATION. '// + 4' EACH AF MUST BE A POSITIVE NUMBER LESS THAN OR EQUAL TO 1.0.'/) + + DO I = 1,NDRUG + WRITE(*,1129) I + 1129 FORMAT(' AF FOR DRUG ',I1,': ') + READ(*,*,ERR=4150) AF(I) + IF(AF(I) .LE. 0.0 .OR. AF(I) .GT. 1.0) GO TO 4150 + END DO + + + 3130 WRITE(*,3129) + 3129 FORMAT(/' THE COMMENTS ABOVE HAVE ALL BEEN BASED ON THE '/ + 1' ASSUMPTION THAT YOU WANT TO FIND THE OPTIMUM DOSES TO HIT THE'/ + 2' TARGET CONCENTRATIONS IN THE "FUTURE" FILE.'// + 3' ENTER 1 IF THIS IS TRUE; '/ + 4' ENTER 0 IF, INSTEAD, YOU WANT THE OUTPUT FILE TO SHOW '/ + 5' PREDICTED CONCENTRATIONS AND AUCs FOR THE DOSES IN '/ + 6' THE "FUTURE" FILE (I.E., NO OPTIMIZATION WILL BE DONE'/ + 7' IN THIS CASE): ') + READ(*,*,ERR=3130) IOPTIMIZE + IF(IOPTIMIZE .NE. 1 .AND. IOPTIMIZE .NE. 0) GO TO 3130 + +C IF IOPTIMIZE = 0, NO OPTIMIZATION IS TO BE DONE, WHICH RENDERS THE +C QUESTION ABOUT BIASWEIGHT BELOW MOOT. IN THIS CASE, SIMPLY SET +C BIASWEIGHT = 0. BUT IF IOPTIMIZE = 1, THEN QUESTION THE USER ABOUT +C HOW THE COST FUNCTION (WHICH ESTABLISHES THE BEST DOSES) SHOULD BE +C CALCULATED. SIMILARLY FOR ITARGET. IT IS IRRELEVANT IF NO +C OPTIMIZATION IS TO BE DONE. SO SET IT = 1 IF IOPTIMIZE = 0. + + ITARGET = 1 + + BIASWEIGHT = 0.D0 + + + IF(IOPTIMIZE .EQ. 1) THEN + + 3140 WRITE(*,3139) + 3139 FORMAT(/' THE COST FUNCTION TO BE MINIMIZED IN FINDING THE'/ + 1' "BEST" DOSES IS (1 - BIASWEIGHT)*V(U) + BIASWEIGHT*B(U), WHERE'/ + 2' V(U) IS THE MEAN SQUARED ERROR ASSOCIATED WITH ALL THE '/ + 3' GRID PTS. IN THE PARAMETER DENSITY; AND B(U) IS THE MEAN '/ + 4' SQUARED ERROR DUE TO BIAS ABOUT THE MEAN RESPONSE.'// + 5' ENTER THE VALUE FOR BIASWEIGHT BETWEEN 0 AND 1, INCLUSIVE: ') + READ(*,*,ERR=3140) BIASWEIGHT + IF(BIASWEIGHT .LT. 0.D0 .OR. BIASWEIGHT .GT. 1.D0) GO TO 3140 + +3150 WRITE(*,3149) + 3149 FORMAT(/' ENTER 1 IF THE OBSERVED VALUES IN THE FUTURE PATIENT'/ + 1' FILE ARE TARGET CONCENTRATIONS; '/ + 2' ENTER 2 IF THE OBSERVED VALUES ARE TARGET AUCs: ') + READ(*,*,ERR=3150) ITARGET + IF(ITARGET .NE. 1 .AND. ITARGET .NE. 2) GO TO 3150 + + + ENDIF +C THE ABOVE ENDIF IS FOR THE IF(IOPTIMIZE .EQ. 1) CONDITION. + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 0) CONDITION. + + +C AS OF BESTDOS105.FOR, THE IF(IAF .EQ. 0) CODE IS REMOVED SINCE +C IAF IS ALWAYS 1 ... IN FACT, ALL CODE FOR IAF IS REMOVED SINCE IT IS +C NO LONGER NEEDED. + + +C PRINT TO THE SCREEN ALL INPUT INFO FOR VERIFICATION. + + CALL VERIF1(FORFILE,ICSVFILE,FUTUREFILEIN,PATH,NOB,C0P,C1P,C2P, + 1 C3P,NUMEQT,NOFIX,VALFIX,PARFIX,TOLER,ATOL,IASS,AF,MATFIL, + 2 NPAGDENFILE,INCLUDPAST,IPASTFILE,PASTFILEIN,IERRMOD, + 3 GAMLAM,NDRUG,IPRIOROBS,TNEXT,IDELTA,MAXOBDIM,MAXCYC,IOPTIMIZE, + 4 BIASWEIGHT,ITARGET) + + +C GIVE USER OPTION TO SAVE INPUT DATA TO AN INPUT FILE (FOR ANOTHER +C RUNNING OF THE PROGRAM). + + 4610 WRITE(*,4601) + 4601 FORMAT(//' ENTER 1 TO SAVE THE INFORMATION FOR THIS RUN INTO'/ + 1' A FILE;'/ + 1' ENTER 0 OTHERWISE: ') + READ(*,*,ERR=4610) ISAVFL + + IF (ISAVFL .NE. 0 .AND. ISAVFL .NE. 1) GO TO 4610 + + + IF(ISAVFL .EQ. 1) THEN + + 1960 WRITE(*,4616) + 4616 FORMAT(/' ENTER THE DESIRED FILENAME: ') + READ(*,2) SAVFIL + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE + +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = SAVFIL + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(24,FILE=PATHFILE,ERR=1970,STATUS='NEW') + GO TO 1975 + + 1970 WRITE(*,9826) PATHFILE + 9826 FORMAT(/' THE FOLLOWING FILE ALREADY EXISTS ....'/ + 1' ',A73/ + 1' ENTER 0 TO ENTER A NEW FILENAME;'/ + 2' ENTER 1 TO OVERWRITE THIS FILE: ') + READ(*,*,ERR=1970) IFILE + IF(IFILE .NE. 0 .AND. IFILE .NE. 1) GO TO 1970 + IF(IFILE .EQ. 0) GO TO 1960 + IF(IFILE .EQ. 1) OPEN(24,FILE=PATHFILE) + + 1975 WRITE(24,7123) 'BESTDOS OCT_13' + + WRITE(24,8111) + 8111 FORMAT(' MODEL FILENAME') + WRITE(24,2) FORFILE + + + WRITE(24,8112) + 8112 FORMAT(' IRAN INDICES') + WRITE(24,*) (IRAN(I),I=1,NP) + + WRITE(24,9006) + 9006 FORMAT(' NPAG DENSITY FILE') + WRITE(24,2) NPAGDENFILE + + + WRITE(24,9017) + 9017 FORMAT(' MAXCYC') + WRITE(24,*) MAXCYC + + WRITE(24,9004) + 9004 FORMAT(' INCLUDPAST') + WRITE(24,*) INCLUDPAST + + WRITE(24,9008) + 9008 FORMAT(' IPASTFILE') + WRITE(24,*) IPASTFILE + + WRITE(24,9011) + 9011 FORMAT(' PASTFILEIN') + WRITE(24,2) PASTFILEIN + + WRITE(24,8116) + 8116 FORMAT(' ICSVFILE') + WRITE(24,*) ICSVFILE + + WRITE(24,8117) + 8117 FORMAT(' FUTUREFILEIN') + WRITE(24,2) FUTUREFILEIN + + WRITE(24,8118) + 8118 FORMAT(' TNEXT') + WRITE(24,*) TNEXT + + + WRITE(24,8171) + 8171 FORMAT(' IDELTA') + WRITE(24,*) IDELTA + + WRITE(24,8119) + 8119 FORMAT(' NOFIX') + WRITE(24,*) NOFIX + + WRITE(24,8121) + 8121 FORMAT(' VALFIX ARRAY IF NOFIX > 0') + + + IF(NOFIX .GT. 0) WRITE(24,2416) (VALFIX(I),I=1,NOFIX) + 2416 FORMAT(30(G14.7,1X)) + + WRITE(24,8122) + 8122 FORMAT(' TOLER') + WRITE(24,*) TOLER + + WRITE(24,8123) + 8123 FORMAT(' NUMEQT') + WRITE(24,*) NUMEQT + + WRITE(24,8124) + 8124 FORMAT(' NUMEQT LINES OF ASSAY COEFFICIENTS') + DO IEQ=1,NUMEQT + WRITE(24,2416) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + END DO + + WRITE(24,8133) + 8133 FORMAT(' IERRMOD') + WRITE(24,*) IERRMOD + + WRITE(24,8134) + + 8134 FORMAT(' GAMLAM') + IF(IERRMOD .EQ. 1) WRITE(24,*)' -99' + IF(IERRMOD .GE. 2) WRITE(24,*) GAMLAM + + + WRITE(24,8127) + 8127 FORMAT(' IASS(I),I=1,NUMEQT') + WRITE(24,*) (IASS(I),I=1,NUMEQT) + + WRITE(24,9131) + + 9131 FORMAT(' NDRUG') + WRITE(24,*) NDRUG + + WRITE(24,8131) + 8131 FORMAT(' AF(I),I=1,NDRUG') + WRITE(24,*) (AF(I),I=1,NDRUG) + + WRITE(24,8132) + + 8132 FORMAT(' IOPTIMIZE') + WRITE(24,*) IOPTIMIZE + + WRITE(24,8136) + 8136 FORMAT(' BIASWEIGHT') + WRITE(24,*) BIASWEIGHT + + WRITE(24,8138) + 8138 FORMAT(' ITARGET') + WRITE(24,*) ITARGET + + + CLOSE(24) + + + ENDIF + +C ABOVE ENDIF IS FOR THE IF(ISAVFL .EQ. 1) CONDITION. + + +C IF THE FILE 'GUICMDS.INX' EXISTS IN THE WORKING DIRECTORY, CONTROL +C IS TRANSFERRED TO LABEL 1450 IMMEDIATELY AFTER THAT FILE HAS +C BEEN READ ABOVE. + + 1450 CONTINUE + + +C SET NOFIXXX TO NOFIX, AND NDIMMM TO NDIM. THEY ARE SUPPLIED IN +C DIFFERENT COMMON STATEMENTS, AND THEREFORE MUST HAVE DIFFERENT NAMES. + + + NOFIXXX = NOFIX + NDIMMM = NDIM + + +C OPEN AND READ NPAGDENFILE. IF INCLUDPAST = 1 (WHICH MEANS THE USER +C HAS PROVIDED A "PAST" HISTORY FILE (PASTFILEIN) FOR THE SUBJECT OF +C THIS RUN, AND IF IPRIOROBS = 1 (WHICH MEANS THAT THIS FILE HAS +C NON-MISSING OBSERVED VALUES), THEN THE FOLLOWING CODE WILL BE USED +C TO CALL ROUTINE NPAGFULL TO GET THE POSTERIOR DENSITY FOR THE +C SUBJECT, WHICH WILL BE STORED INTO THE ARRAY, DENSITY. OTHERWISE, THE +C ARRAY, DENSITY, IS GOTTEN DIRECTLY FROM NPAGDENFILE. + + TMPFILE = ' ' + TMPFILE = NPAGDENFILE + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(34,FILE=PATHFILE) + READ(34,7123) CODE + + IVER = 0 + IF(CODE .EQ. 'DENSITY APR_10') IVER = 1 + IF(CODE .EQ. 'DENSITY OCT_15') IVER = 2 + + IF(IVER .EQ. 0) THEN + + WRITE(*,7126) NPAGDENFILE + 7126 FORMAT(/' YOUR DENSITY FILE, ',A20,' IS NOT AN UP-TO-DATE'/ + 1' DENSITY FILE.'// + 2' PLEASE RERUN THE PROGRAM AFTER ENSURING THAT YOUR DENSITY '/ + 3' FILE HAS "DENSITY APR_10" OR "DENSITY OCT_15" ON THE FIRST'/ + 4' LINE.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,7126) NPAGDENFILE + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + +C AS THE INFO OF THE DENSITY FILE IS BEING READ, VERIFY THAT IT +C MATCHES THE INFO READ IN ABOVE. IF NOT, STOP THE PROGRAM, AND TELL +C THE USER THE REASON. + + READ(34,*) NDIMM + IF(NDIM .NE. NDIMM) THEN + + WRITE(*,7127) NPAGDENFILE,NDIMM,NDIM,FORFILE + 7127 FORMAT(/' NDIM READ IN FROM YOUR DENSITY FILE, ',A20/ + 1' IS ',I3,' WHICH DOES NOT MATCH THE VALUE OF ',I3,' READ IN '/ + 2' FROM YOUR MODEL FILE, ',A20 // + + 3' PLEASE RERUN THE PROGRAM AFTER ENSURING COMPATIBILITY BETWEEN'/ + 4' THESE TWO FILES. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,7127) NPAGDENFILE,NDIMM,NDIM,FORFILE + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + READ(34,*) INDPTS + IF(INDPTS .EQ. 1) NGRID=2129 + IF(INDPTS .EQ. 2) NGRID=5003 + IF(INDPTS .EQ. 3) NGRID=10007 + IF(INDPTS .EQ. 4) NGRID=20011 + IF(INDPTS .EQ. 5) NGRID=40009 + IF(INDPTS .EQ. 6) NGRID=80021 + IF(INDPTS .GT. 6) NGRID = 80021*(INDPTS - 100) + + READ(34,*) NACTVE + + IF(NACTVE .GT. MAXGRD) THEN + + WRITE(*,7128) NPAGDENFILE,NACTVE,MAXGRD,MAXGRD + 7128 FORMAT(//' THE NO. OF ACTIVE GRID POINTS IN YOUR DENSITY'/ + 1' FILE, ',A20,' IS ',I7,' WHICH IS MORE THAN THE MAXIMUM ALLOWED'/ + 2' FOR THIS PROGRAM (',I7,'). PLEASE RERUN THE PROGRAM WITH A'/ + 3' DENSITY FILE HAVING NO MORE THAN ',I7,' ACTIVE GRID POINTS. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,7128) NPAGDENFILE,NACTVE,MAXGRD,MAXGRD + CLOSE(47) + + CALL PAUSE + STOP + + + ENDIF + + READ(34,*) NVARR + + IF(NVAR .NE. NVARR) THEN + + WRITE(*,7129) NPAGDENFILE,NVARR,NVAR,FORFILE + 7129 FORMAT(/' NVAR READ IN FROM YOUR DENSITY FILE, ',A20/ + 1' IS ',I3,' WHICH DOES NOT MATCH THE VALUE OF ',I3,' READ IN '/ + 2' FROM YOUR MODEL FILE, ',A20 // + 3' PLEASE RERUN THE PROGRAM AFTER ENSURING COMPATIBILITY BETWEEN'/ + 4' THESE TWO FILES. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,7129) NPAGDENFILE,NVARR,NVAR,FORFILE + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + +C AS OF BESTDOS121.FOR, THE DENSITY FILE CAN BE EITHER HAVE CODE +C "DENSITY APR_10" OR "DENSITY OCT_15". IN THE FORMER CASE, THERE ARE +C NO RANFIX PARAMETERS. IN THE LATTER CASE, THERE MAY BE RANFIX +C PARAMETERS (I.E., THOSE WHICH WERE FIXED BUT UNKNOWN, AND THEREFORE +C ESTIMATED IN THE NPAG RUN WHICH PRODUCED THIS DENSITY FILE). IN +C THIS LATTER CASE, THESE RANFIX PARAMETERS WERE ESTIMATED AND NOW +C WILL BE TREATED AS IF THEY WERE FIXED AND KNOWN, I.E., THEY WILL +C BE TREATED AS FIXED PARAMETERS. SO THEY WILL BE COMBINED WITH THE +C OTHER FIXED PARAMETERS. + +C READ IN PAR, NOFIX, AND PARFIX. NOTE THAT NOFIX SHOULD MATCH NOFIX +C READ IN ABOVE FROM THE MODEL FILE, BUT THAT IT IS POSSIBLE THE USER +C HAS USED SLIGHTLY DIFFERENT NAMES FOR PAR AND PARFIX IN THE MODEL +C FILE AND IN THE DENSITY FILE, SO THESE WILL NOT BE CHECKED FOR +C CONSISTENCY. + + READ(34,1717) (PAR(I),I=1,NVAR) + 1717 FORMAT(A11) + + READ(34,*) NOFIXX1 + READ(34,1717) (PARFIX(I),I=1,NOFIXX1) + + IF(IVER .EQ. 2) THEN + READ(34,*) NRANFIX + READ(34,1717) (PARRANFIX(I),I=1,NRANFIX) + ENDIF + +C AS INDICATED ABOVE, SET THE NEW NO. OF FIXED PARAMETERS TO BE THE +C NO. THAT WERE ORIGINALLY FIXED AND KNOWN (NOFIXX1) + THE NO. THAT +C WERE ORIGINALLY FIXED AND UNKNOWN (NRANFIX) SINCE RANFIX +C PARAMETERS ARE TREATED THE SAME AS FIXED PARAMETERS IN THIS PROGRAM. + + NOFIXX = NOFIXX1 + NRANFIX + + IF(NOFIXX .NE. NOFIX) THEN + + WRITE(*,7131) NPAGDENFILE,NOFIXX,NOFIX + 7131 FORMAT(/' THE NO. OF FIXED PARAMETERS (WHICH INCLUDES THOSE'/ + 1' WHICH WERE ORIGINALLY FIXED AND KNOWN AS WELL AS THOSE WHICH'/ + 2' WERE ORIGINALLY FIXED AND UNKNOWN IN THE NPAG RUN) WHICH WERE'/ + 3' READ IN FROM YOUR DENSITY FILE, ',A20/ + 4' IS ',I3,' WHICH DOES NOT MATCH THE VALUE OF ',I3,' READ IN '/ + 2' ABOVE FROM AN INSTRUCTION FILE OR THE KEYBOARD.' // + 3' PLEASE RERUN THE PROGRAM AFTER ENSURING COMPATIBILITY BETWEEN'/ + 4' THESE TWO FILES. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,7131) NPAGDENFILE,NOFIXX,NOFIX,FORFILE + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + DO I=1,NVAR + READ(34,*) (AB(I,J),J=1,2) + END DO + + READ(34,*) (VALFIXX(I),I=1,NOFIXX1) + IF(IVER .EQ. 2) READ(34,*) (VALFIXX(I+NOFIXX1),I=1,NRANFIX) + +C VERIFY THAT ALL THE VALFIXX VALUES ARE THE SAME AS THOSE READ IN +C ABOVE FOR VALFIX. NOTE THAT ISAME RETURNED FROM CALL TO THESAME +C IS 1 IF THE TWO PRECEEDING ARGUMENTS ARE WITHIN 1.D-10 OF EACH +C OTHER (I.E., VIRTUALLY THE SAME VALUE); OTHERWISE IT RETURNS AS 0. + + DO I = 1,NOFIX + + CALL THESAME(VALFIXX(I),VALFIX(I),ISAME) + + IF(ISAME .EQ. 0 .AND. I .LE. NOFIXX1) THEN + + WRITE(*,7132) I,NPAGDENFILE,VALFIXX(I),VALFIX(I),VALFIXX(I) + 7132 FORMAT(/' FIXED VALUE NO. ',I2,' FROM YOUR DENSITY '/ + 1' FILE, ',A20,' IS ',G14.7,' WHICH DOES NOT MATCH THE VALUE '/ + 2' OF ',G14.7,' READ IN ABOVE.'// + 3' THE VALUE USED IN THIS RUN WILL BE ',G14.7/) + + CALL PAUSE + + ENDIF + + CALL THESAME(VALFIXX(I),VALFIX(I),ISAME) + + IF(ISAME .EQ. 0 .AND. I .GT. NOFIXX1) THEN + + WRITE(*,7133) I,I-NOFIXX1,NPAGDENFILE,VALFIXX(I),VALFIX(I), + 1 VALFIXX(I) + 7133 FORMAT(/' FIXED VALUE NO. ',I2,' WHICH WAS RANFIX VALUE'/ + 1' NO. ',I2,' IN THE NPAG RUN WHICH PRODUCED YOUR DENSITY '/ + 2' FILE, ',A20,' IS ',G14.7,' WHICH DOES NOT MATCH THE VALUE '/ + 2' OF ',G14.7,' READ IN ABOVE.'// + 3' THE VALUE USED IN THIS RUN WILL BE ',G14.7/) + + + CALL PAUSE + + ENDIF + + + END DO +C??? THE ABOVE END DO IS FOR THE DO I = 1,NOFIX LOOP. + + + + READ(34,*) + READ(34,*) + READ(34,*) + + DO I=1,NACTVE + READ(34,*) (CORDEN(I,J),J=1,NVAR+1) + END DO + + CLOSE(34) + + + IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN + + +C SINCE INCLUDPAST = 1 (WHICH MEANS THE USER HAS PROVIDED A "PAST" +C HISTORY FILE (PASTFILEIN) FOR THE SUBJECT OF THIS RUN, AND +C IPRIOROBS = 1 (WHICH MEANS THAT THIS FILE HAS NON-MISSING OBSERVED +C VALUES), THE FOLLOWING CODE WILL BE USED TO CALL ROUTINE NPAGFULL TO +C GET THE POSTERIOR DENSITY FOR THE SUBJECT, WHICH WILL BE +C STORED INTO THE ARRAY, DENSITY. + +C BEFORE CALLING NPAGFULL, PUT ("STACK") THE "PAST" SUBJECT FILE INTO +C FILE 27, SO IT WILL BE READY TO GO IN SUBROUTINE NPAGFULL. + + +C FIRST, ESTABLISH THIS "PAST" SUBJECT IN WORKING COPY FORMAT. +C TMPFILE WILL BE PASTFILEIN IF IPASTFILE = 0, AND IT WILL BE +C 'XQZPJ001.PST' IF IPASTFILE = 1. + + TMPFILE = ' ' + IF(IPASTFILE .EQ. 0) TMPFILE = PASTFILEIN + IF(IPASTFILE .EQ. 1) TMPFILE = 'XQZPJ001.PST' + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + +C CALL SUBROUTINE PUTASS TO MAKE SURE THAT THE WORKING COPY PATIENT +C FILE HAS THE DESIRED ASSAY COEFFICIENTS WRITTEN AT THE END OF IT. + + CALL PUTASS(PATHFILE,IASS,C0P,C1P,C2P,C3P,NUMEQT) + +C OPEN THE PATIENT DATA FILE AND PUT IT INTO FILE (27). + + OPEN(27) + +C CALL SUBROUTINE STACK TO OPEN THE SUBJECT'S DATA FILE AND PUT THE +C INFO INTO FILE 27. NOTE THAT THERE WILL BE ONLY ONE FILE READ IN +C AND "STACKED" INTO FILE 27, BUT THE STRUCTURE OF DOING SO IS +C MAINTAINED SO THAT OTHER CODE DOES NOT HAVE TO BE CHANGED. + +C AS OF BESTDOS108, USE PATFIL INSTEAD OF TMPFILE AS THE 3RD ARGUMENT +C TO STACK (SEE REASON IN THE COMMENTS AT THE TOP OF BESTDOS108.FOR). + + PATFIL = TMPFILE + CALL STACK(PATH,MAXOBDIM,PATFIL,AF) + +C NOW FILE 27 HAS THE PATIENT DATA INFO IN IT + +C REWIND FILE 27, WHICH HAS THE PATIENT DATA FILE ON IT. + + REWIND(27) + + WRITE(*,437) + 437 FORMAT(/' NPAG IS NOW OBTAINING THE POSTERIOR DENSITY ...') + + +C AS OF BESTDOSTEMP.FOR (TO BE RENAMED BESTDOS112.FOR), TO OBTAIN THE +C POSTERIOR DENSITY, DO AN EXTENDED PROCESS TO MAKE IT MORE LIKELY +C THAT THERE WILL BE MORE THAN 1 PT. IN IT. INSTEAD OF JUST CALLING +C NPAGFULL, WHICH ALWAYS RETURNS THE SINGLE BEST POINT WHICH IS +C COMPATIBLE WITH THE "PAST", THIS PROGRAM DOES A 2-STEP PROCESS: + +C 1. IT CALLS NPAGFULL11, WHICH RETURNS ALL GRID PTS. FROM THE +C ORIGINAL PRIOR DENSITY WHICH ARE ARE REASONABLY COMPATIBLE WITH THE +C "PAST" (I.E., THOSE WHOSE PROBABILITIES ARE WITHIN 1.D-100 OF THE +C BEST GRID PT.). THIS IS THE BAYESIAN POSTERIOR OF THE PRIOR DENSITY, +C BASED ON THE "PAST" OF THE SUBJECT. + +C 2. FOR EACH OF THE GRID PTS. IN 1., IT CALLS NPAGFULL TO OBTAIN +C THE SINGLE DAUGHTER PT. WHICH IS BEST. + +C THE RESULT THEN WILL BE A POSTERIOR CONSISTING OF THE BEST DAUGHTER +C POINT FOR EVERY GRID PT. WHICH SHOWED UP IN STEP 1. + + CALL NPAGFULL11(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK, + 1 CORDEN,NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM, + 2 NGRID,NACTVE,PYJGX,DENSTOR,CORDLAST) + +C THE BAYESIAN POSTERIOR = CORDEN(I,J),J=1,NVAR+1; I = 1,NACTVE. +C FOR EACH OF THESE NACTVE GRID PTS., CALL NPAGFULL TO GET THE BEST +C DAUGHTER POINT (VIS-A-VIS THIS SUBJECT'S "PAST"). + + + DO IACTIVE = 1,NACTVE + +C REWIND FILE 27, WHICH HAS THE PATIENT DATA FILE ON IT. + + REWIND(27) + +C STORE INTO CORD1 GRID PT. NO. IACTIVE. NOTE BELOW IN THE CALL TO +C NPAGFULL, THE 20TH ARGUMENT IS 1, INDICATING THAT THERE IS JUST THIS +C ONE GRID PT. IN THIS PRIOR. +C NO! THE 20TH ARGUMENT CANNOT BE A CONSTANT SINCE THE DUMMY ARGUMENT +C IN NPAGFULL IS NACTVE, WHICH IS RESET A COUPLE OF TIMES IN THE +C NPAGFULL CODE. THIS IS FINE IF THE PROGRAM IS RUN UNDER LAHEY +C FORTRAN, BUT CAUSES THE PROGRAM TO BOMB IF THE PROGRAM IS RUN UNDER +C gfortran. SO, INSTEAD SET NACTVE1 = 1, AND SUPPLY NACTVE1 AS THE +C 2OTH ARGUMENT. + + NACTVE1 = 1 + + DO J = 1,NVAR+1 + CORD1(1,J) = CORDEN(IACTIVE,J) + END DO + + + CALL NPAGFULL(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK,CORD1, + 1 NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM,NGRID, + 2 NACTVE1,PYJGX,DENSTOR,CORDLAST,MAXCYC) + + +C ON INPUT TO NPAGFULL, CORD1 (IN ROW 1) CONTAINED THE SINGLE GRID +C POINT IN THE PRIOR DENSITY. NOW, ON RETURN FROM NPAGFULL, ITS +C FIRST ROW CONTAINS THE POSTERIOR DENSITY OF THE SUBJECT, GIVEN THIS +C PRIOR. UPDATE ROW NO. IACTIVE OF CORDEN WITH THESE VALUES. + +C FOR BESTDOS112A.FOR, DO NOT SET CORDEN(IACTIVE,NVAR+1) = +C CORD1(1,NVAR+1). I.E., JUST RUN THE LOOP BELOW FROM 1 TO NVAR, +C NOT TO NVAR+1. THE REASON IS THAT THE DENSITY VALUES FROM NPAGFULL11 +C SHOULD BE THE ONES USED BELOW IN THE CALL TO ELDERY. OTHERWISE, +C THEY ALL GET SET = THE SAME VALUE, AS IF ALL OF THE ORIGINA GRID +C PTS. FROM NPAGFULL ARE EQUALLY LIKELY. + + DO J = 1,NVAR + CORDEN(IACTIVE,J) = CORD1(1,J) + END DO + + END DO +C THE ABOVE END DO IS FOR THE DO IACTIVE = 1,NACTVE LOOP. + + +C NOW CORDEN HAS NACTVE GRID PTS. WHICH CONSTITUTES THE POSTERIOR +C FOR THIS RUN, IN THIS NEW 2-STEP ALGORITHM. IT WILL BE USED TO +C ESTABLISH THE ARRAY DENSITY BELOW, WHICH WILL SUPPLIED IN +C COMMON/TOCALC TO SUBROUTINE CALCS, WHICH IS CALLED BY ELDERY. + + + CLOSE(27) + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. + + + +C NOTE THAT THE DENSITY VALUES MUST BE SET = CORDEN(.,.). + + +C IF(INCLUDPAST .EQ. 0 .OR. IPRIOROBS .EQ. 0) THIS CORDEN COMES +C DIRECTLY FROM NPAGDENFILE SINCE THE USER HAS NOT PROVIDED A "PAST" + +C HISTORY FILE (PASTFILEIN), OR IF HE HAS, THIS FILE HAS NO NON-MISSING +C OBSERVATIONS. IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1), THIS +C CORDEN COMES FROM THE CALL TO NPAGFULL ABOVE. + +C EITHER WAY, NOTE THAT CORDEN(I,NVAR+1) IS THE DENSITY FOR GRID POINT +C I, AND THESE MUST BE NORMALIZED SO THAT THEY ALL SUM TO 0.0. + + + SUMD = 0.D0 + DO I = 1,NACTVE + SUMD = SUMD + CORDEN(I,NVAR+1) + DO J = 1,NVAR + DENSITY(I,J) = CORDEN(I,J) + END DO + END DO + + DO I = 1,NACTVE + DENSITY(I,NVAR+1) = CORDEN(I,NVAR+1)/SUMD + + + END DO + + +C MUST SET NGRD = NACTVE SINCE IT MUST BE SUPPLIED IN COMMON/TOCALC. + + NGRD = NACTVE + + +C THE ARRAY, DENSITY, HAS BEEN ESTABLISHED ABOVE. NOW ESTABLISH THIS +C SUBJECT'S COMPLETE PROFILE FOR THE OPTIMIZATION, AND PUT IT INTO THE +C WORKING COPY FILE, TMPFILE. IT WILL CONSIST OF THE DOSES (BUT NOT THE + +C OBSERVATIONS) IN THE "PAST" ALONG WITH THE DOSES AND OBSERVATIONS IN +C THE "FUTURE" (WITH ALL TIMES IN THE "FUTURE" INCREASED BY TNEXT). + +C IF INCLUDPAST = 0, TNEXT WILL = 0, AND THE COMPLETE PROFILE WILL +C CONSIST ONLY OF JUST THE "FUTURE" FILE. + + IF(INCLUDPAST .EQ. 0) THEN + + TNEXT = 0 + + TMPFILE = ' ' + IF(ICSVFILE .EQ. 0) TMPFILE = FUTUREFILEIN + IF(ICSVFILE .EQ. 1) TMPFILE = 'XQZPJ001.FUT' + +C SET ND41 = 0. IT WILL BE USED BELOW (AND PUT INTO COMMON/TOCALC). IT +C IS THE NO. OF DOSES IN THE "PAST" HISTORY OF THE SUBJECT, AND SO IN +C THIS CASE WHERE THERE IS NO "PAST" HISTORY, IT WILL BE 0. ALSO, +C SET THIS VALUE TO NDD41 SINCE IT WILL BE PASSED IN COMMON/TOCALC, +C AND MUST THEREFORE HAVE A DIFFERENT NAME. + + ND41 = 0 + + NDD41 = ND41 + +C ALSO, AS OF BESTDOS110, SET M41 = 0. THIS IS PASSED IN +C COMMON/TOCALCTP TO SUBROUTINE CALCTPRED SO THAT IT WILL KNOW THAT +C THERE ARE NO OBSERVATION TIMES FROM THE "PAST". + + M41 = 0 + + ENDIF + + + IF(INCLUDPAST .EQ. 1) THEN + + TMPFILE1 = ' ' + IF(ICSVFILE .EQ. 0) TMPFILE1 = PASTFILEIN + IF(ICSVFILE .EQ. 1) TMPFILE1 = 'XQZPJ001.PST' + + TMPFILE2 = ' ' + IF(ICSVFILE .EQ. 0) TMPFILE2 = FUTUREFILEIN + IF(ICSVFILE .EQ. 1) TMPFILE2 = 'XQZPJ001.FUT' + +C SINCE THE FUTURE FILE AND THE PAST FILE HAVE TO OPEN AT THE SAME +C TIME (IN ORDER TO COMBINE THEM INTO TMPFILE BELOW), THEY CANNOT +C BE THE SAME FILE. IF THEY ARE, THE PROGRAM WILL STOP WITH A MESSAGE +C TO THE USER THAT THESE FILES HAVE TO BE DIFFERENT. + + IF(ICSVFILE .EQ. 0 .AND. TMPFILE1 .EQ. TMPFILE2) THEN + + WRITE(*,317) TMPFILE1 + 317 FORMAT(/' YOU HAVE CHOSEN THE "PAST" AND THE "FUTURE" FILES'/ + 1' TO BE THE SAME FILE ... ',A20// + 2' THIS IS NOT ALLOWED. IF YOU REALLY WANT THE INFORMATION TO BE'/ + 3' THE SAME IN THE "PAST" AS IN THE "FUTURE", YOU WILL HAVE TO'/ + 4' COPY THE PATIENT FILE TO ANOTHER FILE, AND THEN USE ONE OF'/ + 5' THESE FILES AS THE "PAST" AND ONE AS THE "FUTURE".'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,317) TMPFILE1 + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + TMPFILE = ' ' + TMPFILE = 'BOTHFILES.ZPJ' + +C??? DEBUG: +C THIS FILE WILL BE LEFT IN THE WORKING DIRECTORY FOR NOW, SO THAT +C IT CAN BE EXAMINED TO VERIFY THAT THE COMPLETE PATIENT PROFILE IS +C WHAT WAS INTENDED. AT SOME POINT IN THE FUTURE, IF DESIRED, IT CAN +C BE DELETED AT THE END OF THE RUN. + + OPEN(41,FILE=TMPFILE1) + OPEN(42,FILE=TMPFILE2) + OPEN(43,FILE=TMPFILE) + +C NOW CALL MAKETMP TO COMBINE TMPFILE1 AND TMPFILE2 INTO TMPFILE, +C WHICH WILL CONSIST OF THE DOSES (BUT NOT THE OBSERVATIONS) IN +C TMPFILE1 (THE "PAST") ALONG WITH THE DOSES AND OBSERVATIONS IN +C TMPFILE2(THE "FUTURE"), WITH ALL TIMES IN TMPFILE2 INCREASED BY +C TNEXT. + +C AS OF BESTDOS119.FOR, ND42 IS RETURNED, RATHER THAN ND41 IN +C THE CALL TO MAKETMP. + + + CALL MAKETMP(TNEXT,MAXOBDIM,ND42) + +C NOTE THAT TMPFILE = 'BOTHFILES.ZPJ' HAS A TOTAL OF ND DOSES, BUT +C THE OPTIMIZATION BELOW WILL BE OVER ONLY THE LAST ND42 OF THEM. +C THE FIRST ND41 WILL BE FIXED TO THEIR VALUES IN THE FILE. +C IF THERE ARE NO STEADY STATE DOSE SETS IN THE "PAST", COULD SET +C ND41 = ND - ND42 NOW. BUT SINCE THERE MAY BE STEADY STATE DOSE SETS +C AS OF BESTDOS119.FOR, MUST WAIT TO ESTABLISH ND41 UNTIL AFTER +C SUBROUTINE NEWWORK1 IS CALLED BELOW. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1) CONDITION. + + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + + +C CALL SUBROUTINE PUTASS TO MAKE SURE THAT THE WORKING COPY PATIENT + + +C FILE HAS THE DESIRED ASSAY COEFFICIENTS WRITTEN AT THE END OF IT. + + CALL PUTASS(PATHFILE,IASS,C0P,C1P,C2P,C3P,NUMEQT) + + +C OPEN THE PATIENT DATA FILE AND PUT IT INTO FILE (27). + + OPEN(27) + +C CALL SUBROUTINE STACK TO OPEN THE SUBJECT'S DATA FILE AND PUT THE +C INFO INTO FILE 27. NOTE THAT THERE WILL BE ONLY ONE FILE READ IN +C AND "STACKED" INTO FILE 27, BUT THE STRUCTURE OF DOING SO IS +C MAINTAINED SO THAT OTHER CODE DOES NOT HAVE TO BE CHANGED. + + +C AS OF BESTDOS108, USE PATFIL INSTEAD OF TMPFILE AS THE 3RD ARGUMENT +C TO STACK (SEE REASON IN THE COMMENTS AT THE TOP OF BESTDOS108.FOR). + + PATFIL = TMPFILE + CALL STACK(PATH,MAXOBDIM,PATFIL,AF) + + +C NOW FILE 27 HAS THE PATIENT DATA INFO IN IT +C REWIND FILE 27, WHICH HAS THE PATIENT DATA FILE ON IT. + + REWIND(27) + + +C AS OF BESTDOS119.FOR, FILE 27 DATA MUST BE CONVERTED TO FILE 37 +C DATA AS FOLLOWS: + +C PUT THE SUBJECT'S DATA ONTO FILE 37 BY CALLING SUBROUTINE NEWWORK1 +C (SIMILAR ROUTINE TO THE ONE IN npageng25.f, EXCEPT IT READS FILE 27 +C AND WRITES TO FILE 37, RATHER THAN READING FROM FILE 23 AND WRITING +C TO FILE 27). NOTE THAT IT HAS NO ARGUMENTS; NONE ARE NEEDED IN THIS +C PROGRAM. + +C NOTE THAT IF THE SUBJECT FILE HAS NO STEADY STATE DOSE INDICATORS, IT +C WILL NOT BE CHANGED; IF IT DOES, IT WILL BE ALTERED TO INCLUDE AN +C EXTRA 100 DOSES SETS FOR EACH STEADY STATE DOSE INDICATOR. NOTE THAT +C SUBROUTINE NEWWORK1 WILL LEAVE IN THE NEGATIVE DOSE TIME (WHICH IS +C THE STEADY STATE DOSE INDICATOR) BECAUSE THE ID ROUTINES NEED TO SEE +C THIS INDICATOR TO KNOW THAT A STEADY STATE DOSE SET IS COMING. + + + OPEN(37,FILE='FILE37') +C???DEBUG. MAKE THIS TEMPORARY FILE PERMANENT WHILE DEBUGGING. + + CALL NEWWORK1 + REWIND(37) + + + CALL FILRED(NOBSER,ND,NDRUG,RS,SIG,YO,C0,C1,C2,C3,MAXOBDIM) + +C YO(I),I=1,NOBSER; J=1,NUMEQT, ARE THE TARGET OBSERVED VALUES FOR +C THIS SUBJECT. FIND THE ASSAY STANDARD DEVIATIONS. FOR EACH +C OBSERVED VALUE, SI = (C0+C1*Y+C2*Y**2+C3*Y**3). THEN THE WEIGHT +C ASSOCIATED WITH OBSERVATION I WILL BE 1/SI**2. +C NO! WEIGHT(.,.) ARE NO LONGER USED IN SUBROUTINE WSUMSQ. SO +C COMMENT OUT THIS CODE. + +C DO I=1,NOBSER + +C DO J = 1,NUMEQT +C Y=YO(I,J) +C WEIGHT(I,J) = +C 1 1.D0/(C0(J) + C1(J)*Y + C2(J)*Y*Y + C3(J)*Y**3)**2.D0 +C END DO +C END DO + +C BEFORE CALL TO ELDERY, SET NVARR = NVAR (NVAR IS ALREADY IN A COMMON +C STATEMENT, AND NVARR MUST BE SUPPLIED TO SUBROUTINE CALCS, CALLED +C BY ELDERY).` + + NVARR = NVAR + +C AS OF BESTDOS113, ELDERY WILL BE CALLED TWICE, ONCE WITH THE DENSITY +C AS IT NOW STANDS (I.E., THE WITH THE SAME VALUES AS CALCULATED +C ORIGINALLY FROM NPAGFULL1), AS WAS DONE IN BESTDOS112A.FOR; AND ONCE +C WITH THE DENSITY OF ALL THE GRID PTS. BEING THE SAME, AS WAS DONE IN +C BESTDOS112.FOR. + + +C NOTE THAT IF INCLUDPAST = 0, ND41 AND NDD41 WERE ALREADY SET = 0 +C ABOVE. BUT IF INCLUDPAST = 1, THEY HAVE NOT BEEN ESTABLISHED YET +C FROM ND42 WHICH RETURNS FROM THE CALL TO MAKETMP, AND FROM ND WHICH +C RETURNS FROM THE CALL TO FILRED ABOVE. + + IF(INCLUDPAST .EQ. 1) THEN + + ND41 = ND - ND42 + +C MUST SET ND41 TO BE NDD41 SINCE IT WILL BE PASSED IN COMMON/TOCALC, +C AND MUST THEREFORE HAVE A DIFFERENT NAME. + + NDD41 = ND41 + + ENDIF + + + +C *************** FIRST CALL TO ELDERY BELOW ************************* + +C THE FIRST CALL TO ELDERY WILL BE WITH THE DENSITY VALUES AS +C CALCULATED ORIGINALLY FROM NPAGFULL1 (AS WAS DONE IN +C BESTDOS112A.FOR). THESE VALUES ARE ALREADY IN DENSITY(.,.). + +C CALL SUBROUTINE ELDERY TO FIND THE BEST SET OF NDOS DOSES (AT THE +C TIMES READ IN FROM THE PATIENT DATA FILE BY SUBROUTINE FILRED - +C THESE TIMES ARE PUT INTO COMMON BY FILRED) TO MINIMIZE THE EXPECTED +C WEIGHTED SUM OF SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET +C CONCENTRATIONS (THE OBSERVATION TIMES AND TARGET CONCENTRATIONS ARE +C ALSO READ IN BY FILRED AND PUT INTO COMMONS TO BE USED BY SUBROUTINE +C CALCS WHICH IS CALLED BY SUBROUTINE ELDERY). THE EXPECTED VALUE IS +C OVER THE PRIOR DENSITY (HAVING PARAMETER VALUES AND CORRESPONDING +C DENSITIES) READ IN ABOVE. + +C IN PARTICULAR, ELDERY MINIMIZES EXPSUM = SUM, OVER I=1,NGRD, OF +C DENSITY(I,NVAR+1)*SUMSQ(I), WHERE SUMSQ(I) IS THE WEIGHTED SUM OF +C SQUARES OF DIFFERENCES W(k,l)*(O(I,k,l) -T(k,l))**2, WHERE O(I,k,l) +C IS THE CONCENTRATION AT TIME (k,l) ASSUMING THE ITH GRID POINT; +C T(k,l) IS THE TARGET CONCENTRAIION OF THE lth EQUATION AT TIME k, AND +C W(k,l) IS THE CORRESPONDING WEIGHT CALCULATED ABOVE. + + +C PREPARE TO CALL ELDERY. + +C THE IV DOSE VALUES IN THE PATIENT DATA FILE ARE IN RS(I,2*J-1), +C I=1,ND; J=1,NDRUG; AND THE BOLUS VALUES IN THE PATIENT DATA FILE +C ARE IN RS(I,2*J), ALL RETURNED FROM THE CALL TO FILRED ABOVE. BUT +C NOTE THAT ONLY THE NON-0 IVs AND BOLUSES FROM DOSE EVENTS ND41+1 +C TO ND WILL BE THE DOSES OVER WHICH THE OPTIMIZATION WILL TAKE PLACE +C BELOW. THE REASON IS THAT THE FIRST ND41 DOSE EVENTS WERE IN THE +C "PAST", WHILE THE DOSES STARTING WITH NO. ND41+1 ARE IN THE "FUTURE" +C (SEE SUBROUTINE MAKETMP). THESE VALUES ARE TO BE USED AS THE INITIAL +C GUESSES TO INITIATE THE NELDER MEED ALGORITHM. + + + +C AS OF BESTDOS111.FOR, IF IOPTIMIZE = 0, IT MEANS THAT THE USER DOES +C NOT WANT TO FIND THE BEST DOSES TO HIT THE TARGETS. INSTEAD HE +C SIMPLY WANTS TO USE THE DOSES SPECIFIED IN THE "FUTURE" FILE. THIS +C CAN BE ACHIEVED BY SETTING STEP(.) VALUUES BELOW TO 0. THAT WAY, +C ELDERY WILL SIMPLY SETTLE FOR THE INITIAL VALUES, AS DESIRED. + + IDOS = 0 + + DO I = ND41+1,ND + + DO J = 1,NDRUG + IF(RS(I,2*J-1) .GT. 0.D0) THEN + IDOS = IDOS + 1 + START(IDOS) = RS(I,2*J-1) + STEP(IDOS)= -.2D0*START(IDOS) + IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 + ENDIF + + IF(RS(I,2*J) .GT. 0.D0) THEN + IDOS = IDOS + 1 + START(IDOS) = RS(I,2*J) + STEP(IDOS)= -.2D0*START(IDOS) + IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 + ENDIF + END DO + END DO + + +C NOTE THAT THE TOTAL NO. OF DOSES OVER WHICH THE MINIMIZATION WILL +C BE DONE IS NDOS = IDOS FROM THE ABOVE LOOP. THIS VALUE MUST + +C BE .LE. 5000. + + NDOS = IDOS + + IF(NDOS .GT. 5000) THEN + + WRITE(*,103) NDOS + 103 FORMAT(/' THE MAXIMUM NO. OF DOSES OVER WHICH THE'/ + 1' MINIMIZATION CAN BE RUN IS 5000. IN YOUR PATIENT DATA FILE,'/ + 2' THE NO. OF NON-ZERO DOSES (IV OR BOLUS) OVER WHICH THE '/ + 3' OPTIMIZATION TAKES PLACE IS ',I8,' WHICH IS MORE THAN 5000. '/ + 4' SO THE PROGRAM STOPS.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,103) NDOS + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + +C HARDCODE IPRINTOUT = 1 FOR NOW, SO THAT THE CONVERGENCE INFO WILL +C PRINT TO THE SCREEN IN SUBROUTINE ELDERY. IF THIS INFO SHOULD BE +C SUPPRESSED IPRINTOUT WILL BE CHANGED TO 0. + + IPRINTOUT = 1 + + + IF(IOPTIMIZE .EQ. 0) IPRINTOUT = 0 + + CALL ELDERY(NDOS,START,DOSEBEST,VALMIN,1.D-10,STEP,1000,CALCS, + 1 0,ICONV,NITER,ICNT,IPRINTOUT) + + +C NOTE THAT ELDERY CALLS CALCS TO WHICH THE FOLLOWING VALUES ARE +C SUPPLIED VIA COMMON TOCALC (NDOS AND THE CANDIDATE OF DOSES ARE +C SUPPLIED AS CALLING ARGUMENTS FROM SUBROUTINE ELDERY). + +C 1. NOBSER = NO. OF OBSERVED VALUES IN THE PATIENT DATA FILE. +C 2. NUMEQT = NO. OF OUTPUT EQUATIONS IN THE PATIENT DATA FILE. +C 3. NGRD = NO. OF GRID POINTS OVER WHICH THE ABOVE EXPECTED VALUE +C IS TO BE CALCULATED. +C 4. NVAR = NO. OF DIMENSIONS IN THE RANDOM PARAMETER VECTOR. +C 5. DENSITY(I,J) = VALUE OF THE JTH RANDOM VARIABLE FOR GRID POINT I, +C J=1,NVAR; I=1,NGRD. +C DENSITY(I,NVAR+1) = DISCRETE DENSITY ASSOCIATED WITH GRID PT. I. +C 6. NDD41 IS NO. OF DOSE EVENTS IN THE "PAST" +C 7. BIASWEIGHT = WEIGHT FOR THE BIAS TERM IN THE CALCULATION OF THE +C COST FUNCTION; (1-BIASWEIGHT) = WEIGHT FOR THE MEAN SQUARE +C ERROR TERM. + + +C RETURNING FROM ELDERY ARE: + +C DOSEBEST(I),I=1,NDOS = THE DOSES WHICH MINIMIZE THE EXPECTED +C WEIGHTED SUM OF SQUARES DESCRIBED ABOVE. + +C VALMIN = MIN. VALUE OF THE FUNCTION ACHIEVED. + +C ICONV = 1 IF THE CONVERGED; 0 OTHERWISE. + +C NOTE THAT PREDMIN, PASSED TO THIS ROUTINE VIA COMMON/PREDVAL, WHERE +C IT WAS STORED BY SUBROUTINE CALCS (THE ROUTINE CALLED BY ELDERY), +C CONTAINS, FOR EACH GRID POINT, THE PREDICTED VALUES. THESE VALUES +C WILL BE WRITTEN, ALONG WITH THE TARGET CONCENTRATIONS, THE BEST SET +C OF DOSES, AND THE ASSOCIATED VALMIN, INTO DOSEROUTxxxx BELOW ... IF +C THIS CALL TO ELDERY PRODUCES A VALMIN WHICH IS LOWER THAN THE NEXT +C CALL. STORE THESE VALUES FOR NOW. + +C STORE PREDMIN, VALMIN, DOSEBEST, DENSITY FROM THIS RUN. + + VALMIN1 = VALMIN + + DO IGRD = 1,NGRD + DO I = 1,NOBSER + DO J = 1,NUMEQT + PREDMIN1(IGRD,I,J) = PREDMIN(IGRD,I,J) + END DO + END DO + END DO + + DO I = 1,NACTVE + DO J = 1,NVAR+1 + DENSITY1(I,J) = DENSITY(I,J) + END DO + END DO + + DO I = 1,NDOS + DOSEBEST1(I) = DOSEBEST(I) + END DO + + + +C *************** FIRST CALL TO ELDERY ABOVE ************************* + + +C *************** SECOND CALL TO ELDERY BELOW ************************ + +C THE SECOND CALL TO ELDERY WILL BE WITH DENSITY VALUES WHICH ARE +C ALL THE SAME (AS WAS DONE IN BESTDOS112.FOR). THESE VALUES WILL +C BE ESTABLISHED NOW. + + DO I = 1,NACTVE + DENSITY(I,NVAR+1) = 1.D0/NACTVE + END DO + +C CALL SUBROUTINE ELDERY TO FIND THE BEST SET OF NDOS DOSES (AT THE +C TIMES READ IN FROM THE PATIENT DATA FILE BY SUBROUTINE FILRED - +C THESE TIMES ARE PUT INTO COMMON BY FILRED) TO MINIMIZE THE EXPECTED +C WEIGHTED SUM OF SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET +C CONCENTRATIONS (THE OBSERVATION TIMES AND TARGET CONCENTRATIONS ARE +C ALSO READ IN BY FILRED AND PUT INTO COMMONS TO BE USED BY SUBROUTINE +C CALCS WHICH IS CALLED BY SUBROUTINE ELDERY). THE EXPECTED VALUE IS +C OVER THE PRIOR DENSITY (HAVING PARAMETER VALUES AND CORRESPONDING +C DENSITIES) READ IN ABOVE. + +C IN PARTICULAR, ELDERY MINIMIZES EXPSUM = SUM, OVER I=1,NGRD, OF +C DENSITY(I,NVAR+1)*SUMSQ(I), WHERE SUMSQ(I) IS THE WEIGHTED SUM OF +C SQUARES OF DIFFERENCES W(k,l)*(O(I,k,l) -T(k,l))**2, WHERE O(I,k,l) +C IS THE CONCENTRATION AT TIME (k,l) ASSUMING THE ITH GRID POINT; +C T(k,l) IS THE TARGET CONCENTRAIION OF THE lth EQUATION AT TIME k, AND +C W(k,l) IS THE CORRESPONDING WEIGHT CALCULATED ABOVE. + + +C PREPARE TO CALL ELDERY. + +C THE IV DOSE VALUES IN THE PATIENT DATA FILE ARE IN RS(I,2*J-1), +C I=1,ND; J=1,NDRUG; AND THE BOLUS VALUES IN THE PATIENT DATA FILE +C ARE IN RS(I,2*J), ALL RETURNED FROM THE CALL TO FILRED ABOVE. BUT + + +C NOTE THAT ONLY THE NON-0 IVs AND BOLUSES FROM DOSE EVENTS ND41+1 +C TO ND WILL BE THE DOSES OVER WHICH THE OPTIMIZATION WILL TAKE PLACE +C BELOW. THE REASON IS THAT THE FIRST ND41 DOSE EVENTS WERE IN THE +C "PAST", WHILE THE DOSES STARTING WITH NO. ND41+1 ARE IN THE "FUTURE" +C (SEE SUBROUTINE MAKETMP). THESE VALUES ARE TO BE USED AS THE INITIAL +C GUESSES TO INITIATE THE NELDER MEED ALGORITHM. + +C AS OF BESTDOS111.FOR, IF IOPTIMIZE = 0, IT MEANS THAT THE USER DOES +C NOT WANT TO FIND THE BEST DOSES TO HIT THE TARGETS. INSTEAD HE +C SIMPLY WANTS TO USE THE DOSES SPECIFIED IN THE "FUTURE" FILE. THIS +C CAN BE ACHIEVED BY SETTING STEP(.) VALUUES BELOW TO 0. THAT WAY, +C ELDERY WILL SIMPLY SETTLE FOR THE INITIAL VALUES, AS DESIRED. + +C NOTE THAT THE RS(.,.) VALUES HAVE CHANGED FROM THEIR READ IN VALUES +C FROM SUBROUTINE FILRED (IN THE FIRST CALL TO ELDERY ABOVE). SO, +C RESET THESE VALUES BEFORE ESTABLISHING START(.) AND STEP(.) FOR THE +C 2ND CALL TO ELDERY BELOW. DO THIS BY CALLING FILRED AGAIN. + + +C AS OF BESTDOS119.FOR, THE PATIENT DATA ARE ON FILE 37 INSTEAD OF +C FILE 27 (SEE NOTES ABOVE WHERE SUBROUTINE NEWWORK1 IS CALLED). + +C REWIND FILE 37, WHICH HAS THE PATIENT DATA FILE ON IT. + + REWIND(37) + + CALL FILRED(NOBSER,ND,NDRUG,RS,SIG,YO,C0,C1,C2,C3,MAXOBDIM) + + + IDOS = 0 + + DO I = ND41+1,ND + DO J = 1,NDRUG + IF(RS(I,2*J-1) .GT. 0.D0) THEN + IDOS = IDOS + 1 + START(IDOS) = RS(I,2*J-1) + STEP(IDOS)= -.2D0*START(IDOS) + IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 + ENDIF + IF(RS(I,2*J) .GT. 0.D0) THEN + IDOS = IDOS + 1 + START(IDOS) = RS(I,2*J) + STEP(IDOS)= -.2D0*START(IDOS) + IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 + + ENDIF + END DO + END DO + + +C NOTE THAT THE TOTAL NO. OF DOSES OVER WHICH THE MINIMIZATION WILL +C BE DONE IS NDOS = IDOS FROM THE ABOVE LOOP. THIS VALUE MUST +C BE .LE. 5000. + + NDOS = IDOS + + + IF(NDOS .GT. 5000) THEN + + WRITE(*,103) NDOS + + OPEN(47,FILE=ERRFIL) + WRITE(47,103) NDOS + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + +C HARDCODE IPRINTOUT = 1 FOR NOW, SO THAT THE CONVERGENCE INFO WILL +C PRINT TO THE SCREEN IN SUBROUTINE ELDERY. IF THIS INFO SHOULD BE +C SUPPRESSED IPRINTOUT WILL BE CHANGED TO 0. + + IPRINTOUT = 1 + IF(IOPTIMIZE .EQ. 0) IPRINTOUT = 0 + + CALL ELDERY(NDOS,START,DOSEBEST,VALMIN,1.D-10,STEP,1000,CALCS, + 1 0,ICONV,NITER,ICNT,IPRINTOUT) + +C NOTE THAT ELDERY CALLS CALCS TO WHICH THE FOLLOWING VALUES ARE +C SUPPLIED VIA COMMON TOCALC (NDOS AND THE CANDIDATE OF DOSES ARE +C SUPPLIED AS CALLING ARGUMENTS FROM SUBROUTINE ELDERY). + +C 1. NOBSER = NO. OF OBSERVED VALUES IN THE PATIENT DATA FILE. +C 2. NUMEQT = NO. OF OUTPUT EQUATIONS IN THE PATIENT DATA FILE. +C 3. NGRD = NO. OF GRID POINTS OVER WHICH THE ABOVE EXPECTED VALUE +C IS TO BE CALCULATED. +C 4. NVAR = NO. OF DIMENSIONS IN THE RANDOM PARAMETER VECTOR. +C 5. DENSITY(I,J) = VALUE OF THE JTH RANDOM VARIABLE FOR GRID POINT I, +C J=1,NVAR; I=1,NGRD. +C DENSITY(I,NVAR+1) = DISCRETE DENSITY ASSOCIATED WITH GRID PT. I. +C 6. NDD41 IS NO. OF DOSE EVENTS IN THE "PAST" +C 7. BIASWEIGHT = WEIGHT FOR THE BIAS TERM IN THE CALCULATION OF THE +C COST FUNCTION; (1-BIASWEIGHT) = WEIGHT FOR THE MEAN SQUARE +C ERROR TERM. + +C RETURNING FROM ELDERY ARE: + +C DOSEBEST(I),I=1,NDOS = THE DOSES WHICH MINIMIZE THE EXPECTED +C WEIGHTED SUM OF SQUARES DESCRIBED ABOVE. + +C VALMIN = MIN. VALUE OF THE FUNCTION ACHIEVED. + +C ICONV = 1 IF THE CONVERGED; 0 OTHERWISE. + +C NOTE THAT PREDMIN, PASSED TO THIS ROUTINE VIA COMMON/PREDVAL, WHERE + +C IT WAS STORED BY SUBROUTINE CALCS (THE ROUTINE CALLED BY ELDERY), +C CONTAINS, FOR EACH GRID POINT, THE PREDICTED VALUES. THESE VALUES +C WILL BE WRITTEN, ALONG WITH THE TARGET CONCENTRATIONS, THE BEST SET +C OF DOSES, AND THE ASSOCIATED VALMIN, INTO DOSEROUTxxxx BELOW ... IF +C THIS CALL TO ELDERY PRODUCES A VALMIN WHICH IS LOWER THAN THE +C PREVIOUS CALL. STORE THESE VALUES FOR NOW. + +C STORE PREDMIN, VALMIN, DOSEBEST, DENSITY FROM THIS RUN. + + VALMIN2 = VALMIN + + +C *************** SECOND CALL TO ELDERY ABOVE *********************** + +C IF VALMIN2 .LE. VALMIN1, THEN THE VALUES IN PREDMIN, DENSITY, +C AND DOSEBEST ARE CORRECT. OTHERWISE, THE FIRST CALL TO ELDERY +C RESULTED IN THE MINIMUM SUM OF SQUARES. IN THIS CASE, RESET THESE +C VALUES TO WHAT THEY WERE AFTER THAT FIRST CALL TO ELDERY. + + IF(VALMIN2 .GT. VALMIN1) THEN + + VALMIN = VALMIN1 + + DO IGRD = 1,NGRD + DO I = 1,NOBSER + DO J = 1,NUMEQT + PREDMIN(IGRD,I,J) = PREDMIN1(IGRD,I,J) + END DO + END DO + END DO + + DO I = 1,NACTVE + DO J = 1,NVAR+1 + DENSITY(I,J) = DENSITY1(I,J) + END DO + END DO + + DO I = 1,NDOS + DOSEBEST(I) = DOSEBEST1(I) + END DO + + + ENDIF +C ABOVE ENDIF IS FOR THE IF(VALMIN2 .GT. VALMIN1) CONDITION. + +C REWIND FILE 27, AND CALL FILRED AGAIN. THIS IS DONE TO RE-ESTABLISH +C THE ORIGINAL DOSE VALUES INTO THE RS(.,.) ARRAY. THE REASON IS THAT +C ELDERY CALLS CALCS, WHICH CALLS WSUMSQ, WHICH SETS THE RS(.,.) VALUES +C TO THE CURRENT CANDIDATES SUPPLIED BY ELDERY. AND IF THESE VALUES +C HAPPEN TO BE SET = 0, THEN THE CODE TO WRITE OUT THE OPTIMAL DOSES +C BELOW (WHICH DEPEND ON RS(I,2*J-1) OR RS(I,2*J) BEING > 0 TO +C IDENTIFY AN IV OR A BOLUS, RESPECTIVELY) WILL NOT BE ENGAGED. AND +C THEN THE #OPTIMAL DOSES LINE WILL BE FOLLOWED BY NO DOSES AT ALL. +C IN ADDITION, THE CODE TO ESTABLISH THE BEST DOSES INTO RS(.,.) FOR +C THE PURPOSE OF WRITING THE PREDICTED VALUES FOR THESE BEST DOSES, +C FOR EACH GRID PT. IN THE PARAMETER DENSITY, WILL NOT BE ENGAGED +C EITHER. + + +C AS OF BESTDOS119.FOR, THE PATIENT DATA ARE ON FILE 37 INSTEAD OF +C FILE 27 (SEE NOTES ABOVE WHERE SUBROUTINE NEWWORK1 IS CALLED). + +C REWIND FILE 37, WHICH HAS THE PATIENT DATA FILE ON IT. + + REWIND(37) + CALL FILRED(NOBSER,ND,NDRUG,RS,SIG,YO,C0,C1,C2,C3,MAXOBDIM) + +C CREATE OUTPUT FILE WHICH HAS 'DOSEROUT' AS ITS 1ST 8 CHARACTERS AND +C NAME AS ITS LAST 4. NOTE THAT NAME WAS ESTABLISHED ABOVE WHEN +C FILE 'EXTNUM' WAS READ. + + OUTFIL = 'DOSEROUT'//NAME + TMPFILE = ' ' + TMPFILE = OUTFIL + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(56,FILE=PATHFILE) + +C FIRST, WRITE ALL INPUT INSTRUCTIONS TO THE OUTPUT FILE. + + WRITE(56,8151) + 8151 FORMAT(/' INSTRUCTIONS FOR THIS RUN WERE AS FOLLOWS: '/) + + WRITE(56,8137) + 8137 FORMAT(/' THE PATH FOR THE WORKING DIRECTORY WAS ') + WRITE(56,2221) PATH + + + WRITE(56,8111) + WRITE(56,2) FORFILE + + WRITE(56,8112) + WRITE(56,*) (IRAN(I),I=1,NP) + + WRITE(56,9006) + WRITE(56,2) NPAGDENFILE + + WRITE(56,9017) + WRITE(56,*) MAXCYC + + WRITE(56,9008) + WRITE(56,*) IPASTFILE + + WRITE(56,9011) + IF(INCLUDPAST .EQ. 0) WRITE(56,9007) + 9007 FORMAT(' N/A') + IF(INCLUDPAST .EQ. 1) WRITE(56,2) PASTFILEIN + + WRITE(56,8116) + WRITE(56,*) ICSVFILE + + WRITE(56,8117) + WRITE(56,2) FUTUREFILEIN + + WRITE(56,8118) + WRITE(56,*) TNEXT + + WRITE(56,8119) + WRITE(56,*) NOFIX + + WRITE(56,8121) + IF(NOFIX .GT. 0) WRITE(56,2416) (VALFIX(I),I=1,NOFIX) + + WRITE(56,8122) + WRITE(56,*) TOLER + + WRITE(56,8123) + WRITE(56,*) NUMEQT + + WRITE(56,8124) + DO IEQ=1,NUMEQT + WRITE(56,2416) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + END DO + + WRITE(56,8127) + WRITE(56,*) (IASS(I),I=1,NUMEQT) + + WRITE(56,9131) + WRITE(56,*) NDRUG + + + WRITE(56,8131) + WRITE(56,*) (AF(I),I=1,NDRUG) + + WRITE(56,8132) + WRITE(56,*) IOPTIMIZE + + WRITE(56,8136) + WRITE(56,*) BIASWEIGHT + + WRITE(56,8138) + WRITE(56,*) ITARGET + + + WRITE(56,8152) + 8152 FORMAT(/'-----------------------------------------------------') + + +C NOW, WRITE THE RESULTS TO THE OUTPUT FILE. + + WRITE(56,206) EEXPSUMMIN,BIASWEIGHT,SUMMIN,BIASMIN + + WRITE(*,206) EEXPSUMMIN,BIASWEIGHT,SUMMIN,BIASMIN + 206 FORMAT(/' THE MIMIMUM ACHIEVED COST FUNCTION IS ',G14.6// + 1' WHICH = (1 - BIASWEIGHT)*SUMMIN + BIASWEIGHT*BIASMIN, WHERE '// + + + 2' BIASWEIGHT = ',G14.6/ + 3' SUMMIN = ',G14.6/ + 4' BIASMIN = ',G14.6) + + WRITE(56,201) NOBSER,NUMEQT + 201 FORMAT(//' THE NEXT ',I4,' LINES GIVE THE TARGET VALUES, EACH'/ + 1' LINE HAVING THE VALUES FOR EACH OF THE ',I2,' OUTPUT EQUATION(S) + 2.') + + DO I = 1,NOBSER + WRITE(56,1212) (YO(I,J),J=1,NUMEQT) + END DO + 1212 FORMAT(1X,6(G12.5,1X)) + + + WRITE(56,717) NVAR,NACTVE + 717 FORMAT(//' FOR THE DENSITY USED IN THE CALCULATIONS OF THE '/ + 1' SIMULATED VALUES BELOW (AND USED TO ESTABLISH THE OPTIMAL'/ + 2' DOSES IF THAT WAS REQUESTED) ...'/ + 3' THE NO. OF RANDOM PARAMETERS IS ',I8/ + 4' THE NO. OF GRID POINTS IS ',I8/ + 5' THE DENSITY ARRAY ITSELF NOW FOLLOWS, ONE LINE (PERHAPS '/ + 6' WRAPPED) FOR EACH GRID PT. WITH THE PARAMETER VALUES FOLLOWED'/ + 7' BY THE PROB. FOR EACH POINT') + + DO I = 1,NACTVE + WRITE(56,*) (DENSITY(I,J),J=1,NVAR+1) + END DO + + WRITE(56,202) NGRD,NGRD,NOBSER,NUMEQT + 202 FORMAT(//' THE FOLLOWING ',I5,' SET(S) OF LINES GIVE THE'/ + 1' ACHIEVED OBSERVED VALUES FOR EACH OF THE ',I5,' GRID PT(S).'/ + + 2' EACH SET HAS ',I4,' ROW(S), (ONE ROW FOR EACH OBSERVATION TIME)' + 3/ + 4' AND ',I2,' COLUMN(S) (EACH COLUMN RESPRESENTS AN OUTPUT EQ.)'/) + + DO IGRD = 1,NGRD + DO I = 1,NOBSER + WRITE(56,1212) (PREDMIN(IGRD,I,J),J=1,NUMEQT) + END DO + END DO + + IF(ICONV .EQ. 0) WRITE(*,7134) + IF(ICONV .EQ. 0) WRITE(56,7134) + 7134 FORMAT(//' THE NELDER MEED ESTIMATE FOR THE BEST SET OF DOSES'/ + 1' DID NOT CONVERGE. '/) + + + WRITE(56,101) + 101 FORMAT(//' THE FOLLOWING MATRIX GIVES THE OPTIMAL DOSES. EACH'/ + 1' HAS, IN ORDER, TIME, DURATION, TOTAL DOSE, AND DRUG NO.') + +C BUT NOTE THAT ALL TIMES IN THE "FUTURE" HAD TNEXT ADDED TO THEM WHEN +C THE "FUTURE" WAS CONCATENATED TO THE "PAST". SO NOW, DECREASE ALL +C THESE "FUTURE" TIMES BY TNEXT BEFORE WRITING THEM TO THE OUTPUT FILE. + + WRITE(56,102) + 102 FORMAT(/'#OPTIMAL DOSES') + + IDOS = 0 + + DO I = ND41+1,ND + DO J = 1,NDRUG + + IF(RS(I,2*J-1) .GT. 0.D0) THEN + + IDOS = IDOS + 1 + +C SINCE RS(I,2*J-1) > 0, IT MEANS THAT THE IV FOR DRUG J DURING TIME +C INTERVAL SIG(I+1) - SIG(I) WAS OPTIMIZED AND FOUND TO BE +C DOSEBEST(IDOS). WRITE OUT FOR THIS DOSE, THE START TIME, THE DURATION +C OF THE IV, THE TOTAL DOSE AMOUNT, AND THE DRUG NO. + + +C NOTE THAT, FOR NOW, IT IS ASSUMED +C THAT I .NE. ND, BECAUSE IF IT IS, IT MEANS THAT AN IV STARTED AT +C THE LAST DOSE EVENT AND CONTINUED FOREVER (I.E., IT WILL BE ASSUMED +C THE USER ALWAYS INCLUDED A FINAL DOSE EVENT IN HIS PATIENT'S FILE +C THAT TURNED OFF ALL IVs). IF THIS IS NOT THE CASE, SET DURATION(.) +C TO -1 AND WRITE A MESSAGE TO THE USER. + + TSTART = SIG(I) - TNEXT + +C AS OF BESTDOS119.FOR, THERE MAY BE A STEADY STATE DOSE SET AT THE +C BEGINNING OF THE PATIENT'S REGIMEN. IN THIS CASE SIG(1) < 0. FOR +C EXAMPLE, SIG(1) = -2 --> THERE IS A STEADY STATE DOSE SET UNTIL +C 100*2 = TIME = 200. IN THIS CASE, SIG(I) ABOVE IS THE ACTUAL +C TIME OF THE BEGINNING OF THE DOSE, NOT THE RELATIVE TIME (RELATIVE +C TO THE END OF THE STEADY STATE DOSE SET). SINCE ALL THE TIMES +C WRITTEN BELOW FOR THE PREDICTED Y'S AND THE AUC'S ARE RELATIVE +C TIMES, THE OPTIMUM DOSE TIMES SHOULD BE ALSO. SO ADJUST TSTART +C HERE: + + IF(SIG(1) .LT. 0.D0) TSTART = TSTART + 100.D0*SIG(1) + + + IF(I .LT. ND) DURIV = SIG(I+1) - SIG(I) + + + IF(I .EQ. ND) THEN + DURIV = -1 + WRITE(56,1053) J + + WRITE(*,1053) J + 1053 FORMAT(/' DRUG ',I3,' HAS AN IV WHICH IS NEVER TURNED OFF.'/ + 1' AS A RESULT, ITS DURATION WILL BE ARBIRTRARILY SET = -1 SO'/ + 2' IT WILL BE CLEAR IN THE OUTPUT FILE THAT THE TOTAL DOSE IS'/ + 3' NOT AVAILABLE. INSTEAD THE IV RATE IS THE ABS. VALUE OF THE'/ + 4' VALUE IN THE OUTPUT FILE.'/) + CALL PAUSE + ENDIF + + DOSTOT = DOSEBEST(IDOS)*DURIV + + WRITE(56,104) TSTART,DURIV,DOSTOT,J + 104 FORMAT(1X,G14.4,2X,G14.4,2X,G18.6,2X,I3) + + + ENDIF +C THE ABOVE ENDIF IS FOR THE IF(RS(I,2*J-1) .GT. 0.D0) CONDITION. + + + IF(RS(I,2*J) .GT. 0.D0) THEN + + IDOS = IDOS + 1 + +C SINCE RS(I,2*J) > 0, IT MEANS THAT THE BOLUS FOR DRUG J AT TIME +C SIG(I) WAS OPTIMIZED AND FOUND TO BE DOSEBEST(IDOS).WRITE OUT FOR +C THIS DOSE, THE START TIME, THE DURATION (WHICH IS 0.0), THE TOTAL +C DOSE AMOUNT (WHICH IS JUST THE BOLUS), AND THE DRUG NO. ALSO, +C AS OF BESTDOS119.FOR, ADJUST TSTART TO BE A RELATIVE TIME, RATHER +C THAN AN ACTUAL TIME (SEE COMMENTS ABOVE). + + TSTART = SIG(I) - TNEXT + IF(SIG(1) .LT. 0.D0) TSTART = TSTART + 100.D0*SIG(1) + DURIV = 0.D0 + DOSTOT = DOSEBEST(IDOS) + + WRITE(56,104) TSTART,DURIV,DOSTOT,J + + + ENDIF +C THE ABOVE ENDIF IS FOR THE IF(RS(I,2*J) .GT. 0.D0) CONDITION. + + + END DO +C THE ABOVE END DO IS FOR THE DO J = 1,NDRUG LOOP. + + END DO +C THE ABOVE END DO IS FOR THE DO I = ND41+1,ND LOOP. + + + +C NOW, FOR EACH GRID POINT IN THE PARAMETER DENSITY, MUST FIND THE +C PREDICTED OBSERVED VALUES EVERY IDELTA MINUTES, GIVEN THE BEST DOSES +C THIS PROGRAM OBTAINED ABOVE. + +C FIRST RESTORE INTO THE RS ARRAY THE BEST DOSES FOUND BY THE CALL TO +C ELDERY ABOVE. AND THEN ESTABLISH THE BOLUS VALUES SINCE THEY WILL +C ALSO BE PASSED TO SUBROUTINE IDCALCYY/FUNC3 BELOW, VIA COMMON/OBSER. + + IDOS = 0 + + DO I = ND41+1,ND + DO J = 1,NDRUG + IF(RS(I,2*J-1) .GT. 0.D0) THEN + IDOS = IDOS + 1 + RS(I,2*J-1) = DOSEBEST(IDOS) + ENDIF + IF(RS(I,2*J) .GT. 0.D0) THEN + IDOS = IDOS + 1 + RS(I,2*J) = DOSEBEST(IDOS) + ENDIF + END DO + END DO + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + +C CALL CALCTPRED TO CALCULATE THE NUMT TIMES TO BE IN TPRED. + + CALL CALCTPRED(IDELTA,NOBSER,TNEXT,NUMT,TPRED,TPREDREL) + + +C AS OF BESTDOS109.FOR, TPREDREL AND OTHER ARRAYS RELATED TO TIME + +C RESETS AND STEADY STATE DOSE SETS ARE REMOVED FROM THIS PROGRAM, +C ... SINCE THIS PROGRAM DOES NOT ALLOW TIME RESETS/STEADY STATE +C DOSING. + +C NOTE THAT TPRED NOW CONTAINS THE NUMT PREDICTED TIMES, IDELTA +C MINUTES APART, ALONG WITH THE OBSERVATION AND DOSE TIMES (BUT +C DUPLICATE TIMES HAVE BEEN REMOVED). + + +C FOR EACH GRID PT. IN THE PARAMETER DENSITY, CALCULATE AND WRITE +C TO THE OUTPUT FILE, SIMULATED OBSERVED VALUES AT THE TIMES IN +C TPRED (SEE CALCTPRED ABOVE), ASSUMING THE OPTIMAL DOSES CALCULATED +C BY ELDERY ABOVE. + + WRITE(56,2133) NGRD,NUMT,IDELTA +2133 FORMAT(//'# SIMULATED OBSERVED VALUES AND AUCs FOLLOW, ONE TABLE'/ + 1' FOR EACH GRID POINT, AND A FINAL TABLE WITH THE WEIGHTED '/ + 2' OBSERVED VALUES AND AUCs, FOR EACH OUTPUT EQUATION. NOTE THAT'/ + 3' THERE ARE:'/ + 2I6,' NO. OF GRID POINTS'/ + 3I6,' NO. OF SIMULATED OBSERVED VALUES AND AUCs FOR EACH TABLE'/ + 4I6,' NO. OF MINS BETWEEN SIMULATED VALUES, EXCEPT FOR EXTRA OBS/ + 5DOSE TIMES') + +C INITIALIZE THE MEAN OBSERVATION AT EACH OF THE NUMT TIMES, FOR EACH +C OUTPUT EQ. TO BE 0. AT THE END OF THE DO IGRD LOOP, YBAR(J,IEQ) +C WIL BE THE MEAN OBSERVATION OVER ALL THE GRID PTS. FOR TIME J +C AND OUTPUT EQ. IEQ. SIMILARLY FOR AUCBAR(J,IEQ), WHICH WILL BE THE +C MEAN AUC OVER ALL THE GRID PTS. FOR TIME J AND OUTPUT EQ. IEQ. + + DO J = 1,NUMT + DO IEQ = 1,NUMEQT + YBAR(J,IEQ) = 0.D0 + AUCBAR(J,IEQ) = 0.D0 + END DO + END DO + + + DO IGRD = 1,NGRD + + +C STORE INTO THETA THE PARAMETER VALUES FOR GRID POINT IGRD. + + DO J=1,NVAR + THETA(J) = DENSITY(IGRD,J) + END DO + +C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO +C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL +C MAKEVEC TO DO THIS. + + CALL MAKEVEC(NVAR,NOFIX,IRAN,THETA,VALFIX,PX) + +C CALL SUBROUTINE IDCALCYY FOR THIS GRID PT. IN THE PARAMETER DENSITY. +C THIS IS A VERSION OF THE ID PROGRAM WHICH CALCULATES THE PREDICTED +C VALUES OF Y(I,J) (OUTPUT CONCENTRATION OF THE JTH OUTPUT EQ. AT TIME +C TPRED(I),I=1,NUMT), ASSUMING THE GIVEN GRID PT. NOTE THAT IN +C IDCALCYY, THE PREDICTED VALUES ARE SUPPLIED IN TPRED, RATHER THAN +C INPUT VIA COMMON/OBSER FROM THE PATIENT'S DATA FILE. ALSO, THE NO. +C OF OBSERVED TIMES IS NUMT, RATHER THAN M WHICH IS SUPPLIED VIA +C COMMON/SUM2. AND NOTE THAT NUMT AND TPRED(.) ARE FOUND FROM THE CALL +C TO CALCTPRED ABOVE. + + CALL IDCALCYY(NVAR+NOFIX,NDIM,PX,TPRED,NUMT,YYPRED,NUMEQT) + + + DO IEQ = 1,NUMEQT + +C FOR GRID PT. IGRD, AND OUTPUT EQ. IEQ, WRITE THE TABLE OF PREDICTED +C VALUES AND AUCs AT THE END OF EACH OF THE NUMT TIME PERIODS. + +C FIRST WRITE THE HEADER FOR THE TABLE. + + WRITE(56,2131) IGRD,DENSITY(IGRD,NVAR+1),IEQ + 2131 FORMAT(//'# GRID PT., ASSOCIATED PROB., AND OUTPUT EQ. NO. ARE: '/ + 1 I5,2X,G16.10,2X,I2/) + + +C THE AUC STARTS AT 0 AT TPREDREL(1), WHICH WILL BE 0. THEN IT WILL +C BE UPDATED FOR EACH INTERVAL, USING THE TRAPEZOIDAL RULE. + + DO J = 1,NUMT + + IF(J .EQ. 1) AUC = 0.D0 + +C AS OF BESTDOS116.FOR, AUCs IN THE "FUTURE" ARE RELATIVE TO THE +C BEGINNING OF THE "FUTURE", WHICH OCCURS AT TNEXT. SO SET AUC BACK +C TO 0 AT TIME TNEXT. + +C NO! AS OF BESTDOS118.FOR, EVEN THOUGH THE CODE IN WSUMSQ (IN +C CALCBST14.FOR) IS UNCHANGED, SO THAT AUCs IN THE "FUTURE" ARE +C RELATIVE TO THE BEGINNING OF THE "FUTURE", AND ARE RESET TO 0 AT +C TIME TNEXT, THE AUCs IN THE DOSEROUTxxxx FILE WILL BE CUMULATIVE +C FROM TIME 0 IN THE "PAST". SO COMMENT OUT THE CODE BELOW TO CALL +C THESAME, AND COMMENT OUT THE RESETTING OF AUC IF ISAME = 1. + +C CALL THESAME(TPREDREL(J),TNEXT,ISAME) + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TPREDREL(I) = TNEXT, +C OR AT LEAST, THEY ARE WITHIN 1.D-10 OF EACH OTHER. IN THIS CASE, +C SET AUC BACK TO 0. + + IF(J .GT. 1) THEN + DELTA = TPREDREL(J) - TPREDREL(J-1) + AUC = AUC + (YYPRED(J,IEQ) + YYPRED(J-1,IEQ))/2.D0 * DELTA +C IF(ISAME .EQ. 1) AUC = 0 + ENDIF + + WRITE(56,*) TPREDREL(J),YYPRED(J,IEQ),AUC + +C ADD THIS YYPRED(J,IEQ) TO THE OVERALL WEIGHTED OBSERVATION. SIMILARLY +C FOR THE OVERALL WEIGHTED AUC. + + YBAR(J,IEQ) = YBAR(J,IEQ) + DENSITY(IGRD,NVAR+1)*YYPRED(J,IEQ) + AUCBAR(J,IEQ) = AUCBAR(J,IEQ) + DENSITY(IGRD,NVAR+1)*AUC + + END DO +C THE ABOVE END DO IS FOR THE DO J = 1,NUMT LOOP. + + END DO +C THE ABOVE END DO IS FOR THE DO IEQ = 1,NUMEQT LOOP. + + END DO +C THE ABOVE END DO IS FOR THE DO IGRD = 1,NGRD LOOP. + + +C NOW ADD THE TABLE FOR THE WEIGHTED MEANS OF THE OBSERVATIONS AND +C AUCs. + + DO IEQ = 1,NUMEQT + +C FOR THIS WEIGHTED MEAN GRID PT., AND OUTPUT EQ. IEQ, WRITE THE TABLE +C OF PREDICTED VALUES AND AUCs AT THE END OF EACH OF THE NUMT TIME +C PERIODS. + +C FIRST WRITE THE HEADER FOR THE TABLE. + + WRITE(56,2134) IEQ + 2134 FORMAT(//'# WEIGHTED OBSERVED VALUES AND AUCs; OUTPUT EQ ',I2/) + + DO J = 1,NUMT + WRITE(56,*) TPREDREL(J),YBAR(J,IEQ),AUCBAR(J,IEQ) + END DO + + END DO + +C THE ABOVE END DO IS FOR THE DO IEQ = 1,NUMEQT LOOP. + + +C NOTE THAT FOR BESTDOS107.FOR, THE PREDICTED TIMES AND AUCs ARE +C CALCULATED FOR THE ENTIRE PATIENT PROFILE (UP TO 24 HOURS AFTER THE +C MAXIMUM OBSERVED TIME). I.E., THESE VALUES START WITH TIME 0 IN THE +C "PAST" HISTORY IF THERE IS A "PAST". THIS MAY CHANGE IN A SUBSEQUENT +C PROGRAM SO THAT THESE VALUES ARE ONLY WRITTEN STARTING IN THE +C "FUTURE" OF THE PATIENT. + + + CLOSE(56) + + + + STOP + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE GETPATH(PATH,NOB) + +C THIS ROUTINE OBTAINS FROM THE USER THE PATH WHERE THE INPUT FILES +C ARE LOCATED (AND WHERE THE OUTPUT FILES WILL BE SENT). NOTE THAT + +C PATH RETURNS AS THE PATH WITH A TRAILING BACKSLASH. + +C NOB RETURNS AS THE NO. OF THE LAST NON-BLANK ENTRY IN PATH. + + CHARACTER PATH*60 + + 10 WRITE(*,1) + 1 FORMAT(/' ENTER 1 IF THE FILES FOR THIS RUN ARE IN THE CURRENT D + 1IRECTORY; '/ + 1' ENTER 0 OTHERWISE: ') + READ(*,*,ERR=10) IPATH + IF(IPATH .NE. 0 .AND. IPATH .NE. 1) GO TO 10 + + IF(IPATH .EQ. 1) PATH = ' ' + NOB = 0 + +C IF THE USER ENTERS A NON-NULL PATH BELOW, NOB WILL BE THE NO. OF +C CHARACTERS IN THE PATH. IF HE ENTERS NOTHING, NOB STAYS 0, WHICH IS + +C THE CORRECT NO. OF CHARACTERS IN A NULL PATH. + + IF(IPATH .EQ. 0) THEN + + WRITE(*,3) + 3 FORMAT(/' ENTER THE LOCATION (PATH) OF YOUR INPUT FILES. NOTE'/ + 1' THAT THE PATH IS LIMITED TO 60 CHARACTERS AND THAT EACH SUB-DIRE + 2CTORY'/ + 3' CAN HAVE AT MOST 8 CHARACTERS (E.G, INSTEAD OF " \DIRECTORY ", U + 4SE '/ + 5' THE DOS-EQUIVALENT NAME, WHICH MIGHT BE " \DIRECT~1 "). '// + 6' ENTER THE PATH NOW: ') + READ(*,2) PATH + + 2 FORMAT(A60) + +C IF THE USER DIDN'T END HIS PATH WITH A '\', PUT ONE IN FOR PATH. + +C NOTE THAT IF THE USER ENTERED A BLANK PATH, IT WILL BE ASSUMED THAT +C HE WANTS THE CURRENT (WORKING) DIRECTORY. + + DO I=1,60 + + J = 60 + 1 - I + IF(PATH(J:J) .NE. ' ') THEN + + NOB = J + IF(PATH(J:J) .NE. '\') THEN + PATH(J+1:J+1) = '\' + NOB = J+1 + ENDIF + RETURN + ENDIF + END DO + + + ENDIF + + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +C + SUBROUTINE FULLNAME(PATH,FILE,FILE2) + +C FULLNAME CONVERTS FILE TO FILE2, THE COMPLETE NAME OF +C THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE CURRENT + +C DIRECTORY). + + + CHARACTER PATH*60,FILE2*73,FILE*13,FILE1*73 + +C INITIALIZE FILE1 AND FILE2 AS ALL BLANKS, IN CASE THE USER IS +C RE-ENTERING HIS FILENAME (SO THERE WON'T BE SOMETHING ALREADY IN +C THESE FILENAMES). + + FILE2 = ' ' + FILE1 = ' ' + FILE1 = PATH//FILE + +C ESTABLISH FILE2 AS FILE1 WITHOUT ANY BLANKS. + + J = 0 + DO I=1,73 + IF(FILE1(I:I) .NE. ' ') THEN + J= J+1 + FILE2(J:J) = FILE1(I:I) + ENDIF + END DO + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + + SUBROUTINE SEEDIR(PATH,NOB,FILENAME) + CHARACTER FILENAME*20,PATH*60,PRTDIR*47,TEMP*72,PRTDIR2*47 + +C NOTE THAT PATH(1:NOB) IS THE CONDENSED (WITHOUT BLANKS) PATH. + + 10 PRTDIR = ' ' + WRITE(*,6) + 6 FORMAT(/' PRESS THE ENTER KEY TO SEE YOUR ENTIRE DIRECTORY;'// + 1' ENTER A PARTIAL FILENAME (WITH THE * WILDCARD) TO SEE A '/ + 2' PARTICULAR SUBSET OF FILENAMES IN YOUR DIRECTORY. '/ + 3' e.g., ENTER "TO*.INS TO SEE A LIST OF ALL FILES WHICH'/ + 4' BEGIN WITH "TO" AND HAVE A .INS SUFFIX '// + + 5' NOTE THAT THE FILES WILL AUTOMATICALLY BE TIME-ORDERED FROM '/ + 6' OLDEST TO NEWEST.'// + 7' ENTER YOUR CHOICE NOW: ') + READ(*,1) PRTDIR + 1 FORMAT(A47) + + +C REMOVE ANY BLANKS FROM PRTDIR SINCE THERE CAN BE NO BLANKS BETWEEN +C THE END OF THE PATH AND THE BEGINNING OF THE "OBJECT" OF THE +C DIR COMMAND FOR SUBDIRECTORIES. PRTDIR, WITHOUT BLANKS, WILL BE +C PRTDIR2. + + IF(PRTDIR .EQ. ' ') TEMP = 'DIR/OD '//PATH(1:NOB)//' |MORE' + + IF(PRTDIR .NE. ' ') THEN + PRTDIR2 = ' ' + J = 0 + DO I=1,47 + IF(PRTDIR(I:I) .NE. ' ') THEN + J = J+1 + + PRTDIR2(J:J) = PRTDIR(I:I) + + ENDIF + END DO + TEMP = 'DIR/OD '//PATH(1:NOB)//PRTDIR2(1:J)//' |MORE' + ENDIF + + + CALL SYSTEM(TEMP) + + WRITE(*,3) + 3 FORMAT(/' ENTER THE NAME OF THE DESIRED FILE (WITHOUT THE PATH); + 1'/ + 2' ENTER -99 TO ENTER A DIFFERENT FILE SPECIFICATION: ') + READ(*,2) FILENAME + 2 FORMAT(A20) + IF(FILENAME(1:3) .EQ. '-99') GO TO 10 + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE PUTASS(PATHFILE,IASS,C0P,C1P,C2P,C3P,NUMEQT) + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION IASS(MAXNUMEQ),C0P(MAXNUMEQ),C1P(MAXNUMEQ), + 1 C2P(MAXNUMEQ),C3P(MAXNUMEQ) + + + CHARACTER PATHFILE*73,READLINE*1000,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C THIS ROUTINE READS THE INFO IN FILE PATHFILE, AND MAKES SURE THE +C CORRECT ASSAY ERROR COEFFICIENTS ARE AT THE END OF THE FILE, AS +C FOLLOWS: + +C IASS(I) = 1 --> IF THE FILE ALREADY HAS C'S, THEY REMAIN; +C IF THE FILE DOESN'T HAVE C'S, +C [C0P(I),C1P(I),C2P(I),C3P(I)] ARE PUT INTO THE FILE +C FOR OUTPUT EQUATION I; I=1,NUMEQT. + + +C IASS(I) = 0 --> [C0P(I),C1P(I),C2P(I),C3P(I)] ARE PUT INTO THE FILE +C FOR OUTPUT EQUATION I; I=1,NUMEQT, REGARDLESS OF WHETHER +C THE FILE ALREADY HAS ASSAY C'S OR NOT. + + + + +C FIRST, DETERMINE IF FILE 21 HAS ASSAY COEFFICIENTS AT THE END. OPEN + +C THE FILE AND READ UNTIL THE LINE STARTING WITH +C "ASSAY COEFFICIENTS ..." IS ENCOUNTERED. IF THE NEXT WORD IS +C "FOLLOWS", THE LAST NUMEQT LINES CONTAIN ASSAY COEFFICIENTS. + + 3 FORMAT(A1000) + + OPEN(21,FILE=PATHFILE,STATUS='OLD') + 5 READ(21,3,IOSTAT=IEND) READLINE + +C IF THERE IS NO LINE WITH "ASSAY COE" ON IT, THIS IS NOT AN +C ACCEPTABLE WORKING COPY FILE. + + IF(IEND .LT. 0) THEN + + + + WRITE(*,56) PATHFILE + 56 FORMAT(//' PATIENT FILE '/ + 1' ',A73/ + 2' IS NOT AN ACCEPTABLE WORKING COPY FILE. SUCH A FILE MUST HAVE '/ + 2' "ASSAY COEFFICIENTS ... " NEAR THE BOTTOM OF THE FILE.'// + 3' THE PROGRAM STOPS. '//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,56) PATHFILE + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + IF(READLINE(1:9) .NE. 'ASSAY COE') GO TO 5 + + IF(READLINE(20:25) .EQ. 'FOLLOW' ) ICOFF = 1 + IF(READLINE(20:25) .NE. 'FOLLOW' ) ICOFF = 0 + +C NOTE THAT ICOFF = 1 IF ASSAY COEFFS. ARE AT THE END OF FILE 21; +C 0 IF ASSAY COEFFS. ARE NOT AT END OF THE FILE. + +C IF ICOFF=0, WRITE ALL OF FILE 21 TO FILE 27; +C IF ICOFF=1, WRITE ALL OF FILE 21, EXCEPT FOR ASSAY COEFFICIENT INFO, +C TO FILE 27. + + OPEN(27) + REWIND(21) + + 10 READ(21,3,IOSTAT=IEND) READLINE + IF(IEND .LT. 0 .OR. READLINE(1:5) .EQ. 'ASSAY' ) GO TO 25 + WRITE(27,3) READLINE + + GO TO 10 + + 25 READLINE = 'ASSAY COEFFICIENTS FOLLOW, ONE SET FOR EACH OUTPUT E + 1QUATION:' + WRITE(27,3) READLINE + +C NOW PUT IN THE APPROPRIATE C'S, DEPENDING ON THE VALUE OF ICOFF. + + +C********** PUT C'S IN FILE CURRENTLY HAVING NO C'S (BELOW) ************ + + IF(ICOFF .EQ. 0) THEN + + DO IEQ = 1,NUMEQT + + WRITE(27,16) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + + END DO + + 16 FORMAT(4(F16.8,2X)) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICOFF .EQ. 0) CONDITION. + +C********** PUT C'S IN FILE CURRENTLY HAVING NO C'S (ABOVE) ************ + + + +C********** PUT C'S IN FILE CURRENTLY HAVING C'S (BELOW) *************** + + IF(ICOFF .EQ. 1) THEN + + + DO IEQ = 1,NUMEQT + +C THIS FILE HAS C'S ON THE NEXT LINE. + + READ(21,*) C0,C1,C2,C3 + + + IF(IASS(IEQ) .EQ. 1) WRITE(27,16) C0,C1,C2,C3 + IF(IASS(IEQ) .EQ. 0) WRITE(27,16) C0P(IEQ),C1P(IEQ),C2P(IEQ), + 1 C3P(IEQ) + + END DO + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICOFF .EQ. 1) CONDITION. + +C********** PUT C'S IN FILE CURRENTLY HAVING C'S (ABOVE) *************** + +C NOW COPY FILE 27 BACK INTO FILE 21. + + CLOSE(21) + OPEN(21,FILE=PATHFILE) + REWIND(27) + + 60 READ(27,3,IOSTAT=IEND) READLINE + + IF(IEND .LT. 0) THEN + CLOSE(27) + CLOSE(21) + RETURN + ENDIF + + WRITE(21,3) READLINE + GO TO 60 + + + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE FILRED(NOBSER,NDD,NNDRUG,RSS,SIGG,YO,C0,C1,C2,C3, + 1 MAXOBDIM) + +C FILRED IS CALLED BY SUBROUTINE PREVRUN TO READ THE PORTION OF +C SCRATCH FILE 37 WHICH APPLIES TO THE SUBJECT UNDER CONSIDERATION. THE + +C 'POINTER' FOR FILE 37 IS IN THE PROPER POSITION TO BEGIN READING THE +C INFO FOR THE DESIRED SUBJECT. + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + + + DIMENSION SIG(5000),RS(5000,34),YO(MAXOBDIM,MAXNUMEQ), + 1 BS(5000,7),C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ), + 2 C3(MAXNUMEQ),YOO(594,MAXNUMEQ),TIM(594),RSS(5000,34),SIGG(5000) + + +C THE MAJOR CHANGE AS OF NPBIG11.FOR (WHICH ALLOWS MULTIPLE DRUGS) +C OCCURS IN THE DOSAGE REGIMEN BLOCK WHICH WILL NOW HAVE THE FOLLOWING +C COLUMNS, IN ORDER: + +C COL 1 = TIME +C COL 2 = IV FOR DRUG 1; COL 3 = PO FOR DRUG 1; +C COL 4 = IV FOR DRUG 2; COL 5 = PO FOR DRUG 2; +C ... EACH SUCCEEDING DRUG HAS AN IV FOLLOWED BY A PO COLUMN. +C NEXT NADD COLUMNS = ONE FOR EACH ADDITIONAL COVARIATE. + + CHARACTER SEX*1,READLINE*1000,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + + + COMMON/OBSER/ TIM,SIG,RS,YOO,BS + COMMON /CNST/ N,ND,NI,NUP,NUIC,NP + COMMON /CNST2/ NPL,NUMEQT,NDRUG,NADD + COMMON /SUM2/ M,NPNL + COMMON/DESCR/AGE,HEIGHT,ISEX,IETHFLG + + +C INPUT IS: SCRATCH FILE 37, WHICH IS POSITIONED AT THE BEGINNING OF +C THE INFO FOR THE SUBJECT DESIRED. + +C OUTPUT ARE: + +C NOBSER = THE NO. OF OBSERVATIONS FOR THIS SUBJECT. +C YO(I,J),I=1,M; J=1,NUMEQT = NO. OF OUTPUT EQS; I=1,M, WHERE M = NO. +C OF OBSERVATION TIMES. +C [C0(J),C1(J),C2(J),C3(J)] = ASSAY NOISE COEFFICIENTS FOR OUTPUT EQ. +C J; J=1,NUMEQT. + + +C AGE, SEX, HEIGHT, AND ETHNICITY FLAG ARE ON LINES 8-11. + + DO I=1,7 + READ(37,*) + END DO + + READ(37,*) AGE + READ(37,2) SEX + 2 FORMAT(A1) + ISEX=1 + IF(SEX .EQ. 'F') ISEX=2 + + READ(37,*) HEIGHT + READ(37,*) IETHFLG + + +C READ THE NO. OF DRUGS FROM THE LINE WITH 'NO. OF DRUGS' AS ENTRIES +C 12:23. THEN READ NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE +C EVENTS, ETC. + + 1 FORMAT(A1000) + 10 READ(37,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 + BACKSPACE(37) + + 3 FORMAT(T2,I5) + READ(37,3) NDRUG + + + IF(NDRUG .GT. 7) THEN + + + + WRITE(*,124) + 124 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 7'/ + 1' DRUGS. THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,124) + CLOSE(47) + + + + CALL PAUSE + + + STOP + + + + + ENDIF + + + READ(37,3) NADD + +C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND + +C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE +C BEYOND THE FIRST 4 ABOVE, AGE, SEX, HEIGHT, AND ETHNICITY FLAG). + + NI = 2*NDRUG + NADD + + IF(NI .GT. 34) THEN + + + + WRITE(*,123) + 123 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY COLUMNS IN '/ + 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ + 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ + 3' NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,123) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + READ(37,3) ND + + IF(ND .GT. 5000) THEN + + + + WRITE(*,125) + 125 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 5000'/ + 1' DOSE EVENTS. THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,125) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + +C ND*NDRUG IS THE TOTAL NO. OF IV RATES OVER WHICH THE PROGRAM WILL +C DO ITS MINIMIZATION. THESE VALUES ARE RETURNED TO MAIN IN THE +C ARGUMENT LIST. + + READ(37,*) + READ(37,*) + + + IF(ND.EQ.0) GO TO 40 + + DO I = 1,ND + READ(37,*) SIG(I),(RS(I,J),J=1,NI) + END DO + + +C ESTABLISH RSS = RS; ONE IS A DUMMY ARGUMENT; THE OTHER IS USED IN +C A COMMON. SIMILARLY SET NDD = ND, AND NNDRUG = NDRUG. AND ALSO +C SET SIGG(.) = SIG(.) + + + + NNDRUG = NDRUG + NDD = ND + DO I=1,ND + SIGG(I) = SIG(I) + + DO J=1,NI + RSS(I,J) = RS(I,J) + END DO + END DO + + + +C ASSIGN THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + +C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' +C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC. + + 40 READ(37,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 + BACKSPACE(37) + + READ(37,3) NUMEQT + READ(37,3) M + + IF(M .GT. MAXOBDIM) THEN + + + + WRITE(*,126) MAXOBDIM + 126 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ + 1' MANY OBSERVED VALUE TIMES. THIS NO. CANNOT EXCEED ',I5,'.'/ + 2' THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,126) MAXOBDIM + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + + IF(NUMEQT .GT. MAXNUMEQ) THEN + + WRITE(*,127) MAXNUMEQ + 127 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ + 1' MANY OUTPUT EQUATION COLUMNS. THIS NO. CANNOT EXCEED ',I2,'.'/ + 2' THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,127) MAXNUMEQ + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + DO I=1,M + READ(37,*) TIM(I),(YO(I,J),J=1,NUMEQT) + END DO + +C PUT YO VALUES INTO YOO BECAUSE A DUMMY ARGUMENT CANNOT BE IN A +C COMMON STATEMENT. + + DO I=1,M + DO J=1,NUMEQT + YOO(I,J) = YO(I,J) + END DO + END DO + + + NOBSER = M + + +C AT THIS POINT, MUST SKIP THE COVARIATE INFO IN THE FILE, AND PROCEED +C TO READ THE ASSAY NOISE COEFFICIENTS BELOW THAT. + + +C READ THE NUMEQT SETS OF ASSAY COEFFICIENTS JUST BELOW THE LINE +C WHICH HAS "ASSAY COEFFICIENTS FOLLOW" IN ENTRIES 1:25. + + + 50 READ(37,1) READLINE + IF(READLINE(1:25) .NE. 'ASSAY COEFFICIENTS FOLLOW') GO TO 50 + + DO IEQ = 1,NUMEQT + + READ(37,*) C0(IEQ),C1(IEQ),C2(IEQ),C3(IEQ) + END DO + + RETURN + END + + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE STACK(PATH,MAXOBDIM,PATFIL,AF) + +C THIS ROUTINE, CALLED BY MAIN, READS THE INFO IN FILE PATFIL, AND +C APPENDS IT ONTO THE END OF FILE 27. + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + + + + DIMENSION SIG(5000),RS(5000,34),AF(7) + CHARACTER PATFIL*20,READLINE*1000,PATH*60,TMPFILE*13, + 1 PATHFILE*73,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + +C SEE SUBROUTINE FILRED FOR SOME DETAILS ON THE MAJOR CHANGES AS +C OF NPBIG11.FOR. + +C INPUT IS: + + +C PATH = LOCATION (DIRECTORY) OF PATIENT DATA FILES. +C PATFIL = PATIENT DATA FILE. + + +C AF = ACTIVE FRACTION OF THE DRUG. EACH IV RATE AND BOLUS VALUE +C MUST BE MULTIPLIED BY AF. + + +C OUTPUT IS: + +C FILE 27 WHICH NOW HAS PATFIL APPENDED ONTO ITS END. +C COPY LINE-BY-LINE PATFIL TO FILE 27 EXCEPT FOR THE DOSAGE REGIMEN + +C (BECAUSE EACH IV RATE AND BOLUS INPUT MUST BE MULTIPLIED BY AF BEFORE +C BEING WRITTEN TO FILE 27). + + 1 FORMAT(A1000) + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = PATFIL + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE) + 10 READ(21,1,IOSTAT=IEND) READLINE + + +C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED. + + IF(IEND .LT. 0) THEN + + WRITE(*,128) PATFIL + 128 FORMAT(/' PATIENT DATA FILE ',A20,' HAS AN OLD-STYLE WORKING'/ + 1' COPY FORMAT.'// + 2' TO BE ACCEPTABLE TO THIS PROGRAM, A PATIENT DATA FILE MUST'/ + 3' HAVE BEEN MADE BY A RECENT BOXES PROGRAM. THE FILE MUST HAVE'/ + 4' "NO OF DRUGS" IN ENTRIES 12 THROUGH 23 ON OR NEAR LINE 18.'// + 5' THE PROGRAM STOPS. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,128) PATFIL + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + WRITE(27,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 + +C READLINE NOW CONTAINS THE NO. OF DRUGS, NDRUG. BACKSPACE AND READ +C NDRUG; THEN READ THE NO. OF ADDITIONAL COVARIATES, AND THE NO. OF +C DOSE EVENTS. + + + BACKSPACE(21) + 3 FORMAT(T2,I5) + + READ(21,3) NDRUG + + IF(NDRUG .GT. 7) THEN + + WRITE(*,124) PATFIL + 124 FORMAT(' PATIENT DATA FILE ',A20,' HAS TOO MANY DRUGS'/ + 1' (I.E, MORE THAN 7). THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,124) PATFIL + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + READ(21,3) NADD + + +C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND +C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE). + + NI = 2*NDRUG + NADD + + IF(NI .GT. 34) THEN + + + + WRITE(*,123) PATFIL + 123 FORMAT(/' PATIENT DATA FILE ',A20,' HAS TOO MANY COLUMNS IN '/ + 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ + 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ + 3' NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,123) PATFIL + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + READ(21,3) ND + + IF(ND .GT. 5000) THEN + + + + WRITE(*,125) PATFIL + + 125 FORMAT(' PATIENT DATA FILE ',A20,' HAS TOO MANY DOSE EVENTS'/ + 1' (I.E., MORE THAN 5000). THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,125) PATFIL + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + +C BACKSPACE TWICE AND PUT THE LAST TWO LINES, AND THE NEXT TWO LINES +C ONTO FILE 27 (THE NEXT LINE AFTER THAT STARTS THE DOSAGE REGIMEN). + + BACKSPACE(21) + BACKSPACE(21) + + DO I=1,4 + + READ(21,1) READLINE + WRITE(27,1) READLINE + END DO + + IF(ND.EQ.0) GO TO 40 + +C THE FIRST NDRUG*2 COLUMNS OF R HAVE THE IV AND BOLUS VALUES FOR +C THE NDRUG DRUGS IN THE FILE. THESE VALUES MUST BE MULTIPLIED BY +C AF(I), WHERE I IS THE DRUG NO. + + DO I = 1,ND + + READ(21,*) SIG(I),(RS(I,J),J=1,NI) + + DO J = 1,2*NDRUG + +C THE DRUG NO., IDRUG, IS THE INTEGER VALUE OF (J+1)/2. EX: (J+1)/2 +C WILL BE 1 IF J = 1 OR 2 SINCE INTEGER ARITHMETIC TRUNCATES. + + IDRUG = (J+1)/2 + RS(I,J) = RS(I,J)*AF(IDRUG) + + + END DO + + WRITE(27,*) SIG(I),(RS(I,J),J=1,NI) + + END DO + +C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' +C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC. CHECK +C THAT THESE ENTRIES ARE NOT TOO BIG. IF NOT, WRITE THE REST OF THE +C FILE 21 TO FILE 27. + + + 40 READ(21,1) READLINE + WRITE(27,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 + + BACKSPACE(21) + + READ(21,3) NUMEQT + READ(21,3) M + + IF(M .GT. MAXOBDIM) THEN + + + + WRITE(*,126) PATFIL,M,MAXOBDIM,MAXOBDIM + 126 FORMAT(/' PATIENT ',A20,' HAS ',I3,' OBSERVATION TIMES. THIS '/ + 1' IS MORE THAN THE ALLOWABLE MAXIMUM OF ',I3,'. PLEASE RERUN THE'/ + 2' PROGRAM AFTER ENSURING THAT ALL YOUR PATIENTS HAVE NO MORE '/ + 3' THAN ',I3,' OBSERVATION TIMES. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,126) PATFIL,M,MAXOBDIM,MAXOBDIM + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + + IF(NUMEQT .GT. MAXNUMEQ) THEN + + WRITE(*,127) PATFIL,NUMEQT,MAXNUMEQ,MAXNUMEQ + 127 FORMAT(/' PATIENT ',A20,' HAS ',I3,' OUTPUT EQUATION COLUMNS,'/ + 1' WHICH IS MORE THAN THE MAXIMUM ALLOWABLE NO. OF ',I2,'.'/ + 2' PLEASE RERUN THE PROGRAM AFTER ENSURING THAT ALL YOUR PATIENTS'/ + 3' HAVE NO MORE THAN ',I2,' OUTPUT EQUATION COLUMNS. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,127) PATFIL,NUMEQT,MAXNUMEQ,MAXNUMEQ + CLOSE(47) + + + + CALL PAUSE + + + STOP + + + + ENDIF + +C BACKSPACE JUST ONCE TO THE LINE WITH M ON IT, SINCE THE LINE WITH +C NUMEQT ON IT WAS ALREADY PUT INTO FILE 27. THEN COPY LINE FOR LINE +C THE REST OF THE FILE TO FILE 27. NOTE THAT IEND .LT. 0 --> END OF +C FILE REACHED. + + BACKSPACE(21) + + 20 READ(21,1,IOSTAT=IEND) READLINE + IF(IEND .LT. 0) GO TO 100 + WRITE(27,1) READLINE + GO TO 20 + 100 CLOSE(21) + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE ELDERY(N,START,XMIN,YNEWLO,REQMIN,STEP, + X ITMAX,FUNC,IPRINT,ICONV,NITER,ICOUNT,IPRINTOUT) + + + +C ELDERX DIFFERS FROM ELDER (DESCRIBED BELOW) ONLY IN THAT N, THE +C DIMENSION OF START (THE NO. OF UNKNOWN PARAMETERS OVER WHICH THE +C MINIMIZATION IS DONE) IS PASSED TO THE SUBROUTINE FUNC IN THE CALLING +C STATEMENTS. + + +C ELDER IS A PROGRAM TO MINIMIZE A FUNCTION USING THE NELDER-MEED +C ALGORITM. +C THE CODE WAS ADAPTED FROM A PROG. IN J. OF QUALITY TECHNOLOGY VOL. +C JAN. 1974. BY D.M. OLSSON. +C CALLING ARGUMENTS: +C N -NUMBER OF UNKNOWN PARAMS. UP TO 99. +C START -A VECTOR WITH THE INITIAL QUESSES OF THE SOLUTION PARAMS. +C ITMAX -THE MAXIMUM NUMBER OF ITERATIONS. +C (KCOUNT IS THE MAX NUM OF FUNC CALLS.SET AT 1000000) +C STEP -THE STEP SIZE VECTOR FOR DEFINING THE N ADDITIONAL +C VERTICIES. +C REQMIN-THE STOP TOLERANCE. + +C XMIN -THE SOLUTION VECTOR. +C YNEWLO-THE FUCTION VALUE AT XMIN. + + +C IPRINT-SWITCH WHICH DETERMINES IF INTERMEDIATE ITERATIONS +C ARE TO BE PRINTED. (0=NO,1=YES). +C ICONV -FLAG INDICATING WHETHER OR NOT CONVERGENCE HAS BEEN +C ACHEIVED. (0=NO,1=YES). +C NITER -THE NUMBER OF ITERATIONS PERFORMED. +C ICOUNT-THE NUMBER OF FUNCTION EVALUATIONS. +C FUNC -THE NAME OF THE SUBROUTINE DEFINING THE FUNCTION. + +C THIS SUBROUTINE MUST EVALUATE THE FUNCTION GIVEN A +C VALUE FOR THE PARAMETER VECTOR. THE ROUTINE IS OF +C THE FOLLOWING FORM: +C FUNC(P,FV), WHERE P IS THE PARAMETER VECTOR, +C AND FV IS THE FUNCTION VALUE. + +C A SUBROUTINE TO PRINT THE RESULTS OF ITERMEDIATE ITERATIONS +C MUST ALSO BE SUPPLIED. ITS NAME AND CALLING SEQUENCE ARE +C DEFINED AS FOLLOWS: +C PRNOUT(P,N,NITER,NFCALL,FV). +C OTHER PROGRAM VARIABLES OF INTEREST ARE; +C XSEC -THE COORDINATES OF THE VETEX WITH THE 2ND SMALLEST FUNCTION +C VALUE. NOTE: XSEC IS NOT USED. REMOVED IN BESTDOS7.FOR, IT +C IS REMOVED FROM THE DIMENSION STATEMENT, AND IS NOT + +C ASSIGNED VALUES ABOVE LABEL 26. + + +C YSEC - THE FUNCTION VALUE AT XSEC. + + PARAMETER(NMAX=5000) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION START(N),STEP(N),XMIN(N), + X P(NMAX,NMAX+1),PSTAR(NMAX),P2STAR(NMAX),PBAR(NMAX),Y(NMAX+1) + EXTERNAL FUNC + DATA RCOEFF/1.0D0/,ECOEFF/2.0D0/,CCOEFF/.5D0/ + KCOUNT=1000000 + ICOUNT=0 + + NITER=0 + ICONV=0 +C +C CHECK INPUT DATA AND RETURN IF AN ERROR IS FOUND. +C + + IF(REQMIN.LE.0.0D0) ICOUNT=ICOUNT-1 + IF(N.LE.0) ICOUNT=ICOUNT-10 + IF(N.GT.99) ICOUNT=ICOUNT-10 + IF(ICOUNT.LT.0) RETURN +C +C SET INITIAL CONSTANTS +C + DABIT=2.04607D-35 + BIGNUM=1.0D+38 + KONVGE=5 +C XN=FLOAT(N) + DN=FLOAT(N) + + NN=N+1 + + +C +C CONSTRUCTION OF INITIAL SIMPLEX. +C +1001 DO 1 I=1,N +1 P(I,NN)=START(I) + + CALL FUNC(N,START,FN) + Y(NN)=FN + ICOUNT=ICOUNT+1 +C CALL PRNOUT(START,N,NITER,ICOUNT,FN) + IF(ITMAX.NE.0) GO TO 40 + DO 45 I=1,N +45 XMIN(I)=START(I) + YNEWLO=FN + RETURN +40 DO 2 J=1,N + DCHK=START(J) + START(J)=DCHK+STEP(J) + DO 3 I=1,N +3 P(I,J)=START(I) + CALL FUNC(N,START,FN) + Y(J)=FN + ICOUNT=ICOUNT+1 +2 START(J)=DCHK +C +C SIMPLEX CONSTRUCTION COMPLETE. +C +C FIND THE HIGHEST AND LOWEST VALUES. YNEWLO (Y(IHI)) INDICATES THE +C VERTEX OF THE SIMPLEX TO BE REPLACED. +C +1000 YLO=Y(1) + YNEWLO=YLO + ILO=1 + IHI=1 + + + DO 5 I=2,NN + IF(Y(I).GE.YLO) GO TO 4 + YLO=Y(I) + ILO=I +4 IF(Y(I).LE.YNEWLO) GO TO 5 + + YNEWLO=Y(I) + IHI=I +5 CONTINUE +C + + IF(ICOUNT.LE.NN) YOLDLO=YLO + + IF(ICOUNT.LE.NN) GO TO 2002 + IF(YLO.GE.YOLDLO) GO TO 2002 + YOLDLO=YLO + NITER=NITER+1 + IF(NITER.GE.ITMAX) GO TO 900 + IF(IPRINT.EQ.0) GO TO 2002 +C CALL PRNOUT(P(1,ILO),N,NITER,ICOUNT,YLO) +C +C PERFORM CONVERGENCE CHECKS ON FUNCTIONS. +C +2002 DCHK=(YNEWLO+DABIT)/(YLO+DABIT)-1.0D0 + +C PRINT OUT NITER (ITERATION NO.) AND ITMAX (MAX. NO. OF ITERATIONS) + +C STARTING WITH THE BESTDOS4.FOR PROGRAM, BECAUSE THIS PROGRAM SOLVES +C D.E.'S WHICH MEANS IT CAN TAKE A LONG TIME, AND NITER AND ITMAX +C GIVE AT LEAST SOME INDICATION OF HOW LONG THE PROGRAM HAS GONE AND + +C HOW LONG IT COULD GO. SIMILARLY, PRINT OUT DABS(DCHK) AN REQMIN, + +C THE MEASURE OF HOW CLOSE TO CONVERGENCE THE PROGRAM IS AND THE +C REQUIRED TOLERANCE FOR CONVERGENCE. + + +C THE FOLLOWING CONVERGENCE INFO IS ONLY WRITTEN IF IPRINTOUT = 1. + + + IF(IPRINTOUT .EQ. 1) WRITE(*,1234) NITER,ITMAX,DABS(DCHK),REQMIN + 1234 FORMAT('+ ',' ITER ',I5,' (MAX = ',I5,') TOL = ',G10.4,' (CONV. + 1 TOL = ',G10.4,')') + + IF(DABS(DCHK).GT. REQMIN) GO TO 2001 + + ICONV=1 + GO TO 900 +C +2001 KONVGE=KONVGE-1 + IF(KONVGE.NE.0) GO TO 2020 + KONVGE=5 + +C +C CHECK CONVERGENCE OF COORDINATES ONLY EVERY 5 SIMPLEXES. +C + DO 2015 I=1,N + + COORD1=P(I,1) + COORD2=COORD1 + DO 2010 J=2,NN + IF(P(I,J).GE.COORD1) GO TO 2005 + COORD1=P(I,J) +2005 IF(P(I,J).LE.COORD2) GO TO 2010 + COORD2=P(I,J) +2010 CONTINUE + DCHK=(COORD2+DABIT)/(COORD1+DABIT)-1.0D0 + IF(DABS(DCHK).GT.REQMIN) GO TO 2020 +2015 CONTINUE + ICONV=1 + GO TO 900 +2020 IF(ICOUNT.GE.KCOUNT) GO TO 900 +C +C CALCULATE PBAR, THE CENTRIOD OF THE SIMPLEX VERTICES EXCEPTING THAT +C WITH Y VALUE YNEWLO. +C + DO 7 I=1,N + Z=0.0D0 + DO 6 J=1,NN +6 Z=Z+P(I,J) + Z=Z-P(I,IHI) +7 PBAR(I)=Z/DN +C +C REFLECTION THROUGH THE CENTROID. +C + DO 8 I=1,N + +8 PSTAR(I)=(1.0D0+RCOEFF)*PBAR(I)-RCOEFF*P(I,IHI) + CALL FUNC(N,PSTAR,FN) + YSTAR=FN + ICOUNT=ICOUNT+1 + IF(YSTAR.GE.YLO) GO TO 12 + IF(ICOUNT.GE.KCOUNT) GO TO 19 +C +C SUCESSFUL REFLECTION SO EXTENSION. + +C + DO 9 I=1,N + +9 P2STAR(I)=ECOEFF*PSTAR(I)+(1.0D0-ECOEFF)*PBAR(I) + CALL FUNC(N,P2STAR,FN) + Y2STAR=FN + + ICOUNT=ICOUNT+1 +C + +C RETAIN EXTENSION OR CONTRACTION. + +C + IF(Y2STAR.GE.YSTAR) GO TO 19 +10 DO 11 I=1,N +11 P(I,IHI)=P2STAR(I) + + Y(IHI)=Y2STAR + GO TO 1000 +C +C NO EXTENSION. +C +12 L=0 + DO 13 I=1,NN + IF(Y(I).GT.YSTAR) L=L+1 +13 CONTINUE + IF(L.GT.1) GO TO 19 + IF(L.EQ.0) GO TO 15 +C + +C CONTRACTION ON REFLECTION SIDE OF CENTROID. +C + DO 14 I=1,N +14 P(I,IHI)=PSTAR(I) + Y(IHI)=YSTAR +C +C CONTRACTION ON THE Y(IHI) SIDE OF THE CENTROID. +C +15 IF(ICOUNT.GE.KCOUNT) GO TO 900 + DO 16 I=1,N +16 P2STAR(I)=CCOEFF*P(I,IHI)+(1.0D0-CCOEFF)*PBAR(I) + CALL FUNC(N,P2STAR,FN) + Y2STAR=FN + ICOUNT=ICOUNT+1 + + IF(Y2STAR.LT.Y(IHI)) GO TO 10 +C +C CONTRACT THE WHOLE SIMPLEX +C + DO 18 J=1,NN + DO 17 I=1,N + P(I,J)=(P(I,J)+P(I,ILO))*0.5D0 +17 XMIN(I)=P(I,J) + CALL FUNC(N,XMIN,FN) + Y(J)=FN + +18 CONTINUE + ICOUNT=ICOUNT+NN + IF(ICOUNT.LT.KCOUNT) GO TO 1000 + GO TO 900 +C +C RETAIN REFLECTION. +C +19 CONTINUE + DO 20 I=1,N +20 P(I,IHI)=PSTAR(I) + Y(IHI)=YSTAR + GO TO 1000 +C +C SELECT THE TWO BEST FUNCTION VALUES (YNEWLO AND YSEC) AND THEIR +C COORDINATES (XMIN AND XSEC)>. XSEC NOT SET AS OF BESTDOS7.FOR. +C +900 DO 23 J=1,NN + DO 22 I=1,N +22 XMIN(I)=P(I,J) + CALL FUNC(N,XMIN,FN) + Y(J)=FN +23 CONTINUE + ICOUNT=ICOUNT+NN + YNEWLO=BIGNUM + DO 24 J=1,NN + IF(Y(J).GE.YNEWLO) GO TO 24 + YNEWLO=Y(J) + IBEST=J +24 CONTINUE + + Y(IBEST)=BIGNUM + YSEC=BIGNUM + DO 25 J=1,NN + IF(Y(J).GE.YSEC) GO TO 25 + YSEC=Y(J) +C ISEC=J ... ISEC NOT USED. REMOVED IN BESTDOS7.FOR. +25 CONTINUE + DO 26 I=1,N + XMIN(I)=P(I,IBEST) +26 CONTINUE + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX, + 1 PARFIX,IRAN,INOPT) + +C THIS SUBROUTINE, CALLED BY MAIN, READS THE FORTRAN FILE, FORFILE, +C OPENED IN MAIN (FILE 28), WHICH WAS CREATED BY A 'BOXES'- TYPE +C PROGRAM, AND RETURNS THE VALUES IN THE ABOVE ARGUMENT LIST. + +C ??? +C NOTE: WHEN THIS PROGRAM STARTS READING THE NEW BOXES PROGRAM, MAKE +C SURE THAT THE MICHAELIS-MENTIN EQUATION IS CORRECT - IT SHOULD +C BE (SEE PAGE *1 OF M2_7/m2_7calc.f NOTES OR NOTES FROM PG. 5. +C OF PHARMACOKINETICS AND PHARMACODYNAMICS, VOL 2). + +C dX/dT = (VM x X) / (KM x V1 + X), WHERE VM = V1 * Vmax, AND +C THE UNITS ARE: X --> grams; T --> hours; VM --> grams/hour; + +C V1 --> liters; KM --> grams/liter; +C Vmax --> grams/(liter * hour) + +C NOTE: THE ABOVE EQUATION IS EXACTLY THE SAME AS +C dC/dT = (Vmax * C)/(KM + C), WHERE C = X/V1, WHICH IS +C EQUATION 3 ON PG. 5 OF PHARMACOKINETICS AND PHARMACODYNAMICS, +C VOL 2, WHERE: +C Vmax = dC/dT AS C--> infinity; +C KM = C WHEN dC/dT = Vmax/2. + + +C ABOVE COMMENTS WERE IMPROVED 7/27/99 AFTER +C CONVERSATION WITH ROGER AND DARRYL CLARDY. +C ??? + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION IRAN(32) + + CHARACTER PAR(30)*11,PARFIX(20)*11,READLINE*1000, + 1 PSYM(32)*11,RR*1,TEMP*11,C*1,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C FILE 28 WAS OPENED (IN MAIN) AT THE END OF THE FILE. BACKSPACE AND +C THEN READ IN NDIM, NP AND PSYM(I),I=1,NP. + + 2 FORMAT(A1000) + + 30 BACKSPACE(28) + + BACKSPACE(28) + READ(28,2) READLINE + IF(READLINE(8:9) .NE. 'N=') GO TO 30 + BACKSPACE(28) + READ(28,3) NDIM + 3 FORMAT(T10,I3) + + 40 READ(28,2) READLINE + IF(READLINE(8:9) .NE. 'NP') GO TO 40 + BACKSPACE(28) + READ(28,4) NP + 4 FORMAT(T11,I3) + + 50 READ(28,2) READLINE + + IF(READLINE(8:11) .NE. 'PSYM') GO TO 50 + BACKSPACE(28) + + DO 70 I=1,NP + + IF(I .LE. 9) READ(28,14) TEMP + IF(I .GE. 10 .AND. I .LE. 99) READ(28,6) TEMP + +C WRITE TEMP INTO PSYM, STRIPPING OFF THE ENDING QUOTE MARK, IF ONE +C IS THERE. + + C = '''' + + PSYM(I) = TEMP + + DO J=1,11 + + IF(TEMP(J:J) .EQ. C) THEN + PSYM(I) = TEMP(1:J-1) + GO TO 70 + ENDIF + + END DO + + + + 70 CONTINUE + + 14 FORMAT(T17,A11) + 6 FORMAT(T18,A11) + + +C IF INOPT .EQ. 3 (MEANING THE PROGRAM HAS ALREADY OPENED THE +C FILE, 'GUICMDS.INX'), THE NEXT LINE IN THE INSTRUCTION FILE HAS +C THE VALUES FOR IRAN(I),I=1,NP. READ THIS LINE, CALCULATE NVAR AND +C NOFIX AND ... THAT'S IT. THERE IS NO USER INTERACTION IF +C INOPT .EQ. 3. + + IF(INOPT .EQ. 3) THEN + + READ(23,*) +C SKIP THIS LINE. IT CONTAINS 'IRAN INDICES'. + + + READ(23,*) (IRAN(I),I=1,NP) + + NVAR = 0 + NOFIX = 0 + + DO I = 1,NP + + + IF(IRAN(I) .EQ. 1) THEN + NVAR = NVAR+1 + PAR(NVAR) = PSYM(I) + ENDIF + + IF(IRAN(I) .EQ. 0) THEN + NOFIX = NOFIX + 1 + PARFIX(NOFIX) = PSYM(I) + ENDIF + + END DO + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 3) CONDITION. + + +C IF INOPT .EQ. 1 (MEANING THE PROGRAM HAS ALREADY OPENED AN +C INSTRUCTION FILE) THE NEXT LINE IN THE INSTRUCTION FILE HAS THE +C VALUES FOR IRAN(I),I=1,NP. READ THIS LINE AND PRESENT THE INFO TO +C THE USER. + + IF(INOPT .EQ. 1) THEN + + READ(23,*) +C SKIP THIS LINE. IT CONTAINS 'IRAN INDICES'. + + READ(23,*) (IRAN(I),I=1,NP) + WRITE(*,201) + 201 FORMAT(/' YOU HAVE SELECTED YOUR PARAMETERS TO BE RANDOM'/ + 1' OR FIXED AS INDICATED BELOW. IF YOU WANT TO CHANGE THIS, YOU'/ + 2' WILL HAVE TO RERUN THIS PROGRAM WITHOUT AN INSTRUCTION FILE'/ + 3' SINCE THE REST OF THIS INSTRUCTION FILE (BOUNDARIES AND/OR'/ + 4' FIXED VALUES WILL NOT BE COMPATIBLE WITH YOUR CHANGED '/ + 5' DESIGNATIONS.'/) + + CALL PAUSE + + + + NVAR = 0 + NOFIX = 0 + + + DO I = 1,NP + + + IF(IRAN(I) .EQ. 1) THEN + TEMP = 'RANDOM' + NVAR = NVAR+1 + PAR(NVAR) = PSYM(I) + ENDIF + + IF(IRAN(I) .EQ. 0) THEN + TEMP = 'FIXED' + + NOFIX = NOFIX + 1 + PARFIX(NOFIX) = PSYM(I) + ENDIF + + WRITE(*,202) PSYM(I),TEMP + 202 FORMAT(2X,A11,2X,A11) + + END DO + + 210 WRITE(*,203) + 203 FORMAT(/' ENTER 1 IF THE ABOVE DESIGNATIONS ARE CORRECT;'/ + 1' ENTER 0 OTHERWISE: ') + + + READ(*,*,ERR=210) ICORRECT + IF(ICORRECT .NE. 1 .AND. ICORRECT .NE. 0) GO TO 210 + + + IF(ICORRECT .EQ. 0) THEN + + + + WRITE(*,204) + 204 FORMAT(//' PLEASE RERUN THE PROGRAM WITH KEYBOARD ENTRY.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,204) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + +C IF NVAR .GT. MAXDIM, PRINT MESSAGE TO USER AND HAVE HIM TRY AGAIN. +C SIMILARLY IF NOFIX .GT. 20, OR IF NVAR + NOFIX .GT. 32. + + IF(NVAR .GT. MAXDIM) THEN + + + + WRITE(*,207) NVAR,MAXDIM + 207 FORMAT(//' SOMEHOW, YOUR INSTRUCTION FILE HAS ',I2,/ + 1' PARAMETERS DESIGNATED TO BE RANDOM VARIABLES. THE LIMIT IS '/ + 2' CURRENTLY ',I2,'. PLEASE USE A CURRENT INSTRUCTION FILE OR'/ + 3' RERUN THE PROGRAM WITH KEYBOARD ENTRY.'//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,207) NVAR,MAXDIM + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + IF(NOFIX .GT. 20) THEN + + + + WRITE(*,208) NOFIX + 208 FORMAT(//' SOMEHOW, YOUR INSTRUCTION FILE HAS ',I2,/ + 1' PARAMETERS DESIGNATED TO BE FIXED. THE LIMIT IS CURRENTLY 20.'/ + 2' PLEASE USE A CURRENT INSTRUCTION FILE OR RERUN THE PROGRAM'/ + 3' WITH KEYBOARD ENTRY.'//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,208) NOFIX + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + IF(NVAR + NOFIX .GT. 32) THEN + + WRITE(*,209) NVAR + NOFIX + 209 FORMAT(//' SOMEHOW, YOUR INSTRUCTION FILE HAS ',I2,' TOTAL'/ + 1' PARAMETERS. THE LIMIT IS CURRENTLY 32. PLEASE USE A CURRENT '/ + 2' INSTRUCTION FILE OR RERUN THE PROGRAM WITH KEYBOARD ENTRY.'//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,209) NVAR + NOFIX + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 1) CONDITION. + + + + +C THE CODE BELOW IS FOR THE INOPT .EQ. 0 CASE. + + IF(INOPT .EQ. 0) THEN + + +C NOW QUIZ THE USER TO SEE WHICH PARAMETERS ARE FIXED, AND WHICH ARE +C RANDOM. + +C SET IRAN(I) = 1 IF PSYM(I) = RANDOM; +C 0 IF PSYM(I) = FIXED. + + 80 WRITE(*,7) NP + 7 FORMAT(/' FOR EACH OF THE ',I2,' PARAMETERS, '// + 1' ENTER "R" IF IT IS TO BE A RANDOM VARIABLE;'/ + 2' ENTER "F" IF IT IS TO BE A FIXED PARAMETER.'//) + + NVAR = 0 + NOFIX = 0 + + + DO I=1,NP + + + 8 FORMAT(1X,A11,': ') + 60 WRITE(*,8) PSYM(I) + READ(*,9) RR + + 9 FORMAT(A1) + IF(RR .NE. 'R' .AND. RR .NE. 'r' .AND. RR .NE. 'F' + 1 .AND. RR .NE. 'f') GO TO 60 + + IF(RR .EQ. 'R' .OR. RR .EQ. 'r') THEN + NVAR = NVAR+1 + + +C NOTE THAT THIS PROGRAM RESETS NP TO A VERY LARGE VALUE +C IF NVAR > THE DIMENSION LIMIT OF PAR. THIS IS BIZARRE. IT DOESN'T + +C HAPPEN IF NOFIX > THE DIMENSION LIMIT OF PARFIX, AND IT DOESN'T +C HAPPEN IN MONTBIG8.FOR WHICH HAS THE SAME CODE AS HERE. +C BUT SINCE IT HAPPENS HERE, CHECK TO SEE IF NVAR > MAXDIM, AND IF +C SO TRANSFER CONTROL TO LABEL 110 WITHOUT SETTING PAR(MAXDIM+1) TO +C PSYM(I). + + IF(NVAR .GT. MAXDIM) GO TO 110 + PAR(NVAR) = PSYM(I) + + IRAN(I) = 1 + ENDIF + + IF(RR .EQ. 'F' .OR. RR .EQ. 'f') THEN + NOFIX = NOFIX+1 + PARFIX(NOFIX) = PSYM(I) + IRAN(I) = 0 + ENDIF + + + END DO + +C IF NVAR .GT. MAXDIM, PRINT MESSAGE TO USER AND HAVE HIM TRY AGAIN. +C SIMILARLY IF NOFIX .GT. 20, OR IF NVAR + NOFIX .GT. 32. + + 110 IF(NVAR .GT. MAXDIM) THEN + WRITE(*,111) NVAR,MAXDIM + 111 FORMAT(//' YOU HAVE SELECTED ',I2,' PARAMETERS TO BE RANDOM'/ + 1' VARIABLES. THE LIMIT IS CURRENTLY ',I2,'. PLEASE RESELECT YOUR'/ + + 2' RANDOM VARIABLES WITH THIS LIMIT IN MIND.'//) + GO TO 80 + ENDIF + + IF(NOFIX .GT. 20) THEN + WRITE(*,112) NOFIX + 112 FORMAT(//' YOU HAVE SELECTED ',I2,' PARAMETERS TO BE FIXED'/ + 1' PARAMETERS. THE LIMIT IS CURRENTLY 20. PLEASE RESELECT YOUR'/ + 2' RANDOM VARIABLES WITH THIS LIMIT IN MIND.'//) + GO TO 80 + ENDIF + + IF(NVAR + NOFIX .GT. 32) THEN + + + + WRITE(*,113) NVAR + NOFIX + 113 FORMAT(//' YOUR MODEL FILE HAS A TOTAL OF ',I2,' PARAMETERS.'/ + 1' THE LIMIT IS CURRENTLY 32. PLEASE EDIT YOUR MODEL FILE SO '/ + 2' THAT IT HAS .LE. 32 PARAMETERS. '//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,113) NVAR + NOFIX + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 0) CONDITION. + + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +C SUBROUTINE DETECT(NOB,PATH,FORFILE,IVERS) - REMOVED. + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +C SUBROUTINE CHECKLIN(READLINE,TARGET,IYES) - REMOVED. + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +C SUBROUTINE WRITEDIF(IVERS) - REMOVED. + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +C SUBROUTINE WRITEOUT(IVERS) - REMOVED. + + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +C SUBROUTINE WRITESYM(IVERS) - REMOVED. + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +C SUBROUTINE SKIPLINE(READLINE,IYES) - REMOVED. + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + + SUBROUTINE GETNUMEQ(NUMEQT,NDRUG) + + IMPLICIT REAL*8(A-H,O-Z) + CHARACTER READLINE*78,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + +C THIS SUBROUTINE READS THE PATIENT DATA FILE (FILE 21) TO FIND THE +C NO. OF OUTPUT EQUATIONS (NUMEQT), AND THE NO. OF DRUGS (NDRUG). + +C PRINT MESSAGE TO THE USER THAT IF HE CHANGES HIS WORKING COPY +C FILE IN SUBROUTINE VERIF1, HE MUST MAKE SURE THAT THE NEW WORKING +C COPY FILE HAS THE SAME NO. OF OUTPUT EQUATIONS AS THE FILE. + + WRITE(*,4) + 4 FORMAT(//' YOUR WORKING COPY FILE WILL NOW BE OPENED TO'/ + 1' READ THE NUMBER OF OUTPUT EQUATIONS, AND THE NUMBER OF DRUGS.'/ + + 2' LATER, YOU WILL HAVE THE OPTION TO CHANGE YOUR WORKING COPY'/ + 3' FILE. IF YOU DO THIS, MAKE SURE THAT THE NEW FILE HAS THE SAME'/ + + 4' NUMBER OF OUTPUT EQUATIONS AND THE SAME NUMBER OF DRUGS.'//) + + CALL PAUSE + +C NOTE THAT NUMEQT IS ON THE LINE WITH "NO. OF TOTAL OUTPUT EQUATIONS" +C IN COLUMNS 12:40. IF NO LINE HAS THESE WORDS, THIS PATIENT DATA +C FILE IS NOT A NEW-STYLE WORKING COPY FILE FROM ANDREAS' NEW +C BOXES PROGRAM. + + 3 FORMAT(A78) + 35 READ(21,3,IOSTAT=IEND) READLINE + + IF(IEND .LT. 0) THEN + + + + WRITE(*,58) + 58 FORMAT(//' YOUR WORKING COPY FILE IS NOT A CURRENT MULTIPLE'/ + 1' DRUG WORKING COPY FILE. SUCH A FILE MUST HAVE A LINE WITH '/ + 2' "NO. OF DRUGS" IN COLUMNS 12:23.'// + 3' THE PROGRAM STOPS. '//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,58) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 35 + BACKSPACE(21) + 13 FORMAT(T2,I5) + READ(21,13) NDRUG + + + 45 READ(21,3,IOSTAT=IEND) READLINE + + IF(IEND .LT. 0) THEN + + + + WRITE(*,59) + 59 FORMAT(//' YOUR WORKING COPY FILE IS NOT A CURRENT MULTIPLE'/ + 1' DRUG WORKING COPY FILE. SUCH A FILE MUST HAVE A LINE WITH '/ + 2' "NO. OF TOTAL OUTPUT EQUATIONS IN COLUMNS 12:40.'// + 3' THE PROGRAM STOPS. '//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,59) + CLOSE(47) + + + + + CALL PAUSE + STOP + + + + ENDIF + + IF(READLINE(12:40) .NE. 'NO. OF TOTAL OUTPUT EQUATIONS') + 1 GO TO 45 + BACKSPACE(21) + READ(21,13) NUMEQT + CLOSE(21) + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE PAUSE + +C THIS ROUTINE IS USED TO REPLACE A PAUSE STATEMENT, WHICH CAUSES +C WARNINGS WHEN THIS PROGRAM IS COMPILED AND LINKED USING gfortran +C (AND FORCES THE USER TO TYPE "go" INSTEAD OF SIMPLY HITTING THE +C ENTER KEY). + + WRITE(*,1) + 1 FORMAT(' HIT ANY KEY TO CONTINUE: ') + READ(*,*,ERR=10) IKEY + IF(IKEY .EQ. 1) RETURN + 10 RETURN + + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE VERIF1(FORFILE,ICSVFILE,FUTUREFILEIN,PATH,NOB,C0P, + 1 C1P,C2P,C3P,NUMEQT,NOFIX,VALFIX,PARFIX,TOLER,ATOL,IASS,AF, + 2 MATFIL,NPAGDENFILE,INCLUDPAST,IPASTFILE,PASTFILEIN, + 3 IERRMOD,GAMLAM,NDRUG,IPRIOROBS,TNEXT,IDELTA,MAXOBDIM,MAXCYC, + 4 IOPTIMIZE,BIASWEIGHT,ITARGET) + + PARAMETER(MAXDIM=25) + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION C0P(MAXNUMEQ),C1P(MAXNUMEQ),C2P(MAXNUMEQ), + 1 C3P(MAXNUMEQ),VALFIX(20),IASS(MAXNUMEQ),IRAN(32),ATOL(20),AF(7) + + CHARACTER FORFILE*20,MATFIL*20,FUTUREFILEIN*20,PARFIX(20)*11, + 1 TMPFILE*13,PATHFILE*73,PAR(30)*11,PATH*60,NPAGDENFILE*20, + 2 PASTFILEIN*20,ESTNAM*6 + +C SUBROUTINE VERIF1 IS CALLED BY MAIN TO PRINT TO THE SCREEN THE INPUT +C INFO, SO THE USER CAN VERIFY THAT THE VALUES WERE ENTERED CORRECTLY, + +C OR CHANGE VALUES AS DESIRED. + + +C NOTE: SUBROUTINE CHANGE BELOW IS CALLED SEVERAL TIMES. ITS ARGUMENT, +C ICHANG, RETURNS AS 1 IF THE PREVIOUS INFORMATION PRINTED TO THE +C SCREEN IS VALIDATED BY THE USER; IT RETURNS AS 0 IF THE USER +C WANTS TO CHANGE SOMETHING. + + + + 102 FORMAT(A20) + 103 FORMAT(A3) + + 8040 WRITE(*,1) + 1 FORMAT(///' THE FOLLOWING INFO WAS READ IN; IF ANY OF IT IS '/ + 1' INCORRECT, MAKE THE DESIRED CHANGES.') + + WRITE(*,2) FORFILE + 2 FORMAT(/' THE MODEL FILE WHICH IS ALREADY LINKED WITH THIS '/ + 1' PROGRAM, AND IS AN EDITED VERSION OF TSTMULTM.FOR, IS ',A20) + + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + + WRITE(*,3) + 3 FORMAT(/' ENTER THE NAME OF THE MODEL FILE WHICH IS ALREADY'/ + 1' LINKED WITH THIS PROGRAM (IF THIS FILE IS NOT AN EDITED '/ + 2' VERSION OF TSTMULTM.FOR, STOP THE PROGRAM NOW): ') + READ(*,102) FORFILE + + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + 5010 TMPFILE = ' ' + TMPFILE = FORFILE + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + + OPEN(28,FILE=PATHFILE,ERR=50,STATUS='OLD',POSITION='APPEND') + + GO TO 30 + 50 WRITE(*,4406) FORFILE + 4406 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ + 1' ',A73/ + 2' ENTER THE CORRECT FILENAME OR ... '/ + 2' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,102) FORFILE + IF(FORFILE(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FORFILE) + GO TO 5010 + + 30 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,0) + + CLOSE(28) + +C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: + +C NDIM = NO. OF STATES FOR THE O.D.E. +C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. +C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). +C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. +C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE +C TO BE SET BY THE USER. +C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. + +C IRAN(I) = 1 IF PARAMATER I IS RANDOM; +C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION FOR THE +C FORFILE FILE. + + IF(INCLUDPAST .EQ. 0) WRITE(*,9001) NPAGDENFILE + 9001 FORMAT(/' YOUR RUN DOES NOT INCLUDE A "PAST" HISTORY FOR THE '/ + 1' SUBJECT BEING ANALYZED. THEREFORE, THE NPAG DENSITY FILE YOU'/ + 2' ENTERED ABOVE, ',A20,', WILL BE USED AS THE PARAMETER DENSITY'/ + 3' FOR THE OPTIMIZATION OVER THE DOSES IN THE "FUTURE" FILE.') + + IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 0) + 1 WRITE(*,9004) PASTFILEIN,NPAGDENFILE + 9004 FORMAT(/' YOUR RUN INCLUDES A "PAST" HISTORY FOR THE SUBJECT'/ + 1' BEING ANALYZED (IN FILE ',A20,'). BUT THIS FILE DOES NOT HAVE'/ + 2' ANY NON-MISSING OBSERVED VALUES, AND SO THE NPAG DENSITY FILE'/ + 3' YOU ENTERED ABOVE, ',A20,', WILL BE USED AS THE PARAMETER'/ + 4' DENSITY FOR THE OPTIMIZATION OVER THE DOSES IN THE "FUTURE" '/ + 5' FILE.') + + + IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN + + IF(IPASTFILE .EQ. 0) WRITE(*,9002) PASTFILEIN,NPAGDENFILE +9002 FORMAT(/' YOUR RUN INCLUDES A "PAST" HISTORY FOR THE SUBJECT'/ + 1' BEING ANALYZED (IN WORKING COPY FILE ',A20,'), AND THIS FILE'/ + 2' HAS NON-MISSING OBSERVED VALUES. THEREFORE, THE NPAG DENSITY'/ + 3' FILE YOU ENTERED ABOVE, ',A20,', WILL BE USED AS A PRIOR'/ + 4' DENSITY FOR ANOTHER NPAG RUN WHICH WILL OBTAIN A '/ + 5' POSTERIOR DENSITY WHICH WILL BE USED AS THE PARAMETER DENSITY'/ + 6' FOR THE OPTIMIZATION OVER THE DOSES IN THE "FUTURE" FILE.') + + + IF(IPASTFILE .EQ. 1) WRITE(*,9003) PASTFILEIN,NPAGDENFILE +9003 FORMAT(/' YOUR RUN INCLUDES A "PAST" HISTORY FOR THE SUBJECT'/ + 1' BEING ANALYZED (IT IS THE INFO OF THE FIRST SUBJECT IN THE'/ + 2' .CSV FILE, ',A20,'), AND THIS FILE HAS NON-MISSING OBSERVED'/ + 3' VALUES. THEREFORE, THE NPAG DENSITY FILE YOU ENTERED ABOVE,'/ + 4' ',A20,' WILL BE USED AS A PRIOR DENSITY FOR ANOTHER NPAG RUN'/ + 5' WHICH WILL OBTAIN A POSTERIOR DENSITY WHICH WILL BE'/ + 6' USED AS THE PARAMETER DENSITY FOR THE OPTIMIZATION OVER THE'/ + 7' DOSES IN THE "FUTURE" FILE.') + + + WRITE(*,8092) MAXCYC + 8092 FORMAT(//' AND THIS NEW NPAG ANALYSIS WILL RUN A MAXIMUM '/ + 1' OF ',I6,' CYCLES.') + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. + + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + + + 8010 WRITE(*,8013) + 8013 FORMAT(/' THIS PROGRAM REQUIRES AN NPAG DENSITY FROM A PREVIOUS'/ + 1' ANALYSIS OF A POPULATION. THIS NPAG DENSITY WILL BE USED AS'/ + 2' THE PARAMETER DENSITY FOR THE OPTIMIZATION OVER THE DOSES IN'/ + 3' THE "FUTURE" OF THE SUBJECT BEING CONSIDERED IN THIS RUN IF'/ + 4' THERE IS NO "PAST" HISTORY FOR THE SUBJECT, OR IF THE "PAST"'/ + 5' HISTORY INCLUDES NO OBSERVED VALUES.'// + 6' BUT IF THERE IS A "PAST" HISTORY FOR THE SUBJECT, AND IT '/ + 7' INCLUDES OBSERVATIONS, THEN THE NPAG DENSITY WILL BE USED AS'/ + 8' AS A PRIOR DENSITY FOR ANOTHER NPAG RUN WHICH WILL OBTAIN A'/ + 9' POSTERIOR DENSITY FOR THE SUBJECT, AND THIS NEW '/ + 1' DENSITY WILL THEN BE THE DENSITY FOR THE OPTIMIZATION. '// + 1' ENTER THE NAME OF THE FILE WHICH CONTAINS THE NPAG DENSITY'/ + 2' FROM A PREVIOUS ANALYSIS OF A POPULATION (IT WILL PROBABLY'/ + 3' BE DENxxxx, WHERE xxxx WAS THE JOB NUMBER): '// + 4' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,102) NPAGDENFILE + IF(NPAGDENFILE(1:3) .EQ. '-99') + + 1 CALL SEEDIR(PATH,NOB,NPAGDENFILE) + + + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE + +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + + TMPFILE = ' ' + TMPFILE = NPAGDENFILE + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8020,STATUS='OLD') + GO TO 8025 + 8020 WRITE(*,5316) PATHFILE + GO TO 8010 + 8025 CLOSE(21) + + 8030 WRITE(*,8031) + 8031 FORMAT(/' ENTER 1 IF THE CALCULATIONS ARE TO INCLUDE THE "PAST" '/ + 1' HISTORY FOR THE SUBJECT OF THIS RUN;'/ + 2' ENTER 0 OTHERWISE: ') + + READ(*,*,ERR=8030) INCLUDPAST + IF(INCLUDPAST .NE. 1 .AND. INCLUDPAST .NE. 0) GO TO 8030 + + IF(INCLUDPAST .EQ. 0) THEN + IPASTFILE = -1 + PASTFILEIN = 'NOT USED' + TNEXT = 0.D0 + ENDIF + +8035 IF(INCLUDPAST .EQ. 1) THEN + + + WRITE(*,8003) +8003 FORMAT(/' ENTER 1 IF THE FILE WHICH HAS THE "PAST" INFO FOR'/ + 1' THE SUBJECT OF THIS RUN IS A .CSV FILE (IN THIS CASE,'/ + 2' THE INFO FOR THE FIRST SUBJECT IN THE .CSV FILE WILL'/ + 3' BE USED); '/ + 4' ENTER 0 IF THE FILE WHICH HAS THE "PAST" INFO FOR THE SUBJECT'/ + 5' OF THIS RUN IS A WORKING COPY FILE: ') + + READ(*,*,ERR=8035) IPASTFILE + IF(IPASTFILE .NE. 1 .AND. IPASTFILE .NE. 0) GO TO 8035 + + IF(IPASTFILE .EQ. 0) THEN + + WRITE(*,1021) + READ(*,102) PASTFILEIN + IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = PASTFILEIN + + + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8050,STATUS='OLD') + GO TO 8045 + 8050 WRITE(*,5316) PATHFILE + GO TO 8030 + 8045 CONTINUE + + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIOROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + + + CLOSE(21) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 0) CONDITION. + + + IF(IPASTFILE .EQ. 1) THEN + + WRITE(*,8021) + 8021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ + 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ + 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// + 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,102) PASTFILEIN + IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + + TMPFILE = PASTFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,ERR=8060,STATUS='OLD') + + + GO TO 8055 + 8060 WRITE(*,5316) PATHFILE + GO TO 8030 + 8055 CONTINUE + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + CALL CONVERTCSV + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE +C READBLOCK2. + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + +C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.PST IN THE +C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN +C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. + + + REWIND(66) + +C AS OF BESTDOS108, CHANGE ARGUMENTS BELOW FROM C0,...,C3 TO +C C0P,...,C3P (SEE REASON AT THE TOP OF BESTDOS108.FOR). + + CALL READBLOCK2(PATH,C0P,C1P,C2P,C3P,1,0) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + + TMPFILE = ' ' + TMPFILE = 'XQZPJ001.PST' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=8065,STATUS='OLD') + GO TO 8070 + 8065 WRITE(*,5466) PATHFILE,PASTFILEIN + GO TO 8030 + + 8070 CONTINUE + +C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF +C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR +C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN +C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE +C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE +C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. + + CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) +C IN PATFILE. OTHERWISE, IT RETURNS AS 0. + + + CLOSE(21) + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 1) CONDITION. + + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1) CONDITION. + + + IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN + + 8080 WRITE(*,8077) + 8077 FORMAT(/' FOR THE NPAG ANALYSIS WHICH WILL OBTAIN THE POSTERIOR'/ + 1' DENSITY (WHICH WILL THEN BE THE DENSITY FOR THE OPTIMIZATION)'/ + 2' SELECT THE MAXIMUM NO. OF CYCLES IT SHOULD RUN. THE DEFAULT'/ + 3' IS A MAXIMUM OF 500 CYCLES. '// + 4' SELECT 1 FOR 500 CYCLE;'/ + 5' SELECT 0 FOR A DIFFERERENT NO. OF MAXIMUM CYCLES: ') + READ(*,*,ERR=8080) MAXCYC + + + IF(MAXCYC .NE. 1 .AND. MAXCYC .NE. 0) GO TO 8080 + + + IF(MAXCYC .EQ. 1) MAXCYC = 500 + + IF(MAXCYC .EQ. 0) THEN + 8090 WRITE(*,8091) + 8091 FORMAT(/' ENTER A POSITIVE NO. FOR THE MAXIMUM NO. OF CYCLES'/ + 1' THE NPAG ANALYSIS SHOULD RUN: ') + READ(*,*,ERR=8090) MAXCYC + + IF(MAXCYC .LT. 1) GO TO 8090 + ENDIF + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. + + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION. + + + IF(ICSVFILE .EQ. 1) WRITE(*,4) FUTUREFILEIN + 4 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN COMES FROM THE'/ + 1' DATA OF THE FIRST SUBJECT IN THE .CSV FILE ', A20) + IF(ICSVFILE .EQ. 0) WRITE(*,6) FUTUREFILEIN + + 6 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN COMES FROM THE '/ + 1' (MULTIPLE DRUG) WORKING COPY PATIENT DATA FILE ', A20) + + IF(INCLUDPAST .EQ. 1) WRITE (*,14) PASTFILEIN,TNEXT + 14 FORMAT(/' SINCE YOUR ANALYSIS INCLUDES THE "PAST" HISTORY FOR'/ + 1' THE SUBJECT (IN FILE ',A20,'), IT WILL'/ + 2' BE ASSUMED THAT THE "PAST" BEGINS AT TIME = 0, AND THE'/ + 3' "FUTURE" BEGINS AT TIME = TNEXT. IN OTHER WORDS, THE "FUTURE"'/ + 4' FILE SHOULD START AS USUAL WITH TIME = 0, BUT ALL THE TIMES IN'/ + 5' THIS FILE WILL BE INCREASED BY TNEXT HOURS, AND THEN THIS FILE'/ + 6' WILL BE CONCATENATED TO THE "PAST" TO PROVIDE A COMPLETE'/ + 7' DOSING/OBSERVED VALUE PROFILE OF THE SUBJECT.'// + 8' TNEXT IS CURRENTLY SET TO BE ',G12.5) + + + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + + 5020 WRITE(*,5002) + 5002 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN CAN BE INPUT VIA'/ + 1' A (MULTIPLE DRUG) WORKING COPY PATIENT DATA FILE OR A BLOCK '/ + 2' MATRIX .CSV FILE (THE INFO WILL COME FROM THE DATA OF THE'/ + 3' FIRST SUBJECT IN THIS CASE).'// + 5' ENTER 1 TO ENTER INFO USING A .CSV FILE; '/ + 6' ENTER 0 TO ENTER INFO USING A WORKING COPY PATIENT DATA FILE: ') + READ(*,*,ERR=5020) ICSVFILE + IF(ICSVFILE .NE. 1 .AND. ICSVFILE .NE. 0) GO TO 5020 + + IF(ICSVFILE .EQ. 0) THEN + + WRITE(*,1021) + 1021 FORMAT(/' ENTER THE NAME OF THE WORKING COPY PATIENT DATA FILE.' + 1// + 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,102) FUTUREFILEIN + IF(FUTUREFILEIN(1:3) .EQ. '-99') + 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=6440,STATUS='OLD') + GO TO 6455 + 6440 WRITE(*,5316) PATHFILE + + 5316 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ + 1' ',A73) + GO TO 5020 + 6455 CONTINUE + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 0) CONDITION. + + + IF(ICSVFILE .EQ. 1) THEN + + WRITE(*,3021) +3021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ + 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ + 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// + + 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') + READ(*,102) FUTUREFILEIN + IF(FUTUREFILEIN(1:3) .EQ. '-99') + 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) + +C CHECK THAT THIS IS AN EXISTING FILE. + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = FUTUREFILEIN + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(87,FILE=PATHFILE,ERR=5440,STATUS='OLD') + + GO TO 5455 + 5440 WRITE(*,5316) PATHFILE + GO TO 5020 + 5455 CONTINUE + +C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, +C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" +C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, +C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT +C NEWCSV CONVERTS FILE 77 TO FILE 67. + + CALL CONVERTCSV + +C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF +C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) +C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT + +C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE +C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN +C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE +C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE +C READBLOCK2. + + OPEN(67) + CALL NEWCSV + CALL CSVCHANGE + +C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.FUT IN THE +C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN +C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. + + REWIND(66) + +C AS OF BESTDOS108, CHANGE ARGUMENTS BELOW FROM C0,...,C3 TO +C C0P,...,C3P (SEE REASON AT THE TOP OF BESTDOS108.FOR). + + CALL READBLOCK2(PATH,C0P,C1P,C2P,C3P,2,0) + CLOSE(66) + +C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. + + TMPFILE = ' ' + + + TMPFILE = 'XQZPJ001.FUT' + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + OPEN(21,FILE=PATHFILE,ERR=5465,STATUS='OLD') + GO TO 5470 + 5465 WRITE(*,5466) PATHFILE,FUTUREFILEIN + 5466 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ + 1' ',A73/ + 2' WHICH MEANS THAT YOUR .CSV FILE, ',A20,' WAS NOT READ '/ + 3' PROPERLY. PLEASE CHECK THIS FILE TO MAKE SURE IT IS CORRECT.'//) + + GO TO 5020 + + 5470 CONTINUE + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. + +C AT THIS POINT, FILE 21 CONTAINS THE WORKING COPY FILE TO BE USED +C FOR THIS RUN (VIA EITHER THE ICSVFILE .EQ. 0 OR THE ICSVFILE .EQ. 1 +C BLOCK). CALL GETNUMEQ WHICH WILL READ THIS FILE 21 AND OBTAIN +C NUMEQT AND NDRUG. + + + CALL GETNUMEQ(NUMEQT,NDRUG) + CLOSE(21) + +C IF INCLUDPAST = 0, IT MEANS THAT THE USER IS PROVIDING NO "PAST" +C HISTORY FOR THE SUBJECT. IN THIS CASE, SET TNEXT = 0.0. OTHERWISE, +C HAVE THE USER ENTER TNEXT. + + IF(INCLUDPAST .EQ. 0) TNEXT = 0.D0 + + IF(INCLUDPAST .EQ. 1) THEN + 9040 WRITE(*,8041) PASTFILEIN,FUTUREFILEIN + 8041 FORMAT(/' YOUR ANALYSIS INCLUDES THE "PAST" HISTORY FOR THE'/ + + 1' SUBJECT IN FILE ',A20,' AND THE "FUTURE" IN FILE ',A20/ + 2' IT WILL BE ASSUMED THAT THE "PAST" BEGINS AT TIME = 0, AND THE'/ + 3' "FUTURE" BEGINS AT TIME = TNEXT. IN OTHER WORDS, THE "FUTURE"'/ + 4' FILE SHOULD START AS USUAL WITH TIME = 0, BUT ALL THE TIMES IN'/ + 5' THIS FILE WILL BE INCREASED BY TNEXT HOURS, AND THEN THIS FILE'/ + 6' WILL BE CONCATENATED TO THE "PAST" TO PROVIDE A COMPLETE'/ + 7' DOSING/OBSERVED VALUE PROFILE OF THE SUBJECT.'// + 8' BUT NOTE THAT OPTIMUM DOSES WILL BE FOUND ONLY IN THE "FUTURE"'/ + 9' TO BEST ACHIEVE THE OBSERVED VALUES IN THE "FUTURE" ... BASED'/ + 1' ON THE "PAST" HISTORY. '// + 2' ENTER TNEXT, A POSTIVE NO. OF HOURS, NOW: ') + READ(*,*,ERR=9040) TNEXT + IF(TNEXT .LE. 0.D0) GO TO 9040 + ENDIF + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION FOR THE +C ICSVFILE VALUE. + + + WRITE(*,8174) IDELTA +8174 FORMAT(/' THE OUTPUT FILE WILL INCLUDE, FOR EACH GRID POINT IN '/ + 1' THE PARAMETER DENSITY (AND THE WEIGHTED MEAN OF THESE GRID'/ + 2' POINTS), SIMULATED OBSERVED VALUES, BASED ON THE OPTIMAL DOSES'/ + 3' WHICH THE PROGRAM CALCULATES.'// + 4' THESE SIMULATED VALUES WILL BE ',I6,' MINUTES APART.') + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + + 8170 WRITE(*,8172) + 8172 FORMAT(/' THE OUTPUT FILE WILL INCLUDE, FOR EACH GRID POINT IN '/ + 1' THE PARAMETER DENSITY (AND THE WEIGHTED MEAN OF THESE GRID'/ + 2' POINTS), SIMULATED OBSERVED VALUES, BASED ON THE OPTIMAL DOSES'/ + 3' WHICH THE PROGRAM CALCULATES.'// + 4' ENTER 1 IF THESE VALUES SHOULD BE SIMULATED EVERY 15 MINUTES'/ + 5' 0 FOR A DIFFERENT NO. OF MINUTES BETWEEN SIMULATED VALUES: + 6 ') + READ(*,*,ERR=8170) IDELTA + IF(IDELTA .NE. 1 .AND. IDELTA .NE. 0) GO TO 8170 + + IF(IDELTA .EQ. 1) IDELTA = 15 + + + IF(IDELTA .EQ. 0) THEN + WRITE(*,8173) + 8173 FORMAT(/' ENTER THE NO. OF MINUTES BETWEEN SIMULATED VALUES: ') + READ(*,*,ERR=8170) IDELTA + IF(IDELTA .LE. 0) GO TO 8170 + ENDIF + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION. + + + + IF(NOFIX .GT. 0) THEN + + WRITE(*,7) NOFIX + + 7 FORMAT(/' THE VALUES FOR THE ',I2,' FIXED PARAMETERS ARE: ') + DO I = 1,NOFIX + WRITE(*,8) PARFIX(I),VALFIX(I) + + 8 FORMAT(' ',A11,': ',G14.7) + END DO + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + WRITE(*,4836) + 4836 FORMAT(/' ENTER THE VALUE FOR EACH FIXED PARAMETER: ') + DO I = 1,NOFIX + 4845 WRITE(*,34) PARFIX(I) + 34 FORMAT(/' ',A11,' : ') + READ(*,*,ERR=4845) VALFIX(I) + + END DO + + ENDIF + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NOFIX .GT. 0) CONDITION. + + + WRITE(*,9) TOLER + + 9 FORMAT(/' THE TOLERANCES FOR THE O.D.E. SOLVER ARE SET EQUAL'/ + 1' TO ',G14.7) + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + + 915 WRITE(*,913) + 913 FORMAT(/' ENTER 1 TO SET ALL TOLERANCES (FOR THE O.D.E. '/ + 1' SOLVER) TO THE DEFAULT VALUE ... 1.D-4.'/ + 2' ENTER 0 TO SELECT A DIFFERENT VALUE FOR THE TOLERANCES: ') + READ(*,*,ERR=915) ITOL + IF(ITOL .NE. 0 .AND. ITOL .NE. 1) GO TO 915 + + TOLER = 1.D-4 + + + + IF(ITOL .EQ. 0) THEN + + 910 WRITE(*,914) + + 914 FORMAT(/' ENTER A POSITIVE VALUE FOR THE TOLERANCE PARAMETERS: ') + READ(*,*,ERR=910) TOLER + IF(TOLER .LE. 0.D0) GO TO 910 + + + ENDIF + +C RTOL = TOLER <-- RTOL NOT USED IN THIS ROUTINE. + DO I=1,NDIM + ATOL(I) = TOLER + END DO + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) FOR TOLER. + + + WRITE(*,2112) NPAGDENFILE + 2112 FORMAT(/' IN THE NPAG RUN YOU DID WHICH PRODUCED THE DENSITY'/ + 1' FILE, ',A20,' YOU MODELED THE ASSAY ERROR FUNCTION, S.D., AS'/ + 2' FOLLOWS (ASSUMING SD1 = C0+C1*Y+C2*Y**2+C3*Y**3):') + IF(IERRMOD .EQ. 1) WRITE(*,2113) + IF(IERRMOD .EQ. 2) WRITE(*,2114) GAMLAM + IF(IERRMOD .EQ. 3) WRITE(*,2116) GAMLAM + IF(IERRMOD .EQ. 4) WRITE(*,2117) GAMLAM + 2113 FORMAT(/' S.D. = SD1') + 2114 FORMAT(/' S.D. = GAMMA*SD1, WITH GAMMA TO BE ESTIMATED, AND'/ + 1' THE FINAL GAMMA ESTIMATE WAS ',G16.10) + 2116 FORMAT(/' S.D. = SQRT(SD1**2 + LAMBDA**2), WITH LAMBDA TO BE ES + 1TIMATED'/ + 2' AND THE FINAL LAMBDA ESTIMATE WAS ',G16.10) + 2117 FORMAT(/' S.D. = GAMMA, WITH GAMMA TO BE ESTIMATED, AND'/ + 1' THE FINAL GAMMA ESTIMATE WAS ',G16.10) + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + + + CALL SYSTEM('CLS') + + 1110 WRITE(*,118) NPAGDENFILE + 118 FORMAT(//' SELECT HOW YOU MODELED THE ASSAY ERROR FUNCTION IN '/ + 1' THE NPAG RUN YOU DID WHICH PRODUCED THE DENSITY FILE, ',A20// + 1' RECALL THAT SD1 = C0+C1*Y+C2*Y**2+C3*Y**3; THEN ...'// + 2' ENTER 1 IF S.D. = SD1;'/ + 3' ENTER 2 IF S.D. = GAMMA*SD1, WITH GAMMA TO BE ESTIMATED;'/ + 4' ENTER 3 IF S.D. = SQRT(SD1**2 + LAMBDA**2), WITH LAMBDA TO BE ES + 5TIMATED;'/ + 6' ENTER 4 IF S.D. = GAMMA, WITH GAMMA TO BE ESTIMATED: ') + READ(*,*,ERR=1110) IERRMOD + IF(IERRMOD .LT. 1 .OR. IERRMOD .GT. 4) GO TO 1110 + + IF(IERRMOD .GE. 2) THEN + ESTNAM = ' GAMMA' + + + IF(IERRMOD .EQ. 3) ESTNAM = 'LAMBDA' + + 225 WRITE(*,223) ESTNAM + 223 FORMAT(/' ENTER THE FINAL ESTIMATE FOR ',A6,' IN THE NPAG RUN: + 1 ') + READ(*,*,ERR=225) GAMLAM + IF(GAMLAM .LE. 0.D0) THEN + WRITE(*,1223) + 1223 FORMAT(/' THIS VALUE MUST BE POSITIVE. '/) + GO TO 225 + ENDIF + ENDIF + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) FOR IERRMOD/GAMLAM + + + WRITE(*,12) NUMEQT + 12 FORMAT(/' NOTE THAT THE GENERAL VALUES FOR [C0,C1,C2,C3] '/ + 1' FOR EACH OF THE ',I2,' OUTPUT EQUATION(S), ARE SHOWN BELOW: '/) + + DO IEQ = 1,NUMEQT + WRITE(*,162) IEQ,C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + IAS = IASS(IEQ) + IF(IAS .EQ. 1) WRITE(*,419) + IF(IAS .EQ. 0) WRITE(*,519) + + END DO + + 162 FORMAT(' EQ. ',I2,': ',4(G16.10,1X)) + + 419 FORMAT(/' THE PATIENT DATA FILE FOR THIS RUN WILL BE ASSIGNED'/ + 1' THE ASSAY COEFFICIENTS IN ITS DATA FILE; IF THERE ARE NO'/ + + 2' COEFFICIENTS IN THE DATA FILE, THE PATIENT WILL BE ASSIGNED'/ + 3' THE ABOVE GENERAL VALUES.'/) + + 519 FORMAT(/' THE PATIENT DATA FILE FOR THIS RUN WILL BE ASSIGNED'/ + + 1' THE ABOVE GENERAL ASSAY COEFFICIENTS (I.E., INDIVIDUAL ASSAY'/ + + 2' COEFFICIENTS ALREADY IN THE PATIENT DATA FILE WILL BE'/ + 3' OVERWRITTEN BY THE ABOVE VALUES.)'/) + + CALL CHANGE(ICHANG) + + IF(ICHANG .EQ. 0) THEN + + CALL SYSTEM('CLS') + + WRITE(*,119) + 119 FORMAT(//' FOR EACH OUTPUT EQUATION(S), SELECT ONE OF THE FOLLOWIN + 1G'/ + + 5' OPTIONS FOR THE ASSAY COEFFICIENTS [C0,C1,C2,C3]: '// + 4' ENTER 1 FOR THE DEFAULT OPTION ...'/ + 5' IF THE PATIENT DATA FILE ALREADY INCLUDES '/ + 6' ASSAY COEFFICIENTS, THOSE COEFFICIENTS WILL BE USED. '/ + 7' OTHERWISE THE COEFFICIENTS YOU ENTER BELOW WILL BE '/ + 8' USED;'/ + 7' ENTER 0 IF YOU WOULD LIKE THE ASSAY COEFFICIENTS TO BE THOSE'/ + 1' YOU ENTER BELOW (WHETHER OR NOT YOUR PATIENT FILE HAS'/ + 2' ASSAY COEFFICIENTS ALREADY: ') + + CALL PAUSE + +C FOR EACH OUTPUT, INPUT IASS AND [C0P,...,C3P]. + + DO 2200 IEQ = 1,NUMEQT + + + 1120 WRITE(*,221) IEQ + 221 FORMAT(/' FOR OUTPUT EQUATION ',I1,':'// + 4' ENTER 1 FOR THE DEFAULT OPTION;'// + 7' ENTER 0 TO BE PROMPTED FOR ASSAY COEFFICIENTS: ') + READ(*,*,ERR=1120) IAS + + IF(IAS .NE. 0 .AND. IAS .NE. 1) GO TO 1120 + IASS(IEQ) = IAS + + + WRITE(*,1119) IEQ + 1119 FORMAT(/' ENTER THE GENERAL VALUES FOR [C0,C1,C2,C3] FOR '/ + 1' OUTPUT EQUATION ',I1,'. THESE ') + IF(IAS .EQ. 1) WRITE(*,1121) + IF(IAS .EQ. 0) WRITE(*,1123) + + 1121 FORMAT(' WILL BE USED IF YOUR PATIENT DATA FILE DOES NOT'/ + 1' ALREADY INCLUDE ASSAY COEFFICIENTS: ') + 1123 FORMAT(' WILL BE USED EVEN IF YOUR PATIENT DATA FILE ALREADY'/ + 1' INCLUDES ASSAY COEFFICIENTS: ') + 4140 READ(*,*,ERR=4145) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) + + GO TO 2200 + 4145 WRITE(*,4146) + 4146 FORMAT(/' SEE ABOVE; PLEASE ENTER FOUR REAL NUMBERS: ') + GO TO 4140 + + 2200 CONTINUE + + + WRITE(*,2119) + 2119 FORMAT(//' NOTE: DURING THIS PROGRAM, THE PATIENT DATA FILE'/ + 1' WILL HAVE ITS COEFFICIENTS WRITTEN TO THE END OF THE '/ + 2' WORKING COPY FILE. IF COEFFICIENTS ARE ALREADY THERE'/ + 3' FROM A PREVIOUS RUN, THEY WILL BE OVERWRITTEN.'//) + CALL PAUSE + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION FOR THE +C ASSAY COEFFICIENTS. + +4150 WRITE(*,112) NDRUG + 112 FORMAT(/' THE ACTIVE (SALT) FRACTION OF EACH OF THE ',I1,' DRUG( + 1S) FOLLOWS.') + + DO I = 1,NDRUG + WRITE(*,113) I,AF(I) + 113 FORMAT(' AF FOR DRUG ',I1,' IS ',G12.6) + END DO + + + CALL CHANGE(ICHANG) + IF(ICHANG .EQ. 0) THEN + + +5150 WRITE(*,129) + 129 FORMAT(//' ENTER THE ACTIVE (SALT) FRACTION OF EACH DRUG. AS '/ + 1' AN EXAMPLE, THE A.F. OF THEOPHYLLINE IS 1.0, WHILE THAT OF'/ + 2' AMINOPHYLLINE IS TYPICALLY BETWEEN .79 AND .85, DEPENDING ON'/ + 3' THE PREPARATION. '// + 4' EACH AF MUST BE A POSITIVE NUMBER LESS THAN OR EQUAL TO 1.0.'/) + + DO I = 1,NDRUG + WRITE(*,1129) I + 1129 FORMAT(' AF FOR DRUG ',I1,': ') + READ(*,*,ERR=5150) AF(I) + IF(AF(I) .LE. 0.0 .OR. AF(I) .GT. 1.0) GO TO 5150 + END DO + + ENDIF + + IF(IOPTIMIZE .EQ. 1) WRITE(*,2129) + 2129 FORMAT(/' THE DOSES SHOWN IN THE "FUTURE" FILE WILL BE THE'/ + 1' INITIAL GUESSES USED TO FIND THE OPTIMUM DOSES TO HIT THE'/ + 2' TARGET CONCENTRATIONS IN THE "FUTURE" FILE. ALL SUBSEQUENT'/ + 3' CALCULATIONS WILL BE BASED ON THE OPTIMUM DOSES.') + + IF(IOPTIMIZE .EQ. 0) WRITE(*,2131) + 2131 FORMAT(/' THE DOSES SHOWS IN THE "FUTURE" FILE WILL BE THOSE'/ + 1' USED FOR ALL SUBSEQUENT CALCULATIONS (I.E.,NO OPTIMIZATION OF'/ + 2' DOSES WILL BE DONE).') + + CALL CHANGE(ICHANG) + IF(ICHANG .EQ. 0) THEN + + 3130 WRITE(*,3129) + 3129 FORMAT(/' ENTER 1 IF YOU WANT TO FIND THE OPTIMUM DOSES TO HIT'/ + 1' THE TARGET CONCENTRATIONS IN THE "FUTURE" FILE.'/ + 4' ENTER 0 IF, INSTEAD, YOU WANT THE OUTPUT FILE TO SHOW '/ + 5' PREDICTED CONCENTRATIONS AND AUCs FOR THE DOSES IN '/ + 6' THE "FUTURE" FILE (I.E., NO OPTIMIZATION WILL BE DONE'/ + 7' IN THIS CASE): ') + READ(*,*,ERR=3130) IOPTIMIZE + IF(IOPTIMIZE .NE. 1 .AND. IOPTIMIZE .NE. 0) GO TO 3130 + + ENDIF + + +C IF IOPTIMIZE = 0, NO OPTIMIZATION IS TO BE DONE, WHICH RENDERS THE +C QUESTION ABOUT BIASWEIGHT BELOW MOOT. IN THIS CASE, SIMPLY SET +C BIASWEIGHT = 0. + +C BUT IF IOPTIMIZE = 1, THEN REPORT THE CURRENT VALUE OF BIASWEIGHT AND +C SEE IF THE USER WANTS TO CHANGE IT (I.E., ASK THE THE USER ABOUT +C HOW THE COST FUNCTION (WHICH ESTABLISHES THE BEST DOSES) SHOULD BE +C CALCULATED). + + + + IF(IOPTIMIZE .EQ. 0) THEN + BIASWEIGHT = 0.D0 + ENDIF + + IF(IOPTIMIZE .EQ. 1) THEN + + WRITE(*,3151) BIASWEIGHT + 3151 FORMAT(/' THE COST FUNCTION TO BE MINIMIZED IN FINDING THE'/ + 1' "BEST" DOSES IS (1 - BIASWEIGHT)*V(U) + BIASWEIGHT*B(U), WHERE'/ + 2' V(U) IS THE MEAN SQUARED ERROR ASSOCIATED WITH ALL THE '/ + 3' GRID PTS. IN THE PARAMETER DENSITY; AND B(U) IS THE MEAN '/ + 4' SQUARED ERROR DUE TO BIAS ABOUT THE MEAN RESPONSE.'// + 5' THE VALUE OF BIASWEIGHT IS ',G12.6) + + + CALL CHANGE(ICHANG) + IF(ICHANG .EQ. 0) THEN + + 3140 WRITE(*,3139) + 3139 FORMAT(/' ENTER THE VALUE FOR BIASWEIGHT BETWEEN 0 AND 1, INCLUS + 1IVE:') + READ(*,*,ERR=3140) BIASWEIGHT + IF(BIASWEIGHT .LT. 0.D0 .OR. BIASWEIGHT .GT. 1.D0) GO TO 3140 + ENDIF + + + ENDIF +C THE ABOVE ENDIF IS FOR THE IF(IOPTIMIZE .EQ. 1) CONDITION. + + + IF(ITARGET .EQ. 1) WRITE(*,3252) + 3252 FORMAT(/' THE OBSERVED VALUES IN THE FUTURE PATIENT FILE ARE'/ + 1' TARGET CONCENTRATIONS.') + IF(ITARGET .EQ. 2) WRITE(*,3253) + 3253 FORMAT(/' THE OBSERVED VALUES IN THE FUTURE PATIENT FILE ARE'/ + 1' TARGET AUCs.') + + CALL CHANGE(ICHANG) + IF(ICHANG .EQ. 0) THEN + + 3150 WRITE(*,3149) + 3149 FORMAT(/' ENTER 1 IF THE OBSERVED VALUES IN THE FUTURE PATIENT'/ + 1' FILE ARE TARGET CONCENTRATIONS; '/ + 2' ENTER 2 IF THE OBSERVED VALUES ARE TARGET AUCs: ') + READ(*,*,ERR=3150) ITARGET + IF(ITARGET .NE. 1 .AND. ITARGET .NE. 2) GO TO 3150 + + ENDIF + + + + 7005 WRITE(*,7001) + 7001 FORMAT(///' ENTER 1 IF ALL INSTRUCTIONS ARE NOW CORRECT;'/ + 2' ENTER 0 OTHERWISE: ') + READ(*,*,ERR=7005) ICHANG + IF(ICHANG .NE. 0 .AND. ICHANG .NE. 1) GO TO 7005 + IF(ICHANG .EQ. 0) GO TO 8040 + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE CHANGE(ICHANG) +C +C THIS SUBROUTINE IS CALLED BY SUBROUTINE VERIF1 TO HAVE THE USER CHECK +C WHETHER HIS INPUT INFO IS CORRECT OR NEEDS TO BE CHANGED. +C +C INPUT: NOTHING +C +C OUTPUT: +C +C ICHANG = 1 IF INFO PRINTED PREVIOUSLY TO THE SCREEN IS CORRECT. +C = 0 IF INFO PRINTED PREVIOUSLY TO THE SCREEN SHOULD BE +C CHANGED. +C + 10 WRITE(*,1) + 1 FORMAT(//' ENTER 1 IF THE ABOVE INFORMATION IS CORRECT;'/ + 1' ENTER 0 IF IT SHOULD BE CHANGED: ') + READ(*,*,ERR=10) ICHANG + IF(ICHANG .NE. 0 .AND. ICHANG .NE. 1) GO TO 10 + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE READBLOCK2(PATH,C0,C1,C2,C3,IWHICH,IGUI) + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + +C THIS ROUTINE IS BASED ON SUBROUTINE READBLOCK IN NPBG15E1.FOR, BUT +C INSTEAD OF CREATING A WORKING COPY PATIENT DATA FILE FOR EACH BLOCK +C OF DATA IN THE .CSV FILE ALREADY OPENED AS FILE 66 IN MAIN, IT ONLY +C CREATES ONE MULTIPLE DRUG WORKING COPY PATIENT DATA FILE, +C 'XQZPJ001.PST' IF IWHICH = 1, AND 'XQZPJ001.FUT' IF IWHICH = 2, + +C FROM THE FIRST SUBJECT'S DATA. SO MAXSUB WILL BE +C HARDCODED = 1 BELOW, AND ALL DIMENSIONS WHICH WERE MAXSUB IN +C NPBG15E1.FOR/READBLOCK WILL NOW BE 1. + + + + DIMENSION TIMOUT(1,MAXNUMEQ,650),TIMIV(1,7,5200), + 1 NTIMOUT(1,MAXNUMEQ),NTIMIV(1,7),RATEIV(1,7,5200),BOLUS(1,7,5200), + 2 OUT(1,MAXNUMEQ,650),COV(1,26,5200),ICOVTYPE(26), + 5 TIMBOL(1,7,5200),NTIMBOL(1,7),NTIMCOV(1,26), + 6 TIMCOV(1,26,5200),TIMALL(1,72000),NTIMALL(1), + 7 TIMI(72000),C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ), + 8 C3(MAXNUMEQ),CSUB(1,4,MAXNUMEQ),NSST(1),DOSELINEST(1,99,100) + + CHARACTER READLINE*1000,COVNAME(26)*11,NUMBER(1)*3, + 1 PATFIL*20,CHARSUB*3,SUBID*11,SUBIDPREV*11,SUBARRAY(1)*11, + 3 PATH*60,TMPFILE*13,PATHFILE*73,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + + 1 FORMAT(A1000) + +C SET MAXSUB = 1 SINCE ONLY 1 SUBJECT WILL BE CREATED BY THIS ROUTINE. + + MAXSUB = 1 + + +C INITIALIZE NDRUG (THE NO. OF DRUGS IN THE PATIENT DATA SET) TO BE +C 0. EVERY TIME IDRUGNO IS READ BELOW, NDRUG WILL BE SET = +C MAX(NDRUG,IDRUGNO). + +C SIMILARLY, INITIALIZE NOUT (THE NO. OF OUTPUT EQUATIONS IN THE +C PATIENT DATA SET) TO BE 0. EVERY TIME IOUTEQ IS READ BELOW, +C NOUT WILL BE SET = MAX(NOUT,IOUTEQ). + + NDRUG = 0 + NOUT = 0 + +C INITIALIZE NSST(.) TO 0. IT GIVES THE NO. OF STEADY STATE DOSE +C LINES THAT WILL BE WRITTEN TO THE DOSAGE BLOCK FOR THE SUBJECT. + + DO ISUB = 1,MAXSUB + NSST(ISUB) = 0 + END DO + + +C NOTE THAT ANY LINE STARTING WITH A # WILL BE IGNORED. THE FIRST LINE +C WILL ALSO BE IGNORED - IT HAS ALREADY BEEN VERIFIED TO HAVE THE +C REQUIRED CODE IN IT. + + + READ(66,*) + +C READ THE 2ND LINE, WHICH MUST HAVE A # AS THE FIRST CHARACTER. IT HAS +C THE NAMES OF THE COLUMNS. COUNT THE NO. OF COMMAS ON THE LINE. THE +C NO. OF COVARIATES WILL BE THE NO. OF COMMAS - 11 (SINCE THERE ARE 12 +C FIXED ENTRIES WHICH POTENTIALLY SHOW UP ON EACH LINE: PATIENT ID, +C EVENT ID, TIME, INFUSION DURATION, TOTAL DOSE, INPUT DRUG NO., +C OUTPUT VALUE, OUTPUT EQ., AND 4 SPOTS FOR ASSAY COEFFICIENTS WHICH +C ONLY SHOW UP ON OUTPUT LINES). NOTE THAT THIS VALUE WILL BE CALLED +C NCOVA, WHICH MEANS NO. OF ADDITION COVARIATES (IN ADDITION TO THE 4 +C PERMANENT ONES AT THE TOP OF EACH PATIENT'S WORKING COPY FILE (AGE, +C SEX, HEIGHT, ETHNICITY FLAG), ... TO BE CONSISTENT WITH THE NAME +C USED IN NPAG100.FOR. + + READ(66,1) READLINE + + NCOMMA = 0 + + DO ISTART = 1,1000 + + IF(READLINE(ISTART:ISTART) .EQ. ',') THEN + NCOMMA = NCOMMA + 1 + ENDIF + + END DO + + NCOVA = NCOMMA - 11 + + IF(NCOVA .GT. 0) THEN + +C READ THE NAMES OF THE NCOVA COVARIATES FROM THE LINE STARTING WITH +C #ID OR "#ID. + +C NOTE THAT AFTERCOMMA OPENS AND PUTS INTO FILE 57 THE PART OF READLINE + +C WHICH IS BETWEEN COMMA C AND COMMA C+1, WHERE C IS THE 3RD ARGUMENT. +C ALSO,NOTE THAT NCOVA MUST BE PROVIDED TO AFTERCOMMA SO IT WILL KNOW +C THE TOTAL NO. OF COMMAS IN READLINE (WHICH = 11 + NCOVA). + + + REWIND(66) + 120 READ(66,1) READLINE + IF(READLINE(1:3) .NE. '#ID' .AND. READLINE(1:4).NE. '"#ID' + + 1 .AND. READLINE(1:3) .NE. '#id' .AND. READLINE(1:4).NE. '"#id') + 2 GO TO 120 + + + DO ICOV = 1,NCOVA + CALL AFTERCOMMA(NCOVA,READLINE,11+ICOV) + BACKSPACE(57) + READ(57,2) COVNAME(ICOV) + 2 FORMAT(A11) + CLOSE(57) + END DO + + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE IF(NCOVA .GT. 0) CONDITION. + + + +C CALL SUBROUTINE GETMAXTIM TO GET THE MAXIMUM TIME OVER ALL THE +C SUBJECTS IN FILE 66. THIS INCLUDES THE ENDING TIME OVER ALL IV +C EVENTS. THEN SET TIMADD = THIS TIME + 1. FOR EACH SUBJECT BELOW, +C EACH TIME WILL HAVE TIMADD*NRESET ADDED TO IT, WHERE NRESET IS THE +C NO. OF TIME RESETS (FOR THAT SUBJECT) UP TO AND INCLUDING THAT TIME. +C THIS WILL MAKE EACH TIME A UNIQUE TIME (I.E., WITH TIME RESETS IN +C THE BLOCK FORMAT FILE, THERE COULD BE MANY TIMES WITH THE SAME +C VALUE). + + + CALL GETMAXTIM(NCOVA,TIMAX) + +C VERIFY THAT TIMAX WAS CALCULATED CORRECTLY - I.E., THAT IT IS NOT +C STILL THE INITIALIZED NEGATIVE VALUE IN GETMAXTIM. + + IF(TIMAX .LT. 0) THEN + + + + + WRITE(*,11) + 11 FORMAT(/' THERE IS SOMETHING WRONG WITH YOUR BLOCK FORMAT'/ + 1' FILE. THE TIMES IN COLUMN 3 AND/OR THE TIME DURATIONS'/ + 2' IN COLUMN 4 ARE BAD. PLEASE CHECK YOUR VALUES. '// + 3' THE PROGRAM STOPS.') + + + OPEN(47,FILE=ERRFIL) + WRITE(47,11) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + TIMADD = TIMAX + 1.D0 + + +C REWIND FILE 66, READ PAST THE FIRST LINE WHICH HAS THE CODE, AND +C THE SECOND LINE, WHICH HAS THE COVARIATE INFORMATION ON IT, AND +C THEN READ ALL LINES, EXCEPT THOSE THAT START WITH # OR "#. +C GO THROUGH EACH SUCCEEDING LINE IN FILE 66 AND EXTRACT ALL THE +C INFORMATION. NOTE THAT EACH LINE CAN CONTAIN OUTPUT INFO OR DOSAGE +C INFO (INCLUDING COVARIATE VALUES), DEPENDING ON THE VALUE FOR IDEVENT +C (THE 2ND ENTRY IN EACH LINE), BUT NOT BOTH. IN PARTICULAR, IF +C IDEVENT = 0 --> THE ROW HAS OUTPUT EQUATION INFO. +C IDEVENT = 1 --> THE ROW HAS DOSAGE/COVARIATE INFO. +C IDEVENT = 4 --> SAME AS IDEVENT = 1, EXCEPT THIS ROW REPRESENTS A +C TIME RESET. + + REWIND(66) + READ(66,1) + READ(66,1) + +C INITIALIZE SUBIDPREV (THE PREVIOUS SUBJECT ID) TO BE '%^&*' SO THE + +C FIRST SUJBECT ID READ IN BELOW WILL BE DIFFERENT THAN THIS, AND SO +C START THE SUBJECT ID LOGIC. ALSO, INITIALIZE THE SUBJECT NO. TO 0. + + SUBIDPREV = '%^&*' + NSUB = 0 + +C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED. + + 10 READ(66,1,IOSTAT=IEND) READLINE + IF(IEND .LT. 0) GO TO 100 + IF(READLINE(1:1) .EQ. '#' .OR. READLINE(1:2) .EQ. '"#') GO TO 10 + +C THE FIRST VALUE (I.E., AFTER COMMA NO. 0) IS THE SUBJECT ID. + + CALL AFTERCOMMA(NCOVA,READLINE,0) + BACKSPACE(57) + READ(57,2) SUBID + CLOSE(57) + + +C NOTE THAT SUBID CONTAINS THE 1ST 11 CHARACTERS OF THE LINE, BUT THE +C SUBJECT ID IS JUST THE SET OF CHARACTERS PRIOR TO THE 1ST COMMA. +C CALL SUBROUTINE GETID TO CORRECT THE VALUE OF SUBID. + + CALL GETID(SUBID) + +C IF SUBID = SUBIDPREV, THIS IS ANOTHER LINE FOR THE CURRENT SUBJECT. +C IF SUBID .NE. SUBIDPREV, THIS IS THE 1ST EVENT FOR A NEW SUBJECT, SO +C INCREASE NSUB, AND SET THE NO. OF INFUSIONS (FOR EACH DRUG), BOLI, +C OBSERVATION, AND COVARIATE TIMES FOR THIS SUBJECT TO 0 (THEY WILL +C BE UPDATED BELOW AS REQUIRED). SIMILARY SET THE TOTAL NO. OF DOSE +C EVENTS = 0. + +C ALSO, SINCE THIS IS A NEW SUBJECT, DEFAULT THE ASSAY COEFFICIENTS FOR +C OUTPUT EQ. IEQ TO [C0(IEQ),C1(IEQ),C2(IEQ),C3(IEQ)], +C IEQ = 1,MAXNUMEQ (MAXNUMEQ IS THE MAXIMUM THAT NUMEQT CAN BE). THEN, +C AS THIS SUBJECT'S INFO IS BEING READ BELOW, ANY ASSAY C'S SPECIFIED +C FOR THIS SUBJECT WILL OVERWRITE THE DEFAULT VALUES. AND NOTE THAT IF +C A SUBJECT HAS MORE THAN ONE SET OF ASSAY C'S FOR A GIVEN OUTPUT EQ., +C THE LAST SET WILL BE USED. + +C NOTE THAT AFTER READBLOCK2 HAS FINISHED READING THE PATIENT INFO, +C CSUB(I,J,K), J=1,4 WILL BE ASSAY C'S [C0 C1 C2 C3] FOR SUBJECT I +C AND OUTPUT EQ. K. + + + IF(SUBID .NE. SUBIDPREV) THEN + + SUBIDPREV = SUBID + + NSUB = NSUB + 1 + +C FASTFORWARD THE LOGIC TO THE END OF THE ROUTINE IF NSUB = 2, SINCE +C THE INFO FOR THE FIRST SUBJECT WILL ALREADY HAVE BEEN READ IN. AND +C RESET NSUB = 1 AT THAT POINT SINCE ONLY THE FIRST SUBJECT'S DATA WILL +C BE NEEDED. + + IF(NSUB .EQ. 2) GO TO 100 + + + SUBARRAY(NSUB) = SUBID + + NTIMALL(NSUB) = 0 + + DO K = 1,7 + NTIMIV(NSUB,K) = 0 + NTIMBOL(NSUB,K) = 0 + END DO + + DO K = 1,26 + NTIMCOV(NSUB,K) = 0 + END DO + + DO K = 1,MAXNUMEQ + NTIMOUT(NSUB,K) = 0 + CSUB(NSUB,1,K) = C0(K) + CSUB(NSUB,2,K) = C1(K) + CSUB(NSUB,3,K) = C2(K) + CSUB(NSUB,4,K) = C3(K) + END DO + + +C SEE LOGIC BELOW. IF THIS ROW REPRESENTS A TIME RESET, THEN AN +C EXTRA VALUE (-99) AT AN EXTRA TIME (0) WILL BE ADDED TO EACH OUTPUT +C EQUATION ARRAY. BUT THIS NEEDS TO BE DONE JUST ONCE FOR EACH TIME +C RESET, NOT FOR EACH DOSAGE LINE THAT HAS A RESET. I.E., IF THERE +C ARE 5 DRUGS, THEN THERE COULD BE AS MANY AS 5 DOSE LINES WITH A +C RESET VALUE. ALSO, WITHIN EACH LINE, A DOSE AND/OR A COVARIATE + +C COULD HAVE A RESET TIME OF 0. THEREFORE EACH BLOCK OF CODE BELOW, +C FOR EACH DRUG NO. AND EACH COVARIATE, IS TESTED FOR A TIME RESET, +C AND IN EACH CASE, EXTRA LINES ARE POTENTIALLY ADDED TO THE OUPUT +C ARRAYS. TO PREVENT MORE EXTRA LINES (OF OUTPUT VALUES = -99 AT +C TIMES = 0) THAN ARE NECESSARY, INITIALIZE NRESETADD = 0. THIS +C TELLS THE PROGRAM THAT NO EXTRA LINES HAVE BEEN ADDED TO THE OUTPUT +C ARRAYS SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE +C ARRAYS. NRESETADD WILL BE CHANGED TO 1 WHENEVER EXTRA LINES HAVE +C BEEN ADDED TO THE OUTPUT ARRAYS, AND THEN BACK TO 0 WHENEVER ANOTHER +C ACTUAL OUTPUT VALUE HAS BEEN PUT INTO AN ARRAY. + + NRESETADD = 0 + +C INITIALIZE NRESET TO 0. IT WILL BE THE NO. OF TIME RESETS THAT +C HAVE OCCURRED UP TO ANY TIME. ALSO INITIALIZE TIMERESET = 0; THIS +C WILL BE THE RUNNING TIME TO BE ADDED TO EACH ACTUAL TIME. IT WILL +C ALWAYS BE SET = TIMADD*NRESET BELOW. + + + NRESET = 0 + TIMERESET = TIMADD*NRESET + +C ALSO INITIALIZE NRESETLAST = -1 (SEE CODE BELOW). + + NRESETLAST = -1 + DOSELINEST(NSUB,1,100) = -99 + +C DOSELINE(NSUB,1,100) IS INITIALIZED TO BE -99. IF IT CHANGES BELOW +C TO BE .GE. 0, IT MEANS THAT THERE IS AT LEAST ONE STEADY STATE DOSE +C SET, AND THE FIRST ONE OCCURS AT THE VALUE OF NRESET = +C DOSELINEST(NSUB,1,100). + + +C VERIFY THAT THE 2ND VALUE (I.E., AFTER COMMA NO. 1), WHICH IS THE +C EVENT ID, IDEVENT, IS 1 SINCE THE FIRST EVENT FOR EACH SUBJECT +C SHOULD BE 1 (A NON-TIME-RESET DOSE EVENT). + + CALL AFTERCOMMA(NCOVA,READLINE,1) + BACKSPACE(57) + READ(57,*) IDEVENT + CLOSE(57) + + IF(IDEVENT .NE. 1) THEN + + + + WRITE(*,402) SUBARRAY(NSUB),IDEVENT + 402 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ + 1 1X,A11,', THE FIRST EVENT ID IS NOT 1 AS REQUIRED. IT IS ',I3/ + 3' THE PROGRAM STOPS.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,402) SUBARRAY(NSUB),IDEVENT + CLOSE(47) + + + + + CALL PAUSE + STOP + + + + ENDIF + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SUBID .NE. SUBIDPREV) CONDITION. + + +C THE 2ND VALUE (I.E., AFTER COMMA NO. 1) IS THE EVENT ID, IDEVENT +C (SEE ABOVE). + + CALL AFTERCOMMA(NCOVA,READLINE,1) + BACKSPACE(57) + READ(57,*) IDEVENT + CLOSE(57) + +C IF THE ID OF THIS EVENT IS NO. 4, IT IS A TIME RESET EVENT. IN THIS +C CASE, INCREASE NRESET AND TIMERESET AS INDICATED ABOVE. + + + IF(IDEVENT .EQ. 4) THEN + +C AS OF BESTDOS119.FOR, STOP THE PROGRAM IF THE PATIENT DATA FILE +C HAS AN IDEVENT OF 4. + + WRITE(*,502) + 502 FORMAT(/' YOUR PATIENT DATA FILE HAS AN EVENT OF 4, WHICH '/ + 1' INDICATES A DOSE RESET. DOSE RESETS ARE NOT ALLOWED. THE '/ + 2' PROGRAM STOPS. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,502) + CLOSE(47) + + CALL PAUSE + STOP + + NRESET = NRESET + 1 + TIMERESET = TIMADD*NRESET + ENDIF + + +C THE 3RD VALUE (I.E., AFTER COMMA NO. 2) IS THE TIME OF THE EVENT. +C READ THIS VALUE NOW. + + + CALL AFTERCOMMA(NCOVA,READLINE,2) + BACKSPACE(57) + READ(57,*) TIMEVENT + CLOSE(57) + + + IF(TIMEVENT .LT. 0.D0) THEN + + +C STORE INTO DOSELINEST(.,.,.) ALL THE INFO FOR THE WORKING COPY FILE +C FOR THIS STEADY STATE DOSE SET. + + +C COMPARE NRESET WITH THE PREVIOUS VALUE OF NRESET WHEN THIS PART OF + +C THE CODE WAS USED: IF THEY ARE THE SAME, THIS LINE WILL PROVIDES +C MORE INFO (FOR A DIFFERENT DRUG NO.) FOR THE SAME STEADY STATE DOSE +C EVENT TO BE PUT INTO THE WORKING COPY FILE. IF THEY ARE DIFFERENT, +C THIS LINE IS THE FIRST LINE OF A NEW STEADY STATE DOSE SET. + + + IF(NRESET .GT. NRESETLAST) THEN + +C PUT IN NEW INFO FOR A NEW LINE (FOR A NEW STEADY STATE DOSE SET). +C THIS LINE IS THE FIRST LINE WITH INFO ON A NEW STEADY STATE DOSE SET. +C STORE ALL THE INFO FROM THIS LINE, INCLUDING NRESET, SO SUBROUTINE +C WRITEDOS CAN WRITE THE INFO FOR THIS LINE SEPARATELY. NOTE THAT THIS +C LINE WILL NOT BE A PART OF THE LOGIC BELOW WHICH STORES ALL DOSE +C INFO, AND THEN SORTS IT BY TIME. NOTE THAT NRESET IS STORED INTO +C ENTRY 100 FOR THIS LINE. + + NSST(NSUB) = NSST(NSUB) + 1 + + IF(NSST(NSUB) .GT. 99) THEN + + + WRITE(*,172) NSUB + 172 FORMAT(/' FOR SUBJECT NO. ',I5,' THE NO. OF STEADY STATE DOSE'/ + 1' SETS IS MORE THAN 99, THE MAXIMUM ALLOWED. PLEASE RERUN THE'/ + 2' PROGRAM AFTER REDUCING THE NO. OF STEADY STATE DOSE SETS TO'/ + 3' NO MORE THAN 99.'// + 4' THE PROGRAM STOPS.'/) + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,172) NSUB + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + DOSELINEST(NSUB,NSST(NSUB),100) = NRESET + + +C TIMEVENT IS THE NEGATIVE OF THE INTERDOSE INTERVAL, WHICH WILL SHOW +C UP IN THE TIME COLUMN OF THE WORKING COPY FILE. + + DOSELINEST(NSUB,NSST(NSUB),1) = TIMEVENT + +C ZERO OUT ALL THE IV AND BOLUS ENTRIES FOR ALL POSSIBLE DRUGS +C (I.E., THERE COULD BE AS MANY AS 7 DRUGS). + + DO I = 1,7 + + DOSELINEST(NSUB,NSST(NSUB),2*I) = 0.D0 + DOSELINEST(NSUB,NSST(NSUB),2*I+1) = 0.D0 + END DO + + +C STORE ANY COVARIATE INFO INTO THE COVARIATE ENTRIES. NOTE IT IS NOT +C KNOWN AT THIS POINT HOW MANY TOTAL DRUGS ARE USED IN THE MODEL SINCE +C THE VALUE FOR NDRUG HAS NOT YET FINISHED UPDATING (IN THE CODE BELOW, +C IT IS SET = IDRUGNO IF NDRUG .LT. IDRUGNO). SO, THE COVARIATE VALUES +C WILL BE STORED FAR ENOUGH OUT IN THE DOSELINEST(.,.,.) ARRAY TO NOT +C INTERFERE WITH THE ENTRIES FOR THE MAXIMUM NO. OF POSSIBLE DRUGS. +C SINCE THERE ARE AT MOST 7 POSSIBLE DRUGS, ENTRIES 2,3,...,14,15 WILL +C BE RESERVED FOR THESE DRUG VALUES, AND THE COVARIATE VALUES WILL +C START WITH ENTRY NO. 20. + + + IF(NCOVA .GT. 0) THEN + + DO 110 ICOV = 1,NCOVA + CALL AFTERCOMMA(NCOVA,READLINE,11+ICOV) + BACKSPACE(57) + READ(57,*,ERR=95) COVVAL + CLOSE(57) + DOSELINEST(NSUB,NSST(NSUB),19+ICOV) = COVVAL + + GO TO 110 + 95 DOSELINEST(NSUB,NSST(NSUB),19+ICOV) = -99.D0 + 110 CONTINUE + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE IF(NCOVA .GT. 0) CONDITION. + + +C FOR BESTDOS103A.FOR, ADD LOGIC FOR EXTRA OBS. LINE WITH VALUES OF +C -99'S. + +C THIS IS EITHER A TIME RESET EVENT, OR THE TOP OF THE PATIENT'S FILE. + +C IF IT IS THE TOP OF THE PATIENT'S FILE, NRESET WILL = 0. IF IT IS A + +C TIME RESET EVENT, NRESET WILL BE > 0, AND IN THIS CASE, MUST STORE +C VALUES INTO THE OUPUT ARRAYS (SEE LOGIC BELOW) WHICH INDICATE THAT +C SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. + + + IF(NRESET .GT. 0) THEN + DO IOUTEQ = 1,MAXNUMEQ + NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 + TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMERESET + OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 + END DO + ENDIF + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NRESET .GT. NRESETLAST) CONDITION. + + +C ESTABLISH THE DURATION, (4TH VALUE, AFTER THE 3RD COMMA), DOSE (5TH +C VALUE, AFTER THE 4TH COMMA), AND DRUG NO. (6TH VALUE, AFTER THE 5TH +C COMMA) FOR THIS LINE. + + CALL AFTERCOMMA(NCOVA,READLINE,3) + + + BACKSPACE(57) + READ(57,*,ERR=170) DUR + + + CLOSE(57) + + CALL AFTERCOMMA(NCOVA,READLINE,4) + BACKSPACE(57) + READ(57,*,ERR=170) TOTDOS + CLOSE(57) + + CALL AFTERCOMMA(NCOVA,READLINE,5) + BACKSPACE(57) + READ(57,*,ERR=170) IDRUGNO + CLOSE(57) + +C STORE THE IV RATE INTO THE IV ENTRY FOR DRUG NO. IDRUGNO; SIMILARLY, +C STORE THE TOTAL DOSE INTO THE BOLUS ENTRY FOR DRUG NO. IDRUGNO. +C NOTE THAT IF DUR = 0, THIS LINE REPRESENTS A STEADY STATE OF BOLUS +C VALUES. IN THIS CASE, SET THE IV RATE TO 0. + + + IF(DUR .LE. 0.D0) + 1 DOSELINEST(NSUB,NSST(NSUB),2*IDRUGNO) = 0.D0 + IF(DUR .GT. 0.D0) + 1 DOSELINEST(NSUB,NSST(NSUB),2*IDRUGNO) = TOTDOS/DUR + DOSELINEST(NSUB,NSST(NSUB),2*IDRUGNO+1) = TOTDOS + + + +C NOTE THAT COVARIATE VALUES ARE ONLY READ FOR THE FIRST DOSE LINE +C IN A STEADY STATE SET (I.E., WHEN NRESET .GT. NRESETLAST). IT IS +C POSSIBLE THAT THE USER'S .csv FILE HAS A DIFFERENT SET OF COV. VALUES +C FOR EACH LINE (FOR A DIFFERENT DRUG) THAT IS INCLUDED IN THE +C CURRENT STEADY STATE DOSE SET. BUT, THIS WOULD BE A MISTAKE SINCE +C ONLY 1 SET OF COV. VALUES CAN BE USED FOR THE STEADY STATE SET. THE +C FIRST SET OF VALUES WILL BE USED (AND ALL OTHERS WILL BE IGNORED). + +C SET NRESETLAST = NRESET SO IF ANOTHER LINE OF DOSE INFO FOR THE +C CURRENT STEADY STATE SET FOLLOWS, THE PROGRAM WILL KNOW IT IS +C MORE INFO ON THE CURRENT SET, AND NOT NEW INFO ON THE NEXT SET. + + NRESETLAST = NRESET + + GO TO 10 + + + 170 WRITE(*,171) READLINE(1:75) + 171 FORMAT(/' THERE IS AN ERROR IN YOUR BLOCK FORMAT FILE FOR '/ + 1' SUBJECT NO. 1. EITHER THE DURATION, THE DOSE, OR THE '/ + 2' DRUG NUMBER IS MISSING. THE 1ST 75 CHARACTERS OF THE LINE ARE:'/ + 2A75// + 3' THE PROGRAM STOPS.'/) + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,171) READLINE(1:75) + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + CALL PAUSE + STOP + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(TIMEVENT .LT. 0.D0) CONDITION. + + + + TIMEVENT = TIMEVENT + TIMERESET + + +C IF IDEVENT = 0, IT MEANS THAT THIS ROW IS AN OBSERVED VALUE ROW. +C IN THIS CASE, READ THE OBSERVED VALUE INFO. + + IF(IDEVENT .EQ. 0) THEN + + +C THE 7TH ENTRY (AFTER COMMA NO. 6) IS AN OUTPUT VALUE FOR THIS TIME +C IF THERE IS AN ERROR, IT IS ASSUMED THAT THE PROGRAM READ A DOT, +C WHICH WOULD BE INCONSISTENT SINCE IDEVENT = 0 (MEANING THERE SHOULD +C BE AN OUTPUT VALUE ON THE ROW). + + CALL AFTERCOMMA(NCOVA,READLINE,6) + BACKSPACE(57) + READ(57,*,ERR=30) YVAL + CLOSE(57) + +C TO GET TO THIS POINT --> YVAL CONTAINS AN OUTPUT VALUE FOR THIS +C LINE. BEFORE THIS VALUE CAN BE STORED, MUST READ THE OUTPUT EQUATION +C NO. AFTER COMMA NO. 7. + + CALL AFTERCOMMA(NCOVA,READLINE,7) + BACKSPACE(57) + READ(57,*,ERR=30) IOUTEQ + IF(NOUT .LT. IOUTEQ) NOUT = IOUTEQ + CLOSE(57) + +C STORE THIS VALUE. ALSO STORE THE TIME OF THIS EVENT INTO THE ARRAY +C WHICH STORES OUTPUT TIMES. + + NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 + TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT + OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = YVAL + NRESETADD = 0 + +C SEE CODE ABOVE REGARDING NRESEADD. + + GO TO 20 + + + + 30 WRITE(*,31) NSUB, TIMEVENT - TIMERESET + 31 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ + 1' NO. ',I4,' AND TIME ',F10.4, ' A LINE HAS AN EVENT ID OF 0 IN'/ + 2' COL. 2, INDICATING OBSERVED VALUE INFORMATION. BUT THERE IS '/ + 3' EITHER NO OBSERVED VALUE IN COL. 7, OR NO OUTPUT EQUATION NO.'/ + 4' IN ENTRY 8. '// + 3' THE PROGRAM STOPS.') + + WRITE(*,401) NSUB,SUBARRAY(NSUB) + 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,31) NSUB, TIMEVENT - TIMERESET + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + CALL PAUSE + + STOP + + 20 CONTINUE + +C THE 9TH - 12TH ENTRIES FOR THIS ROW POTENTIALLY HOLD NEW ASSAY +C COEFFICIENTS FOR THIS SUBJECT (NSUB) AND OUTPUT EQ. (IOUTEQ). +C READ THESE VALUES. IF THEY ARE NOT MISSING, UPDATE THE ASSAY +C COEFFICIENT INFO FOR THIS SUBJECT/OUTPUT EQ. + +C NOTE THAT THESE ENTRIES SHOULD ALL BE MISSING (DOTS OR n's) OR ALL + +C BE NUMBERS. IF THERE IS A COMBINATION OF MISSING VALUES AND NUMBERS, +C STOP THE PROGRAM AND TELL THE USER. + + IMISSC0 = 0 + IMISSC1 = 0 + IMISSC2 = 0 + IMISSC3 = 0 + + CALL AFTERCOMMA(NCOVA,READLINE,8) + BACKSPACE(57) + + READ(57,*,ERR=230) C00 + CLOSE(57) + + + GO TO 235 + 230 IMISSC0 = 1 + + 235 CALL AFTERCOMMA(NCOVA,READLINE,9) + BACKSPACE(57) + READ(57,*,ERR=240) C11 + CLOSE(57) + + GO TO 245 + 240 IMISSC1 = 1 + + + 245 CALL AFTERCOMMA(NCOVA,READLINE,10) + BACKSPACE(57) + + + READ(57,*,ERR=250) C22 + CLOSE(57) + + GO TO 255 + 250 IMISSC2 = 1 + + 255 CALL AFTERCOMMA(NCOVA,READLINE,11) + BACKSPACE(57) + READ(57,*,ERR=260) C33 + CLOSE(57) + + + GO TO 265 + 260 IMISSC3 = 1 + + 265 CONTINUE + +C IF ALL IMISSCx VALUES ARE 0, UPDATE THE ASSAY C'S FOR THIS +C SUBJECT AND OUTPUT EQ. NO. IF ALL IMISSCx VALUES ARE 1, THEY +C ARE ALL MISSING, SO JUST CONTINUE. IF SOME OF THE IMISSCx VALUES +C ARE 0 AND SOME ARE 1, THIS IS AN INCONSISTENCY (I.E., THE USER HAS +C ENTERED SOME BUT NOT ALL OF THE ASSAY C'S). IN THIS CASE, STOP THE + +C PROGRAM AFTER INFORMING THE USER OF HIS ERROR. + + ISUMC = IMISSC0 + IMISSC1 + IMISSC2 + IMISSC3 + + + + IF(ISUMC .EQ. 0) THEN + CSUB(NSUB,1,IOUTEQ) = C00 + CSUB(NSUB,2,IOUTEQ) = C11 + CSUB(NSUB,3,IOUTEQ) = C22 + CSUB(NSUB,4,IOUTEQ) = C33 + ENDIF + + + IF(ISUMC .NE. 0 .AND. ISUMC .NE. 4) THEN + + + WRITE(*,231) NSUB, TIMEVENT - TIMERESET,IOUTEQ + 231 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ + 1' NO. ',I4,' AND TIME ',F10.4, ' A LINE HAS AN EVENT ID OF 0 IN'/ + 2' COL. 2, INDICATING OBSERVED VALUE INFORMATION, BUT THIS LINE'/ + 3' HAS AN INCOMPLETE SET OF ASSAY COEFFICIENTS FOR OUTPUT EQ. '/ + 4' NUMBER ',I3,'. THERE MUST BE EITHER 4 ASSAY COEFFICIENTS ON'/ + 5' AN OUTPUT LINE, OR NONE (IF NO OUTPUT LINES FOR A PARTICULAR'/ + 6' SUBJECT x OUTPUT EQ. COMBO HAVE ASSAY COEFFICIENTS, THEN THE'/ + 7' POPULATION COEFFICIENTS WILL BE USED).'// + 8' THE PROGRAM STOPS.') + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,231) NSUB, TIMEVENT - TIMERESET,IOUTEQ + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 0) CONDITION. + + + + IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) THEN + + +C IDEVENT = 1 OR 4 --> DOSE AND/OR COVARITE INFO IS TO BE READ IN. + +C THE 4TH ENTRY (AFTER COMMA NO. 3) IS AN INFUSION DURATION, AND THE +C 5TH ENTRY (AFTER COMMA NO. 4) IS THE TOTAL DOSE ... IF THIS LINE +C HAS DOSE INFORMATION. NOTE THAT IF THERE IS NO DOSE, THE TOTAL DOSE +C ENTRY WILL BE A DOT ("."). ALSO, IF THERE IS A TOTAL DOSE, BUT THE +C INFUSION DURATION IS 0, THIS LINE REPRESENTS A BOLUS INPUT. + +C SO, 1ST TRY READING THE TOTAL DOSE AS A REAL NUMBER; IF THERE IS AN +C ERROR, IT IS ASSUMED THAT THE PROGRAM READ A DOT. + + CALL AFTERCOMMA(NCOVA,READLINE,4) + BACKSPACE(57) + READ(57,*,ERR=40) TOTDOS + CLOSE(57) + +C TO GET TO THIS POINT --> TOTDOS CONTAINS A TOTAL DOSE VALUE FOR THIS +C LINE. READ THE INFUSION DURATION AFTER COMMA NO. 3 TO SEE IF THIS +C DOSE IS AN INFUSION (WITH A POSITIVE DURATION) OR A BOLUS (WITH A +C 0 DURATION). + + CALL AFTERCOMMA(NCOVA,READLINE,3) + BACKSPACE(57) + READ(57,*,ERR=50) DUR + + CLOSE(57) + +C BEFORE THIS VALUE CAN BE STORED, MUST READ THE DRUG NO. AFTER COMMA +C NO. 5. + + CALL AFTERCOMMA(NCOVA,READLINE,5) + BACKSPACE(57) + READ(57,*,ERR=50) IDRUGNO + IF(NDRUG .LT. IDRUGNO) NDRUG = IDRUGNO + CLOSE(57) + +C STORE THE ABOVE VALUES DEPENDING ON WHETHER THEY REPRESENT AN +C INFUSION OR A BOLUS INPUT. + +C INCREASE THE NO. OF DOSAGE LINES FOR THIS SUBJECT. IF DUR > 0, THE +C NO. OF DOSAGE LINES INCREASES BY 2 SINCE THERE WILL BE A START TIME +C AND AN ENDING TIME. IF DUR = 0, THE NO. OF DOSAGE LINES WILL INCREASE +C BY 1. + + + IF(DUR .GT. 0) THEN + +C THE INFUSION RATE IS TOTDOS/DUR. SO THE DOSE VALUE THE 1ST DOSE +C TIME BELOW WILL BE THIS INFUSION RATE, AND THE DOSE VALUE AT THE + +C 2ND DOSE TIME BELOW WILL BE 0. + +C NOTE THAT EVERYTIME NTIMALL(NSUB) IS INCREASED, THE PROGRAM CHECKS +C THAT IT HAS NOT GONE PAST 72000. IF SO, A MESSAGE TO THE USER IS + + +C WRITTEN THAT THIS IS NOT ALLOWED AND THE PROGRAM STOPS. + + + NTIMALL(NSUB) = NTIMALL(NSUB) + 1 + + IF(NTIMALL(NSUB) .GT. 72000) THEN + + + WRITE(*,3001) NSUB + 3001 FORMAT(/' THE NO. OF LINES IN THE DOSAGE REGIMEN FOR SUBJECT'/ + 1' NO. ',I5,' IS MORE THAN THE LIMIT OF 72000. PLEASE RERUN THE'/ + 2' PROGRAM AFTER REDUCING THIS NO. TO BE LESS THAN 72000.'/) + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,3001) NSUB + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT + + + IF(IDEVENT .EQ. 4) THEN + +C SEE FORMAT 502 ABOVE. IDEVENT = 4 IS DISALLOWED EXPLICITLY AS OF +C BESTDOS119.FOR. + +C IF IDEVENT = 4, IT MEANS THAT THIS IS A TIME RESET POINT (I.E., A +C TIME IN THE DISTANT FUTURE WHICH WILL SHOW UP AS T = 0 IN THE +C WORKING COPY FORMAT FILE). IN THIS CASE, IF NRESETADD = 0, ADD +C VALUES TO NTIMOUT, TIMOUT, AND OUT FOR EACH OF THE MAXNUMEQ POSSIBLE +C OUTPUT EQUATIONS (THERE ARE NOUT OUTPUT EQUATIONS SO FAR, BUT IN + + +C SUBSEQUENT ROWS, NOUT COULD INCREASE TO AT MOST MAXNUMEQ) TO +C INDICATE THAT ANY OUTPUTS FOLLOWING THIS TIME ARE BASED ON THE TIME +C RESET. TO DO THIS, PUT IN THE CURRENT TIME IN TIMOUT, AND A +C CORRESPONDING VALUE OF -99 (MISSING VALUE), FOR EACH OUTPUT EQUATION. + + +C STORE VALUES INTO THE OUPUT ARRAYS (TIME = 0 AND VALUE = -99) WHICH +C INDICATE THAT SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. +C ... BUT ONLY STORE THESE EXTRA VALUES IF NRESETADD = 0. IF +C NRESETADD = 1, IT MEANS THAT THESE LINES HAVE ALREADY BEEN ADDED +C SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE OUTPUT +C ARRAYS. + + IF(NRESETADD .EQ. 0) THEN + DO IOUTEQ = 1,MAXNUMEQ + NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 + TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT + OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 + END DO + NRESETADD = 1 + ENDIF + + ENDIF + + + +C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 4) CONDITION. + + +C IF THE CURRENT TIME IS THE SAME AS THE ENDING TIME OF THE PREVIOUS +C IV, DO NOT INCREASE NTIMIV(.,.) BELOW, BECAUSE THE NEW STARTING IV +C RATE MUST REPLACE THE 0.0 FROM THE ENDING OF THE PREVIOUS IV. + + ISAME = 0 + IF(NTIMIV(NSUB,IDRUGNO) .GT. 0) + 1 CALL THESAME(TIMEVENT,TIMIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)), + 2 ISAME) + + IF(ISAME .EQ. 0) NTIMIV(NSUB,IDRUGNO) = NTIMIV(NSUB,IDRUGNO) + 1 + TIMIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = TIMEVENT + RATEIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = TOTDOS/DUR + + NTIMALL(NSUB) = NTIMALL(NSUB) + 1 + + + IF(NTIMALL(NSUB) .GT. 72000) THEN + + + WRITE(*,3001) NSUB + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,3001) NSUB + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT + DUR + NTIMIV(NSUB,IDRUGNO) = NTIMIV(NSUB,IDRUGNO) + 1 + TIMIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = TIMEVENT + DUR + RATEIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = 0.D0 + + ENDIF + + + +C THE ABOVE ENDIF IS FOR THE IF(DUR .GT. 0) CONDITION. + + + + IF(DUR .LE. 0) THEN + + + +C STORE THE BOLUS VALUE AT THE INDICATED TIME, TIMEVENT. + + + NTIMALL(NSUB) = NTIMALL(NSUB) + 1 + + IF(NTIMALL(NSUB) .GT. 72000) THEN + + WRITE(*,3001) NSUB + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,3001) NSUB + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + + CALL PAUSE + STOP + + + + ENDIF + + TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT + + + + IF(IDEVENT .EQ. 4) THEN + +C SEE LOGIC ABOVE FOR TIME RESET LOGIC, AND ADDING LINES TO THE +C OUTPUT EQUATION VALUES IN THAT CASE. + +C STORE VALUES INTO THE OUPUT ARRAYS (SEE LOGIC ABOVE) WHICH +C INDICATE THAT SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. +C ... BUT ONLY STORE THESE EXTRA VALUES IF NRESETADD = 0. IF +C NRESETADD = 1, IT MEANS THAT THESE LINES HAVE ALREADY BEEN ADDED +C SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE OUTPUT +C ARRAYS. + + IF(NRESETADD .EQ. 0) THEN + DO IOUTEQ = 1,MAXNUMEQ + NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 + TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT + OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 + END DO + NRESETADD = 1 + ENDIF + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 4) CONDITION. + + NTIMBOL(NSUB,IDRUGNO) = NTIMBOL(NSUB,IDRUGNO) + 1 + TIMBOL(NSUB,IDRUGNO,NTIMBOL(NSUB,IDRUGNO)) = TIMEVENT + BOLUS(NSUB,IDRUGNO,NTIMBOL(NSUB,IDRUGNO)) = TOTDOS + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE IF(DUR .LE. 0) CONDITION. + + + GO TO 40 + + + 50 WRITE(*,51) NSUB, TIMEVENT - TIMERESET + 51 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ + 1' NO. ',I4,' AND TIME ',F10.4,' A LINE HAS A DOSAGE AMT., BUT NO'/ + 2' DURATION (EVEN A BOLUS SHOULD HAVE A DURATION OF 0) IN '/ + 3' ENTRY 4., OR NO DRUG NO. IN ENTRY 5.'// + 3' THE PROGRAM STOPS.') + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,51) NSUB, TIMEVENT - TIMERESET + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + CALL PAUSE + + + STOP + + + 40 CONTINUE + + +C READ IN ANY COVARIATE VALUES IF NCOVA .GT. 0. + + IF(NCOVA .GT. 0) THEN + + + DO 60 ICOV = 1,NCOVA + + CALL AFTERCOMMA(NCOVA,READLINE,11+ICOV) + BACKSPACE(57) + READ(57,*,ERR=70) COVVAL + CLOSE(57) + + + +C TO GET TO THIS POINT --> COVVAL REPRESENTS THE VALUE OF COV. NO. +C ICOV. STORE IT AT THE INDICATED TIME, TIMEVENT. + + NTIMALL(NSUB) = NTIMALL(NSUB) + 1 + + IF(NTIMALL(NSUB) .GT. 72000) THEN + + + WRITE(*,3001) NSUB + WRITE(*,401) NSUB,SUBARRAY(NSUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,3001) NSUB + WRITE(47,401) NSUB,SUBARRAY(NSUB) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT + + + + IF(IDEVENT .EQ. 4) THEN + + +C SEE LOGIC ABOVE FOR TIME RESET LOGIC, AND ADDING LINES TO THE +C OUTPUT EQUATION VALUES IN THAT CASE. + +C STORE VALUES INTO THE OUPUT ARRAYS (TIME = 0 AND VALUE = -99) WHICH +C INDICATE THAT SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. + +C ... BUT ONLY STORE THESE EXTRA VALUES IF NRESETADD = 0. IF +C NRESETADD = 1, IT MEANS THAT THESE LINES HAVE ALREADY BEEN ADDED +C SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE OUTPUT +C ARRAYS. + + IF(NRESETADD .EQ. 0) THEN + DO IOUTEQ = 1,MAXNUMEQ + NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 + TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT + OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 + END DO + NRESETADD = 1 + ENDIF + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 4) CONDITION. + +C SINCE MULTIPLE DOSE LINES CAN OCCUR AT THE SAME TIME (DEFINING + +C DOSES FOR DIFFERENT DRUGS OR IV VS. BOLUS VALUES, IT IS POSSIBLE +C THAT A COVARIATE VALUE IS BEING RESET AT THE SAME TIME AS IN A +C PREVIOUS LINE. IF THIS IS TRUE, TELL THE USER THAT THE COVARIATE +C VALUE FROM THE FIRST LINE WILL BE USED. THIS MUST BE CHECKED ONLY +C IF THE INDEX OF THE NO. OF COVARIATE VALUES IS > 0 - OTHERWISE +C THIS IS THE FIRST LINE WITH A COVARIATE VALUE ON IT). + +C BUT, ONLY WRITE THIS WARNING IF THE TWO COVARIATE VALUES ARE +C ACTUALLY DIFFERENT, BECAUSE IF THEY ARE THE SAME, THERE IS NO +C CONFLICT, JUST REDUNDANCY. + + + + IF(NTIMCOV(NSUB,ICOV) .GT. 0) THEN + + CALL THESAME(TIMEVENT,TIMCOV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)), + 1 ISAMETIME) + + CALL THESAME(COVVAL,COV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)), + 1 ISAMECOV) + + IF(ISAMETIME .EQ. 1 .AND. ISAMECOV .EQ. 1) GO TO 60 + + IF(ISAMETIME .EQ. 1 .AND. ISAMECOV .EQ. 0) THEN + WRITE(*,41) NSUB,TIMEVENT-TIMERESET,ICOV, + 1 COV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)),COVVAL + 41 FORMAT(/' FOR SUBJECT, 'I2,' AT TIME ',G14.7,', COVARIATE'/ + 1' NO. ',I2,' WAS SET TO BOTH ',G14.7,' AND ',G14.7,'. YOU SHOULD'/ + 2' CHECK YOUR BLOCK FILE. FOR NOW, THE FIRST VALUE WILL BE USED.') + + GO TO 60 + ENDIF + + ENDIF + + + + NTIMCOV(NSUB,ICOV) = NTIMCOV(NSUB,ICOV) + 1 + TIMCOV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)) = TIMEVENT + COV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)) = COVVAL + + GO TO 60 + + 70 CONTINUE + +C TO GET TO LABEL 70 --> THERE WAS NO NUMBER IN THE ENTRY FOR + + +C COVARIATE, ICOV. + + 60 CONTINUE + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NCOVA .EQ. 0) CONDITION. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) +C CONDITION. + + +C RETURN TO LABEL 10 TO READ THE NEXT LINE IN THE BLOCK PATIENT +C DATA FILE. + + + GO TO 10 + + + 100 NSUB = 1 + + + IF(NCOVA .GT. 0) THEN + + +C IF IGUI = 1, IT MEANS THAT THIS PROGRAM IS BEING RUN WITHOUT ANY +C USER INTERACTION, AND ALL THE INFO IS INCLUDED IN THE FILE + +C 'GUICMDS.INX', WHICH IS CURRENTLY OPENED AS FILE 23. IN THIS CASE, +C SKIP THE KEYBOARD INPUTTING OF ICOVTYPE(.) BELOW, AND INSTEAD READ +C THESE VALUES FROM THE PREVIOUS LINE OF FILE 23. + + +C IF IGUI = 0, IT MEANS THAT THIS PROGRAM IS BEING RUN THE STANDARD +C WAY, WITH USER INTERACTION. IN THIS CASE, INPUT ICOVTYPE(.) FROM +C THE USER VIA THE KEYBOARD. + + IF(IGUI .EQ. 1) THEN + BACKSPACE(23) + READ(23,*) (ICOVTYPE(ICOV),ICOV=1,NCOVA) + ENDIF + + + IF(IGUI .EQ. 0) THEN + + + + IF(IWHICH .EQ. 1) WRITE(*,111) NCOVA + 111 FORMAT(/' YOUR BLOCK FORMAT PATIENT INFORMATION FILE, WHICH'/ + 1' HAS THE "PAST" INFORMATION ON YOUR SUBJECT, SHOWS'/ + 1' ',I2,' COVARIATES. EACH COVARIATE MUST BE SPECIFIED TO BE '/ + + + 2' EITHER A PIECEWISE CONSTANT COVARIATE OR AN INTERPOLATED '/ + 3' COVARIATE.'// + 4' A PIECEWISE CONSTANT COVARIATE WILL HAVE THE SAME VALUE FROM'/ + 5' ONE EXPLICITLY CODED VALUE, THROUGH ALL INTERVEENING DOSE'/ + 6' TIMES, TO THE NEXT EXPLICITLY CODED VALUE (WHEN IT WILL CHANGE). + 7 '// + 8' AN INTERPOLATED COVARIATE WILL HAVE INTERPOLATED VALUES FROM'/ + 9' ONE EXPLICITY CODED VALUE, THROUGH ALL INTERVEENING DOSE '/ + 1' TIMES, TO THE NEXT EXPLCITLY CODED VALUE.'//) + + + IF(IWHICH .EQ. 2) WRITE(*,117) NCOVA + 117 FORMAT(/' YOUR BLOCK FORMAT PATIENT INFORMATION FILE, WHICH'/ + 1' HAS THE "FUTURE" INFORMATION ON YOUR SUBJECT, SHOWS'/ + 1' ',I2,' COVARIATES. EACH COVARIATE MUST BE SPECIFIED TO BE '/ + 2' EITHER A PIECEWISE CONSTANT COVARIATE OR AN INTERPOLATED '/ + 3' COVARIATE.'// + 4' A PIECEWISE CONSTANT COVARIATE WILL HAVE THE SAME VALUE FROM'/ + 5' ONE EXPLICITLY CODED VALUE, THROUGH ALL INTERVEENING DOSE'/ + 6' TIMES, TO THE NEXT EXPLICITLY CODED VALUE (WHEN IT WILL CHANGE). + 7 '// + 8' AN INTERPOLATED COVARIATE WILL HAVE INTERPOLATED VALUES FROM'/ + 9' ONE EXPLICITY CODED VALUE, THROUGH ALL INTERVEENING DOSE '/ + 1' TIMES, TO THE NEXT EXPLCITLY CODED VALUE.'//) + + + + DO ICOV = 1,NCOVA + 130 WRITE(*,112) COVNAME(ICOV) + 112 FORMAT(/' FOR COVARIATE ',A11/ + 1' ENTER 1 IF IT IS TO BE PIECEWISE CONSTANT; '/ + 2' ENTER 2 IF IT IS TO BE INTERPOLATED: ') + + READ(*,*,ERR=130) ITYPE + + IF(ITYPE .NE. 1 .AND. ITYPE .NE. 2) GO TO 130 + ICOVTYPE(ICOV) = ITYPE + END DO + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IGUI .EQ. 0) CONDITION. + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NCOVA .GT. 0) CONDITION. + + + + +C WRITE OUT ALL THE INFO IN THE ABOVE ARRAYS INTO A WORKING COPY +C FORMAT. ACTUALLY, FOR NOW, JUST TRY TO CREATE THE DOSAGE AND +C OBSERVATION PART OF A FILE SIMILAR TO 2DRUG001 (I.E., DON'T +C WORRY NOW ABOUT THE TOP PART OF THE FILE, OR THE BOTTOM). + + +C FIRST, CALL SUBROUTINE GETCHAR2 TO ESTABLISH THE NUMBER ARRAY. + + DO JSUB = 1,NSUB + CALL GETCHAR2(JSUB,CHARSUB) + NUMBER(JSUB) = CHARSUB + END DO + + + DO 1000 ISUB = 1,NSUB + +C NOTE THAT THE WORKING COPY SUBJECTS WILL BE PLACED INTO THE +C WORKING DIRECTORY. THE PREFIX WILL BE HARDCODED TO 'XQZPJ', AND THE +C SUFFIX TO 'PST' IF IWHICH = 1, AND TO 'FUT' IF IWHICH = 2. + + IF(IWHICH .EQ. 1) PATFIL = 'XQZPJ'//NUMBER(ISUB)//'.PST' + IF(IWHICH .EQ. 2) PATFIL = 'XQZPJ'//NUMBER(ISUB)//'.FUT' + + +C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE +C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE +C CURRENT DIRECTORY). + + TMPFILE = ' ' + TMPFILE = PATFIL + CALL FULLNAME(PATH,TMPFILE,PATHFILE) + + + OPEN(33,FILE=PATHFILE) + + IF(NDRUG .GT. 7) THEN + + + + WRITE(*,101) NDRUG + 101 FORMAT(/' NO. OF DRUGS IN THIS PATIENT DATA SET IS ',I2/ + 1' THIS IS MORE THAN 7, THE MAXIMUM --> PROGRAM STOPS.'/) + WRITE(*,401) ISUB,SUBARRAY(ISUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,101) NDRUG + WRITE(47,401) ISUB,SUBARRAY(ISUB) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + IF(NOUT .GT. MAXNUMEQ) THEN + + + + WRITE(*,106) NOUT,MAXNUMEQ + 106 FORMAT(/' NO. OF OUTPUT EQS. THIS PATIENT DATA SET IS ',I2/ + 1' THIS IS MORE THAN THE MAX. ALLOWED VALUE OF ',I2,'. SO THE'/ + 2' PROGRAM STOPS.'/) + WRITE(*,401) ISUB,SUBARRAY(ISUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,106) NOUT,MAXNUMEQ + WRITE(47,401) ISUB,SUBARRAY(ISUB) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + IF(NCOVA .GT. 26) THEN + + WRITE(*,103) NCOVA + 103 FORMAT(/' NO. OF COVARIATES IN THIS PATIENT DATA SET IS ',I3/ + 1' THIS IS MORE THAN 26, THE MAXIMUM --> PROGRAM STOPS.'/) + WRITE(*,401) ISUB,SUBARRAY(ISUB) + + OPEN(47,FILE=ERRFIL) + WRITE(47,103) NCOVA + + + WRITE(47,401) ISUB,SUBARRAY(ISUB) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + +C BEFORE CALLING WRITEDOS, CALL TIMESET FOR THIS SUBJECT TO +C ELIMINATE ALL THE DUPLICATE TIMES IN TIMALL(ISUB,.). THERE COULD BE +C DUPLICATE TIMES BECAUSE NTIMALL(ISUB) WAS INCREASED BY 1 FOR EACH +C BOLUS, IV, OR COVARIATE VALUE, AND SOME OF THESE VALUES OCCUR AT THE +C SAME TIME. TIMESET ALSO ORDERS THE TIMES AND THEY COULD BE OUT OF +C ORDER DUE TO AN IV RATE WHOSE DURATION RESULTS IN THE ENDING TIME +C BEING PAST THE NEXT DOSE EVENT. + +C TIMESET RETURNS THE COMPLETE SET OF TIMES FOR THIS SUBJECT'S DOSAGE +C REGIMEN IN TIMI (AND THERE ARE NTIMI OF THEM). + + CALL TIMESET(MAXSUB,ISUB,SUBARRAY(ISUB),NTIMALL,TIMALL,NTIMI, + 1 TIMI) + + + +C CALL WRITEDOS TO WRITE THE PATIENT INFO TO PATHFILE = FILE 33. + + CALL WRITEDOS(ISUB,NTIMIV,TIMIV,RATEIV,NTIMBOL,TIMBOL,BOLUS, + 1 NTIMCOV,TIMCOV,COV,ICOVTYPE,NDRUG,NCOVA,NOUT,NTIMOUT, + 2 TIMOUT,OUT,SUBARRAY(ISUB),COVNAME,MAXSUB,NTIMI,TIMI,TIMADD, + 3 CSUB,NSST,DOSELINEST) + + + 1000 CONTINUE + + + RETURN + + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE AFTERCOMMA(NCOVA,READLINE,NCOMMA) + CHARACTER READLINE*1000,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C OPEN AND WRITE INTO SCRATCH FILE 57 THE PART OF READLINE THAT +C IS BETWEEN COMMAS NCOMMA AND NCOMMA+1 ... UNLESS NCOMMA IS THE MAX. +C NO. OF COMMAS (11+NCOVA). IN THIS CASE, WRITE INTO SCRATCH FILE 57 THE + +C PART OF READLINE THAT FOLLOWS COMMA NCOMMA (SINCE THERE WILL NOT BE +C ANOTHER COMMA). + + 1 FORMAT(A1000) + +C IF NCOMMA = 0, SET ISTART = 0 AND GO TO LABEL 10. + + IF(NCOMMA .EQ. 0) THEN + ISTART = 0 + GO TO 10 + ENDIF + + + ICOMMA = 0 + + DO ISTART = 1,300 + + IF(READLINE(ISTART:ISTART) .EQ. ',') THEN + + ICOMMA = ICOMMA + 1 + IF(ICOMMA .EQ. NCOMMA) GO TO 10 + ENDIF + END DO + + + + +C TO GET TO THIS POINT MEANS THAT THE NO. OF COMMAS IN LINE +C READLINE IS LESS THAN NCOMMA. WRITE A MESSAGE AND STOP. + + WRITE(*,2) NCOMMA,ICOMMA,READLINE + 2 FORMAT(/' THE FOLLOWING LINE WAS SUPPOSED TO HAVE AT LEAST ',I3/ + 1' COMMAS, BUT IT HAD ONLY ',I3,' SO THE PROGRAM STOPS.'// + 2A1000) + + OPEN(47,FILE=ERRFIL) + WRITE(47,2) NCOMMA,ICOMMA,READLINE + CLOSE(47) + + + + CALL PAUSE + STOP + + +C TO REACH LABEL 10, ISTART IS NOW THE COLUMN NO. WHICH HAS THE +C NCOMMAth COMMA IN LINE READLINE. FIND IEND, WHICH IS THE COLUMN NO. +C WHICH HAS THE NCOMMA+1 ST COMMA IN THE LINE. THEN WRITE THE PORTION +C OF READLINE WHICH IS BETWEEN ISTART AND IEND INTO FILE57. + + 10 ICOMMA = 0 + + DO IEND = 1,300 + IF(READLINE(IEND:IEND) .EQ. ',') THEN + ICOMMA = ICOMMA + 1 + IF(ICOMMA .EQ. NCOMMA+1) GO TO 20 + ENDIF + END DO + +C TO GET TO THIS POINT MEANS THAT THE NO. OF COMMAS IN LINE +C READLINE IS LESS THAN NCOMMA+1. THIS IS OK IF NCOMMA IS THE MAXIMUM +C NO. OF COMMAS, WHICH IS 11+NCOVA. OTHERWISE, WRITE A MESSAGE AND +C STOP. + + IF(NCOMMA .LT. 11 + NCOVA) THEN + + + + WRITE(*,2) NCOMMA+1,ICOMMA,READLINE + + OPEN(47,FILE=ERRFIL) + WRITE(47,2) NCOMMA+1,ICOMMA,READLINE + CLOSE(47) + + + + + CALL PAUSE + STOP + + + + ENDIF + + IF(NCOMMA .EQ. 11 + NCOVA) IEND = 301 + +C???DEBUG. NOTE THAT SOMETIMES, WHEN THIS PROGRAM IS COMPILED/LINKED +C WITH gfortran, IT PRODUCES AN ERROR RELATED TO FILE 57. THIS ERROR +C HAPPENS RANDOMLY, AND MAY BE ABLE TO BE REMOVED BY CHANGING FROM +C OPEN(57) TO OPEN(57,FILE='FILE57JUNK'). +C AS OF BESTDOS111.FOR, CHANGE TO OPEN(57,FILE='FILE57JUNK') BECAUSE +C MORE 'CANNOT OPEN' ERRORS RELATED TO FILE 57 HAVE BEEN OBSERVED. + + 20 OPEN(57,FILE='FILE57JUNK') + +C SEE CODE AT TOP OF MONTBG100.FOR TO SEE WHY FORMATTED WRITE +C STATEMENTS ARE USED (UNLESS NUMCHAR BELOW IS > 11, IN WHICH CASE + +C A FREE FORMAT WRITE STATEMENT IS STILL USED). + + NUMCHAR = IEND - ISTART - 1 + + IF(NUMCHAR .EQ. 1) WRITE(57,101) READLINE(ISTART+1:IEND-1) + 101 FORMAT(A1) + + IF(NUMCHAR .EQ. 2) WRITE(57,102) READLINE(ISTART+1:IEND-1) + 102 FORMAT(A2) + + IF(NUMCHAR .EQ. 3) WRITE(57,103) READLINE(ISTART+1:IEND-1) + 103 FORMAT(A3) + + IF(NUMCHAR .EQ. 4) WRITE(57,104) READLINE(ISTART+1:IEND-1) + 104 FORMAT(A4) + + IF(NUMCHAR .EQ. 5) WRITE(57,105) READLINE(ISTART+1:IEND-1) + 105 FORMAT(A5) + + IF(NUMCHAR .EQ. 6) WRITE(57,106) READLINE(ISTART+1:IEND-1) + 106 FORMAT(A6) + + IF(NUMCHAR .EQ. 7) WRITE(57,107) READLINE(ISTART+1:IEND-1) + 107 FORMAT(A7) + + IF(NUMCHAR .EQ. 8) WRITE(57,108) READLINE(ISTART+1:IEND-1) + + 108 FORMAT(A8) + + + IF(NUMCHAR .EQ. 9) WRITE(57,109) READLINE(ISTART+1:IEND-1) + 109 FORMAT(A9) + + IF(NUMCHAR .EQ. 10) WRITE(57,110) READLINE(ISTART+1:IEND-1) + 110 FORMAT(A10) + + IF(NUMCHAR .EQ. 11) WRITE(57,111) READLINE(ISTART+1:IEND-1) + 111 FORMAT(A11) + + IF(NUMCHAR .GT. 11) WRITE(57,*) READLINE(ISTART+1:IEND-1) + + + + RETURN + END +C + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE WRITEDOS(ISUB,NTIMIV,TIMIV,RATEIV,NTIMBOL,TIMBOL, + 1 BOLUS,NTIMCOV,TIMCOV,COV,ICOVTYPE,NDRUG,NCOVA,NOUT,NTIMOUT, + 2 TIMOUT,OUT,SUBID,COVNAME,MAXSUB,NTIMI,TIMI,TIMADD,CSUB,NSST, + 3 DOSELINEST) + + PARAMETER(MAXNUMEQ=7) + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION BOLVAL(7),COVVAL(26),XIVVAL(7),DOSELINE(5200,43), + 1 TIMOUT(MAXSUB,MAXNUMEQ,650),TIMIV(MAXSUB,7,5200), + 2 NTIMOUT(MAXSUB,MAXNUMEQ),NTIMIV(MAXSUB,7),RATEIV(MAXSUB,7,5200), + 3 BOLUS(MAXSUB,7,5200),OUT(MAXSUB,MAXNUMEQ,650), + 4 COV(MAXSUB,26,5200),ICOVTYPE(26),TIMBOL(MAXSUB,7,5200), + 5 NTIMBOL(MAXSUB,7),NTIMCOV(MAXSUB,26),TIMCOV(MAXSUB,26,5200), + 6 INDIV(7),INDBOL(7),INDCOV(26),TIMI(72000),TIMORD(3900), + 7 BLOCKOUT(3900,MAXNUMEQ),CSUB(MAXSUB,4,MAXNUMEQ), + 8 NSST(MAXSUB),DOSELINEST(MAXSUB,99,100),DOSELINES(100) + + CHARACTER SUBID*11,COVNAME(26)*11,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C THIS ROUTINE WRITES THE DOSE EVENTS AND THE OBSERVATION EVENTS OF +C THE PATIENT DATA FILE TO FILE33. NOTE THAT A DOSE EVENT OCCURS +C WHENEVER THERE IS A BOLUS APPLIED, AN IV RATE CHANGE, AND/OR A +C COVARIATE VALUE APPLIED. + + +C----------------- WRITE THE TOP OF FILE BELOW ------------------------- + + WRITE(33,301) SUBID + 301 FORMAT(' LAST AND FIRST NAMES ARE: ',A11) + WRITE(33,302) SUBID + 302 FORMAT(' CHART NUMBER IS: ',A11// + 1' WARD NO, PATIENT AGE (YEARS), SEX, HEIGHT (INCHES),'/ + 2' ETHNICITY FLAG, AND ETHNICITY DESCRIPTION (IF ANY) FOLLOW ON'/ + 3' THE NEXT 6 LINES:'/ + 4'-99'/ + 5'-99'/ + 6'M'/ + 7'-99'/ + 8'1'/ + + 9'Ethnicity Description'// + 1' DATE OF FIRST THERAPY IS 1 1 08'/ + + 2'CCR ML/MIN/ 0.00 150.00'/ + 3'HOURS MG MG/HR MCG/ML KG MG/DL 60 .00 ') + + +C----------------- WRITE THE TOP OF FILE ABOVE ------------------------- + + +C----------------- WRITE THE DOSE EVENTS BELOW ------------------------- + + + WRITE(33,102) NDRUG + 102 FORMAT(/' ',I1,' ... NO. OF DRUGS') + +C NOTE THAT NCOVA IS THE NO. OF COVARIATES IN THE USER'S BLOCK FORMAT +C FILE. THIS AUTOMATICALLY BECOMES NADD, THE NO. OF "ADDITIONAL" +C COVARIATES IN THE WORKING COPY FILE. + + WRITE(33,104) NCOVA + 104 FORMAT(' ',I2,' ... NO. OF ADDITIONAL COVARIATES') + + + +C INCREASE THE NO. OF DOSE EVENTS BY THE NO. OF STEADY STATE DOSE LINES +C THAT WILL BE IN THE FILE (THESE WERE NOT PART OF THE ARRAY EXAMINED +C BY SUBROUTINE TIMESET). + + WRITE(33,2) NTIMI + NSST(ISUB) + 2 FORMAT(' ',I3,' ... NO. OF DOSE EVENTS'// + 1' TIME, IV/PO FOR EACH DRUG; ADDITIONAL COVARIATES IF ANY') + + +C SET THE IVs FOR EACH DRUG TO 0. EACH DRUG IV VALUE STAYS THE SAME +C AS ITS PREVIOUS VALUE UNTIL CHANGED. ALSO INITIALIZE EACH BOLUS + +C VALUE TO 0. + + DO IDRUG = 1,NDRUG + + XIVVAL(IDRUG) = 0.D0 + BOLVAL(IDRUG) = 0.D0 + END DO + +C SET EACH COVARIATE VALUE TO ITS INITIAL VALUE. IT IS ASSUMED THAT +C EACH COV. HAS ITS FIRST VALUE SET AT THE FIRST DOSE TIME (T=0). +C IF THIS IS NOT TRUE, SEE REMARK BELOW WHERE THE COVARIATE VALUES +C ARE SET FOR EACH TIME. + + DO ICOV = 1,NCOVA + COVVAL(ICOV) = COV(ISUB,ICOV,1) + END DO + + +C INITIALIZE THE INDEX OF THE NEXT TIME IN EACH TIME ARRAY TO BE 1. + + DO IDRUG = 1,NDRUG + INDIV(IDRUG) = 1 + INDBOL(IDRUG) = 1 + END DO + + DO ICOV = 1,NCOVA + INDCOV(ICOV) = 1 + END DO + + +C GO THROUGH ALL THE NTIMI DOSAGE BLOCK TIMES IN TIMI AND ESTABLISH ALL +C IV, BOLUS, AND COV. VALUES AT EACH TIME AND WRITE THEM TO THE DOSAGE + +C REGIMEN, BUT NOTE THAT EACH TIME MUST BE REDUCED BY TIMERESET, WHERE +C TIMERESET = TIMADD*NRESET, WHERE NRESET IS THE NO. OF TIME RESETS +C THROUGH THAT TIME (SEE IN READBLOCK THAT TIMERESET WAS ADDED TO EACH +C TIME). + + + + + NRESET = 0 + TIMERESET = TIMADD*NRESET + +C INITIALIZE NSSEVENTS = 1. THIS WILL BE THE INDEX OF THE NEXT STEADY +C STATE DOSE EVENT (IF ANY) IN THE CURRENT PATIENT'S DATA FILE. THE +C TOTAL NO. OF SUCH EVENTS IS NSST(ISUB). + + + NSSEVENTS = 1 + + + + + +C AS OF NPAG104, PUT IN A STEADY STATE LINE AS THE FIRST DOSE EVENT +C IF ONE EXISTS. + +C DOSELINEST(ISUB,1,100) = NRESET, THE NO. OF DOSE RESETS BEFORE THE +C 1ST STEADY STATE DOSE SET. + +C IF DOSELINST(ISUB,1,100) = 0, IT MEANS THAT THERE IS A STEADY STATE +C DOSE SET AT THE TOP OF THE FILE (I.E., BEFORE ANY RESETS). + + +C IF DOSELINEST(ISUB,1,100) IS = -99, IT MEANS THERE ARE NO STEADY +C STATE LINES FOR THIS SUBJECT. + +C IF DOSELINEST(ISUB,1,100) = N > 0, IT MEANS THE FIRST STEADY STATE +C DOSE SET OCCURS AFTER RESET NO. N. + + + CALL THESAME(DOSELINEST(ISUB,1,100),0.D0,ISAME) + + IF(ISAME .EQ. 1) THEN + +C FILL IN THE ENTRIES TO DOSELINE FOR THE STEADY STATE DOSE AT THE +C TOP OF THE PATIENT'S FILE. + +C THE FIRST ENTRY IN DOSELINST IS TIMEVENT = THE NEGATIVE OF THE +C INTERDOSE INTERVAL. + + DOSELINES(1) = DOSELINEST(ISUB,1,1) + + NENTRY = 1 + +C FOR EACH DRUG, THE IV AND TOTAL VALUES ARE ALREADY STORED INTO +C DOSELINEST(ISUB,1,2*I) AND DOSELINEST(ISUB,1,2*I+1), I=1,NDRUG. + + DO IDRUG = 1,NDRUG + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,1,2*IDRUG) + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,1,2*IDRUG+1) + END DO + +C FOR EACH COVARIATE, IF ANY, THE VALUES ARE STORED INTO +C DOSELINEST(ISUB,1,19+ICOV), ICOV = 1,NCOVA. + + IF(NCOVA .GT. 0) THEN + DO ICOV = 1,NCOVA + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,1,19+ICOV) + END DO + ENDIF + + WRITE(33,1) (DOSELINES(J),J=1,NENTRY) + + NSSEVENTS = NSSEVENTS + 1 + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. + + + + DO 1000 ITIM = 1,NTIMI + + + TIME = TIMI(ITIM) + + +C IF THIS TIME = THE NEXT MULTIPLE OF TIMADD, INCREASE THE NO. OF +C RESETS BY 1 AND RECALCULATE TIMERESET, THE CURRENT AMOUNT THAT EACH +C TIME MUST BE REDUCED BEFORE BEING WRITTEN INTO THE WORKING COPY +C FILE. + +C AS OF NPAG104.FOR, THIS TIME COULD BE PAST A TIME RESET POINT. THIS +C WOULD HAPPEN IF A TIME RESET HAD A STEADY STATE DOSE SET ASSOCIATED +C WITH IT, WITHOUT A NON STEADY STATE DOSE IMMEDIATELY FOLLWOING IT (IF +C A NON STEADY STATE DOSE IMMEDIATELY FOLLOWED A STEADY STATE SET, +C THEN THERE WILL BE TIMI(.) ENTRY THAT = TIMADD*(NRESET+1)). IN THIS +C CASE TOO, UPDATE NRESET AND TIMERESET. + +C CALL THESAME HERE TO ESTABLISH THE VALUE FOR ISAMERESET. IT +C WILL USED BELOW TO SUPPRESS INTERPOLATION OF COVARIATES ACROSS A +C TIME RESET. + + CALL THESAME(TIME,TIMADD*(NRESET+1),ISAMERESET) + + + IF(TIME .GE. TIMADD*(NRESET+1)) THEN + +C TIME IS AT OR PAST THE NEXT MULTIPLE OF TIMADD (I.E., IT IS A TIME +C RESET POINT). IN THIS CASE, INCREASE NRESET BY 1 AND RECALCULATE +C TIMERESET. + + NRESET = NRESET + 1 + TIMERESET = TIMADD*NRESET + +C FOR THIS TIME RESET, CHECK TO SEE IF THE FIRST DOSE LINE WILL BE + +C A STEADY STATE DOSE EVENT. THE NO. OF STEADY STATE DOSE EVENTS IN +C THIS PATIENT'S FILE IS NSST(ISUB), AND THE NO. OF SUCH EVENTS THAT +C HAVE ALREADY BEEN WRITTEN TO FILE 33 IS NSSEVENTS-1 SO FAR. + + + + IF(NSSEVENTS .LE. NSST(ISUB)) THEN + +C THE NEXT STEADY STATE DOSE EVENT OCCURS AFTER RESET NO. +C DOSELINEST(ISUB,NSSEVENTS,100). CHECK TO SEE IF THIS VALUE IS +C THE SAME AS NRESET. IF SO, THIS RESET STARTS WITH A STEADY STATE +C LINE. + + XRESET = NRESET + + CALL THESAME(DOSELINEST(ISUB,NSSEVENTS,100),XRESET,ISAME) + + IF(ISAME .EQ. 1) THEN + +C FILL IN THE ENTRIES TO DOSELINE FOR THE STEADY STATE DOSE AT THE +C BEGINNING OF THIS DOSE RESET. + + +C THE FIRST ENTRY IN DOSELINST IS TIMEVENT = THE NEGATIVE OF THE + +C INTERDOSE INTERVAL. + + DOSELINES(1) = DOSELINEST(ISUB,NSSEVENTS,1) + NENTRY = 1 + +C FOR EACH DRUG, THE IV AND TOTAL VALUES ARE ALREADY STORED INTO +C DOSELINEST(ISUB,NSSEVENTS,2*I) AND DOSELINEST(ISUB,NSSEVENTS,2*I+1), +C I=1,NDRUG. + + DO IDRUG = 1,NDRUG + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG) + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG+1) + END DO + +C FOR EACH COVARIATE, IF ANY, THE VALUES ARE STORED INTO +C DOSELINEST(ISUB,NSSEVENTS,19+ICOV), ICOV = 1,NCOVA. + + IF(NCOVA .GT. 0) THEN + DO ICOV = 1,NCOVA + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,19+ICOV) + END DO + ENDIF + + WRITE(33,1) (DOSELINES(J),J=1,NENTRY) + + NSSEVENTS = NSSEVENTS + 1 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NSSEVENTS .LE. NSST(ISUB)) CONDITION. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(TIME .GE. TIMADD*(NRESET+1)) CONDITION. + + + +C CHECK TO SEE IF ANY BOLUS TIMES = TIME. + + + DO IDRUG = 1,NDRUG + +C IF THE CURRENT INDEX FOR THIS BOLUS IS MORE THAN THE NO. +C OF ENTRIES IN THE CORRESPONDING ARRAY, IT MEANS THAT THERE ARE NO +C MORE BOLUS VALUES FOR THIS DRUG. IN THAT CASE, SET ITS TIME TO -99. +C OTHERWISE, SET ITS TIME TO THE NEXT TIME IN THE ARRAY. + + + + IF(INDBOL(IDRUG) .GT. NTIMBOL(ISUB,IDRUG)) TIMEB = -99.D0 + + IF(INDBOL(IDRUG) .LE. NTIMBOL(ISUB,IDRUG)) THEN + TIMEB = TIMBOL(ISUB,IDRUG,INDBOL(IDRUG)) + ENDIF + + CALL THESAME(TIME,TIMEB,ISAME) + + + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE +C "SAME" (I.E., WITHIN 1.D-10). IN THIS CASE, SET THE BOLUS VALUE FOR +C THIS EVENT TO THE CORRESPONDING VALUE IN BOLUS, AND INCREASE THE +C INDEX OF THE NEXT TIME BY 1. IF ISAME RETURNS AS 0, SET THE BOLUS +C VALUE = 0. + + IF(ISAME .EQ. 0) BOLVAL(IDRUG) = 0.D0 + + + IF(ISAME .EQ. 1) THEN + BOLVAL(IDRUG) = BOLUS(ISUB,IDRUG,INDBOL(IDRUG)) + INDBOL(IDRUG) = INDBOL(IDRUG) + 1 + ENDIF + + + END DO + + + +C CHECK TO SEE IF ANY COVARIATE TIMES = TIME. + + DO ICOV = 1,NCOVA + +C IF THE CURRENT INDEX FOR THIS COVARIATE IS MORE THAN THE NO. +C OF ENTRIES IN THE CORRESPONDING ARRAY, IT MEANS THAT THERE ARE NO +C MORE COV VALUES FOR THIS COVARIATE. IN THAT CASE, SET ITS TIME TO +C -99. OTHERWISE, SET ITS TIME TO THE NEXT TIME IN THE ARRAY. + + + + IF(INDCOV(ICOV) .GT. NTIMCOV(ISUB,ICOV)) TIMEC = -99.D0 + + IF(INDCOV(ICOV) .LE. NTIMCOV(ISUB,ICOV)) THEN + TIMEC = TIMCOV(ISUB,ICOV,INDCOV(ICOV)) + ENDIF + + CALL THESAME(TIME,TIMEC,ISAME) + + + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE +C "SAME" (I.E., WITHIN 1.D-10). IN THIS CASE, SET THE COVARIATE VALUE +C FOR THIS EVENT TO THE CORRESPONDING VALUE IN COV, AND INCREASE THE +C INDEX OF THE NEXT TIME BY 1. + + + IF(ISAME .EQ. 1) THEN + COVVAL(ICOV) = COV(ISUB,ICOV,INDCOV(ICOV)) + INDCOV(ICOV) = INDCOV(ICOV) + 1 + ENDIF + + +C IF ISAME RETURNS AS 0, THE COV. VALUE WILL BE THE SAME AS IT WAS +C PREVIOUSLY IF ICOVTYPE(ICOV) = 1 OR 0 (I.E., IF THIS IS A PIECEWISE +C CONTINOUS COVARIATE). IT WILL ALSO BE THE SAME AS IT WAS PREVIOUSLY +C IF ICOVTYPE(ICOV) = 2 (I.E., FOR A LINEARLY INTERPOLATED COVARIATE) +C IF TIMEC = -99, OR IF ISAMERESET = 1. HERE IS WHY: + +C TIMEC = -99 --> THERE ARE NO MORE COVARIATE VALUES (SEE ABOVE). +C IF ISAMERESET = 1, THEN THIS IS A TIME RESET POINT. AND IN THIS CASE, +C EVEN AN INTERPOLATED COVARIATE VALUE SHOULD BE SET = ITS LAST VALUE +C FROM BEFORE THE RESET, SINCE NO INTERPOLATION IS POSSIBLE FOR OUT OF +C ORDER TIMES (E.G., (T,COV) = (24,400), FOLLOWED BY (T,COV) = +C (20,1000) --> INTERPOLATED VALUE AT 0 WOULD BE: +C (0-24)/(20-24) * (1000 - 400) + 400 = 4000, WHICH IS PREPOSTEROUS). + + + IF(ISAME .EQ. 0) THEN + +C SET INTERP = 1, WHICH MEANS THAT THIS COVARIATE VALUE SHOULD BE +C INTERPOLATED FROM THE TWO SURROUNDING COVARIATE VALUES (WHICH HAVE +C BEEN EXPLICITLY SPECIFIED IN THE BLOCK FORMAT FILE). CHANGE INTERP +C TO 0 IF THIS IS NOT AN INTERPOLATED COVARIATE (ICOVTYPE(ICOV) = 1 +C OR 0) OR IF THIS IS AN INTERPOLATED COVARIATE BUT THERE ARE NO MORE +C COVARIATE VALUES FOR THIS COVARIATE (TIMEC = -99) OR IF THIS IS A +C TIME RESET VALUE (ISAMERESET = 1), OR IF THE CURRENT COVARIATE TIME + +C (WHICH WOULD BE USED IN THE INTERPOLATION) IS AT OR PAST THE NEXT +C TIME RESET. + + + INTERP = 1 + + IF(ICOVTYPE(ICOV) .EQ. 1 .OR. ICOVTYPE(ICOV) .EQ. 0) + 1 INTERP = 0 + IF(TIMEC .LE. -99) INTERP = 0 + IF(ISAMERESET .EQ. 1) INTERP = 0 + IF(TIMEC .GE. TIMERESET + TIMADD) INTERP = 0 + + +C IF INTERP = 1: + +C NOTE THAT INDCOV(ICOV) MUST BE .GE. 2 UNLESS THE USER HAS MADE A +C MISTAKE SINCE THE FIRST TIME (TIME = 0) IS SUPPOSED TO HAVE ALL +C COVARIATE VALUES SPECIFIED, WHICH MEANS THE FIRST TIME THROUGH THIS +C PART OF THE CODE ABOVE, INDCOV(ICOV) WAS INCREASED BY 1 (FROM ITS +C ORIGINAL VALUE OF 1). IF THIS IS NOT TRUE, WRITE A MESSAGE TO THE +C USER AND STOP. + + + IF(INDCOV(ICOV) .EQ. 1) THEN + + + + WRITE(*,111) ICOV + 111 FORMAT(/' THERE IS A MISTAKE IN THE BLOCK FORMAT PATIENT'/ + 1' DATA FILE. THE FIRST VALUE FOR COVARIATE NO. ',I2,' WAS NOT'/ + 2' SPECIFIED AT THE ORIGINAL TIME = 0, AS IS REQUIRED. PLEASE'/ + 3' FIX THIS ERROR AND RERUN THE PROGRAM. '//) + WRITE(*,401) ISUB,SUBID + 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,111) ICOV + WRITE(47,401) ISUB,SUBID + CLOSE(47) + + + + CALL PAUSE + STOP + + + + + ENDIF + + + CLAST = COV(ISUB,ICOV,INDCOV(ICOV)-1) + + + IF(INTERP .EQ. 0) COVVAL(ICOV) = CLAST + + IF(INTERP .EQ. 1) THEN + + +C NOTE: THE LAST COV. VALUE WAS CLAST WHICH OCCURRED AT TLAST. THE NEXT + +C COV VALUE IS CNEXT WHICH OCCURS AT TNEXT. SO ESTABLISH THE +C LINEARLY INTERPOLATED VALUE FOR THIS TIME, TIME. NOTE THAT THE TIMES, + +C TLAST AND TNEXT, MUST BE RECAST AS THEIR ACTUAL TIMES (BY REDUCING +C THEM BY TIMERESET) FIRST. + + TLAST = TIMCOV(ISUB,ICOV,INDCOV(ICOV)-1) - TIMERESET + + CNEXT = COV(ISUB,ICOV,INDCOV(ICOV)) + TNEXT = TIMCOV(ISUB,ICOV,INDCOV(ICOV)) - TIMERESET + TIMEREAL = TIME - TIMERESET + COVVAL(ICOV) = (TIMEREAL-TLAST)/(TNEXT-TLAST) * (CNEXT-CLAST) + 1 + CLAST + ENDIF + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 0) CONDITION. + + + + END DO + + +C THE ABOVE END DO IS FOR THE DO ICOV = 1,NCOVA LOOP. + + +C CHECK TO SEE IF ANY IV TIMES = TIME. + + DO IDRUG = 1,NDRUG + +C IF THE CURRENT INDEX FOR THIS IV IS MORE THAN THE NO. +C OF ENTRIES IN THE CORRESPONDING ARRAY, IT MEANS THAT THERE ARE NO +C MORE IV VALUES FOR THIS DRUG. IN THAT CASE, SET ITS TIME TO -99. +C OTHERWISE, SET ITS TIME TO THE NEXT TIME IN THE ARRAY. + + IF(INDIV(IDRUG) .GT. NTIMIV(ISUB,IDRUG)) TIMEI = -99.D0 + + IF(INDIV(IDRUG) .LE. NTIMIV(ISUB,IDRUG)) THEN + TIMEI = TIMIV(ISUB,IDRUG,INDIV(IDRUG)) + ENDIF + + CALL THESAME(TIME,TIMEI,ISAME) + + + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE +C "SAME" (I.E., WITHIN 1.D-10). IN THIS CASE, SET THE IV VALUE FOR +C THIS EVENT TO THE CORRESPONDING VALUE IN RATEIV, AND INCREASE THE +C INDEX OF THE NEXT TIME BY 1. IF ISAME RETURNS AS 0, THE IV VALUE +C WILL REMAIN WHAT IT WAS PREVIOUSLY. + + + + IF(ISAME .EQ. 1) THEN + XIVVAL(IDRUG) = RATEIV(ISUB,IDRUG,INDIV(IDRUG)) + INDIV(IDRUG) = INDIV(IDRUG) + 1 + + ENDIF + + END DO + + +C PUT THE ACTUAL TIME (I.E., TIME - TIMERESET) INTO THE 1ST ENTRY FOR +C THIS ROW. THEN PUT IN THE IV/BOLUS VALUES FOR EACH OF THE NDRUG DRUGS +C IN ORDER; THEN ALL ADDITIONAL COV. VALUES. + + DOSELINE(ITIM,1) = TIME - TIMERESET + NENTRY = 1 + + DO IDRUG = 1,NDRUG + NENTRY = NENTRY+1 + DOSELINE(ITIM,NENTRY) = XIVVAL(IDRUG) + NENTRY = NENTRY+1 + DOSELINE(ITIM,NENTRY) = BOLVAL(IDRUG) + END DO + + DO ICOV = 1,NCOVA + NENTRY = NENTRY+1 + DOSELINE(ITIM,NENTRY) = COVVAL(ICOV) + END DO + + WRITE(33,1) (DOSELINE(ITIM,J),J=1,NENTRY) + 1 FORMAT(43(G19.9,1X)) + + 1000 CONTINUE + +C THE ABOVE LABEL IS THE END OF THE DO 1000 ITIM = 1,NTIMI LOOP. + + + +C NOW CHECK TO SEE IF THE DOSAGE REGIMEN ENDS WITH ONE OR MORE STEADY +C STATE EVENTS. NOTE THAT THERE ARE NSST(ISUB) STEADY STATE EVENTS, +C AND NSSEVENTS - 1 OF THESE HAVE BEEN WRITTEN TO THE WORKING COPY FILE + +C SO FAR. + + 1010 CONTINUE + + + IF(NSSEVENTS .LE. NSST(ISUB)) THEN + + +C THE NEXT STEADY STATE DOSE EVENT OCCURS AFTER RESET NO. +C DOSELINEST(ISUB,NSSEVENTS,100). + +C FILL IN THE ENTRIES TO DOSELINE FOR THE STEADY STATE DOSE AT THE +C BEGINNING OF THIS DOSE RESET. + + +C THE FIRST ENTRY IN DOSELINST IS TIMEVENT = THE NEGATIVE OF THE +C INTERDOSE INTERVAL. + + DOSELINES(1) = DOSELINEST(ISUB,NSSEVENTS,1) + NENTRY = 1 + +C FOR EACH DRUG, THE IV AND TOTAL VALUES ARE ALREADY STORED INTO +C DOSELINEST(ISUB,NSSEVENTS,2*I) AND DOSELINEST(ISUB,NSSEVENTS,2*I+1), + +C I=1,NDRUG. + + DO IDRUG = 1,NDRUG + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG) + + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG+1) + END DO + + +C FOR EACH COVARIATE, IF ANY, THE VALUES ARE STORED INTO +C DOSELINEST(ISUB,NSSEVENTS,19+ICOV), ICOV = 1,NCOVA. + + IF(NCOVA .GT. 0) THEN + DO ICOV = 1,NCOVA + NENTRY = NENTRY+1 + DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,19+ICOV) + END DO + ENDIF + + WRITE(33,1) (DOSELINES(J),J=1,NENTRY) + + NSSEVENTS = NSSEVENTS + 1 + + GO TO 1010 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NSSEVENTS .LE. NSST(ISUB)) CONDITION. + + + +C----------------- WRITE THE DOSE EVENTS ABOVE ------------------------- + + +C----------------- WRITE THE OBSERVATION EVENTS BELOW ------------------ + + + + + WRITE(33,106) NOUT + 106 FORMAT(/' ',I1,' ... NO. OF TOTAL OUTPUT EQUATIONS') + + +C EACH SET OF TIMES FOR EACH OUTPUT EQUATION, TIMOUT(ISUB,IOUT,I), +C I = 1,NTIMOUT(ISUB,IOUT), IS IN ORDER, BUT EACH TIME HAS ADDED +C TO IT TIMADD*NRESET, WHERE NRESET IS THE NO. OF TIME RESETS UP TO +C AND TIME. + +C CALL FIXOUTIM TO OBTAIN NTIMORD, TIMORD, AND BLOCKOUT, WHERE +C NTIMORD IS THE TOTAL NO. OF UNIQUE TIMES TO BE PUT INTO THE +C OBSERVATION BLOCK; TIMORD(.) IS THE ORDERED ACTUAL TIMES (I.E., EACH +C OF THE TIMES IN TIMOUT(.,.,.) HAS BEEN REDUCED BY TIMADD*NRESET - SEE +C ABOVE), EXCEPT THAT EACH TIME OF 0 IS NOT ORDERED (IT INDICATES THE +C NEXT TIME RESET) FOR THE OBSERVATION BLOCK; AND BLOCKOUT IS THE + +C CORRESPONDING ARRAY OF OBSERVED VALUES FOR THE NOUT OUTPUT EQUATIONS +C AT THE TIMES IN TIMORD. + + + CALL FIXOUTIM(MAXSUB,ISUB,SUBID,NOUT,NTIMOUT,TIMOUT,OUT,NTIMORD, + 1 TIMORD,BLOCKOUT,TIMADD) + + WRITE(33,62) NTIMORD + 62 FORMAT(' ',I3,' ... NO. OF OBSERVED VALUE TIMES') + + DO I = 1,NTIMORD + WRITE(33,63) TIMORD(I),(BLOCKOUT(I,J),J=1,NOUT) + 63 FORMAT(7(G16.8,1X)) + + END DO + + + +C----------------- WRITE THE OBSERVATION EVENTS ABOVE ------------------ + + + +C----------------- WRITE THE BOTTOM OF FILE BELOW ---------------------- + + WRITE(33,303) + 303 FORMAT(/' COVARIATE NAMES AND VALUES (1ST, LAST, AND MEAN) FOLLO + 1W:') + +C FOR NOW, THE MEAN VALUE OF EACH COV. WILL BE -99 ... UNTIL WE DECIDE +C WHAT KIND OF MEAN WE WANT. E.G., IF A COV. = 100 AT T=0 AND +C 200 AT T = 10 AND 300 AT T = 11, WHICH IS THE LAST TIME, DO WE +C SIMPLY AVERAGE 100,200, AND 300, OR DO WE TAKE A WEIGHTED MEAN +C WHICH WOULD BE (100*10 + 200*1 + 300*0)/11, OR SOMETHING ELSE + + XMEAN = -99 + + DO ICOV = 1,NCOVA + WRITE(33,304) COVNAME(ICOV),COV(ISUB,ICOV,1), + 1 COV(ISUB,ICOV,NTIMCOV(ISUB,ICOV)),XMEAN + END DO + 304 FORMAT(A11,3X,3(F15.5,1X)) + + WRITE(33,306) + 306 FORMAT(/'ASSAY COEFFICIENTS FOLLOW, ONE SET FOR EACH OUTPUT EQUA + 1TION:') + + DO K = 1,NOUT + WRITE(33,3061) (CSUB(ISUB,I,K),I=1,4) + END DO + + 3061 FORMAT(4(F17.8,1X)) + + +C----------------- WRITE THE BOTTOM OF FILE ABOVE ---------------------- + + CLOSE(33) + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE THESAME(X1,X2,ISAME) + + + IMPLICIT REAL*8(A-H,O-Z) + +C THIS ROUTINE CHECKS TO SEE IF X1 AND X2 ARE VIRTUALLY THE SAME +C VALUES (I.E., IF THEY ARE WITHIN 1.D-10 OF EACH OTHER). IF SO, +C ISAME RETURNS AS 1; IF NOT ISAME RETURNS AS 0. + + ISAME = 0 + + XDEL = DABS(X1-X2) + IF(XDEL .LE. 1.D-10) ISAME = 1 + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE GETID(SUBID) + CHARACTER SUBID*11,SUB*11 + +C THIS ROUTINE IS CALLED TO REPLACE SUBID (WHICH HAS 11 CHARACTERS IN + +C IT) WITH THE CHARACTERS UP TO BUT NOT INCLUDING THE 1ST COMMA. + + + SUB = ' ' + DO I = 1,11 + IF(SUBID(I:I) .NE. ',') SUB(I:I) = SUBID(I:I) + IF(SUBID(I:I) .EQ. ',') GO TO 10 + END DO + + + + 10 SUBID = SUB + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE TIMESET(MAXSUB,ISUB,SUBID,NTIMALL,TIMALL,NTIMI, + 1 TIMI) + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION TIMALL(MAXSUB,72000),NTIMALL(MAXSUB),TIMI(72000), + 1 TIM(72000) + CHARACTER SUBID*11 + + + +C THIS ROUTINE IS CALLED BY READBLOCK2, TO ORDER ALL THE NTIMALL(ISUB) +C TIMES IN TIMALL(ISUB,.), ELIMINATING DUPLICATE TIMES. + +C RETURNED TO READBLOCK2 IS THE VECTOR TIMI, WITH NTIMI TIMES, +C ESTABLISHED AS INDICATED ABOVE. + + +C THE FIRST TIME IS TIMALL(ISUB,1) AND SHOULD BE 0. CHECK THIS FIRST. + + CALL THESAME(TIMALL(ISUB,1),0.D0,ISAME) + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE +C "SAME" (I.E., WITHIN 1.D-10). OTHERWISE, THE TIMES ARE NOT THE +C SAME AND ISAME = 0. + +C STARTING WITH BESTDOS103A.FOR, DO NOT CHECK THAT THE FIRST DOSE TIME +C IN EACH PATIENT IS 0, SINCE THE FIRST TIME MAY BE NEGATIVE (WHICH + +C SIGNIFIES THE DOSAGE REGIMEN BEGINS WITH A STEADY STATE OF DOSES). + + +C IF(ISAME .EQ. 0) THEN + +C WRITE(*,1) ISUB,TIMALL(ISUB,1) +C 1 FORMAT(/' THE FIRST TIME IN THE DOSAGE BLOCK FOR SUBJECT ',I5, +C 1' IS NOT 0; IT IS ',G14.5// +C 2' THIS IS NOT ALLOWED. PLEASE SET THE FIRST TIME IN THE DOSAGE'/ +C 3' BLOCKS FOR ALL SUBJECTS TO BE 0, AND RERUN THE PROGRAM.') +C WRITE(*,401) ISUB,SUBID +C 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) +C CALL PAUSE +C STOP +C ENDIF + + + +C CALL SUBROUTINE PUTORDER TO ORDER THE NTIMALL(ISUB) VALUES IN + +C TIMALL(ISUB,.). + + DO I = 1,NTIMALL(ISUB) + TIM(I) = TIMALL(ISUB,I) + END DO + + CALL PUTORDER(NTIMALL(ISUB),TIM) + + +C THE NTIMALL(ISUB) VALUES ARE NOW ORDERED IN TIM. + + + + +C THE CODE BELOW BELOW WILL REMOVE DUPLICATE TIMES. + + + TIMELAST = -1.D39 + + NTIMI = 0 + + DO I = 1,NTIMALL(ISUB) + + TIME = TIM(I) + CALL THESAME(TIME,TIMELAST,ISAME) + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TIME = TIMELAST (OR AT +C LEAST, THEY ARE WITHIN 1.D-10), AND THIS TIME CAN BE IGNORED SINCE IT +C WAS ALREADY PUT INTO TIMI (ACTUALLY THE VALUE REDUCED BY TIMERESET) +C BY A PREVIOUS TIME. + + IF(ISAME .EQ. 1) GO TO 30 + +C TO GET HERE, ISAME = 0, WHICH MEANS THIS IS A NEW TIME. SO PUT +C TIME INTO TIMI. THEN SET TIMELAST = TIME AND CONTINUE THE LOOP. + + NTIMI = NTIMI + 1 + + TIMI(NTIMI) = TIME + TIMELAST = TIME + + 30 CONTINUE + + END DO + + + + + RETURN + END + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE PUTORDER(NX,XX) + +C SUBROUTINE PUTORDER IS CALLED BY SUBROUTINE TIMESET. IT INPUTS XX, A +C VECTOR OF SIZE, NX, AND RETURNS RETURNS XX, BUT WITH THE VALUES +C ORDERED FROM LOW TO HIGH. + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION XX(72000),Y(72000),IZ(72000),IZZ(72000) + + +C ORDER THE NX VALUES IN X AS FOLLOWS: + +C PUT THE NX VALUES INTO VECTOR Y TO START. +C INITIALIZE VECTOR IZ TO BE -99 IN ALL ITS NX LOCATIONS. THEN, FOR +C EXAMPLE, IF ENTRY 17 IS THE SMALLEST VALUE IN Y, IZ(17) WILL BE +C SET = 0, AND THE PROGRAM WILL KNOW NOT TO CHECK THE 17TH ENTRY +C AGAIN (SINCE IT HAS ALREADY BEEN SELECTED). IF THE NEXT SMALLEST +C ENTRY HAS INDEX 37, THEN IZ(37) WILL BE SET = 0, ETC. + + +C NOTE THAT IZZ WILL BE THE ARRAY WHICH CONTAINS THE ACTUAL ORDERING. +C IN THE EXAMPLE ABOVE, IZZ(1) = 17, IZZ(2) = 37. IT WILL BE EASY TO + + +C ASSIGN ORDERED VALUES BACK INTO XX USING IZZ. IN THE EXAMPLE ABOVE, +C XX(1) = Y(IZZ(1)) = Y(17), XX(2) = Y(IZZ(2)) = Y(37), ETC. + + DO I=1,NX + + Y(I) = XX(I) + IZ(I) = -99 + END DO + + + DO IPLACE = 1,NX + +C PUT THE NEXT LOWEST VALUE OF Y INTO THE IPLACE LOCATION OF +C IZZ. + + +C TEMP IS THE RUNNING VALUE OF THE NEXT VALUE TO BE PLACED INTO Y. +C INITIALIZE IT TO BE VERY HIGH VALUE SO THE FIRST VALUE Y WILL BE +C SURE TO BE LOWER THAN IT IS. + + TEMP = 1.D50 + + DO I=1,NX + + IF(Y(I) .LT. TEMP .AND. IZ(I) .EQ. -99) THEN + TEMP = Y(I) + IND = I + ENDIF + END DO + +C AT THIS POINT, IND IS THE INDEX OF THE SMALLEST REMAINING VALUE +C (TEMP) IN Y. PUT THIS INFORMATION INTO IZZ. ALSO, + +C SET IZ(IND) = 0 --> THE IND LOCATION IN Y HAS BEEN USED. + + IZZ(IPLACE) = IND + IZ(IND) = 0 + + END DO + + +C AT THIS POINT IZZ CONTAINS THE ORDERED INDICES (LOW TO HIGH) OF Y. + +C USE THIS TO RE-ESTABLISH X TO BE ORDERED LOW TO HIGH. + + DO I = 1,NX + + XX(I) = Y(IZZ(I)) + END DO + + + RETURN + END + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE FIXOUTIM(MAXSUB,ISUB,SUBID,NOUT,NTIMOUT,TIMOUT,OUT, + 1 NTIMORD,TIMORD,BLOCKOUT,TIMADD) + + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION TIMOUT(MAXSUB,MAXNUMEQ,650),NTIMOUT(MAXSUB,MAXNUMEQ), + 1 IENTRY(MAXNUMEQ),OUT(MAXSUB,MAXNUMEQ,650),TIMORD(3900), + 2 BLOCKOUT(3900,MAXNUMEQ) + + + CHARACTER SUBID*11,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C FIXOUTIM IS CALLED BY WRITEDOS TO ORDER THE OUTPUT TIMES AMONG ALL +C THE NOUT OUTPUT EQUATIONS. NOTE THAT EACH OF THE TIMES CURRENTLY IN +C TIMOUT HAS BEEN INCREASE BY TIMERESET = TIMADD*NRESET, WHERE NRESET +C IS THE NO. OF TIME RESETS UP TO AND INCLUDING THAT TIME (THIS WAS +C DONE IN SUBROUTINE READBLOCK2). + + +C RETURNED TO SUBROUTINE WRITEDOS ARE: + +C NTIMORD = NO. OF TIME VALUES IN TIMORD. + +C TIMORD(I), I=1,NTIMORD = THE ORDERED SET OF TIMES (EXCEPT FOR 0'S +C WHICH INDICATE A TIME RESET) OVER ALL THE NOUT TIME ARRAYS. + +C BLOCKOUT(I,J) = OBSERVED VALUE FOR IOUTPUT EQUATION J, FOR THE TIME +C VALUE, TIMORD(I), I=1,NEXT; J = I,NOUT. + + +C NOTE THAT EACH OF THE TIME ARRAYS, TIMOUT(ISUB,IOUT,.) HAS ITS OWN +C VALUES IN ORDER (THEY WERE FILLED IN ORDER IN READBLOCK2). NOW, +C ESTABLISH THE ARRAY, TIMORD, WHICH HAS THE ORDERED SET OF +C TIMES OVER ALL THE NOUT TIME ARRAYS. ALSO, REDUCE EACH TIME BY +C TIMRESET = NRESET*TIMADD TO RETURN EACH TIME TO ITS ORIGINAL VALUE. +C NOTE THAT THIS WILL HAVE THE EFFECT OF SETTING TO 0 THE TIMES WHICH +C ARE THE TIME RESET POINTS (THEIR ACCOMPANYING OUTPUT VALUES WILL +C OF COURSE BE SET TO -99). + +C INITIALIZE THE NEXT TIME TO BE PUT INTO TIMORD TO BE A LARGE NO. +C AND INITIALIZE THE INDEX OF THE NEXT ENTRY IN EACH OF THE TIMOUT +C ARRAYS TO BE 1. ALSO INITIALIZE INEXT TO BE 1. IT WILL BE THE +C RUNNING INDEX OF THE NEXT ENTRY TO BE PUT INTO TIMORD. + + DO IOUT = 1,NOUT + + IENTRY(IOUT) = 1 + END DO + + INEXT = 1 + + 20 TIMENEXT = 1.D50 + +C SET IANOTHER = 0. IF IT STAYS 0, THERE ARE NO MORE TIMES IN +C ANY OF THE ARRAYS. + + IANOTHER = 0 + + + DO IOUT = 1,NOUT + +C FOR OUTPUT EQUATION IOUT, IF IENTRY(IOUT) .LE. THE NO. OF ENTRIES +C IN THE TIME ARRAY FOR IOUT, THEN THIS ENTRY IS EQUATION IOUT'S +C CANDIDATE FOR THE NEXT LOWEST TIME. + + + IF(IENTRY(IOUT) .LE. NTIMOUT(ISUB,IOUT)) THEN + IANOTHER = 1 + + IF(TIMOUT(ISUB,IOUT,IENTRY(IOUT)) .LE. TIMENEXT) + + 1 TIMENEXT = TIMOUT(ISUB,IOUT,IENTRY(IOUT)) + ENDIF + + + END DO + +C IF IANOTHER = 0, ALL TIME ARRAY, AND CORRESPONDING OBSERVED, VALUES +C HAVE BEEN STORED, SO GO TO 100 TO RECAST TIMORD BEFORE RETURNING. + + IF(IANOTHER .EQ. 0) GO TO 100 + + +C AT THIS POINT, TIMENEXT IS THE NEXT LOWEST TIME OVER ALL THE NOUT +C TIMOUT ARRAYS. PUT IT INTO TIMORD, AND PUT THE CORRESPONDING ENTRIES +C FOR EACH OF THE NOUT OUTPUT EQUATIONS INTO THE ARRAY BLOCKOUT. ALSO, +C INCREASE THE ENTRY NO. FOR THE TIME ARRAY(S) WHICH HAD THIS TIME. +C BUT CHECK THAT THE NO. OF ENTRIES INTO TIMORD IS NOT > THE MAX, 3900. +C IF IT IS, STOP. + + IF(INEXT .GT. 3900) THEN + + WRITE(*,1) + 1 FORMAT(/' THE TOTAL NO. OF OBSERVATION TIMES IS GREATER THAN'/ + 1' THE MAXIMUM ALLOWABLE VALUE OF 3900 (SUBROUTINE FIXOUTIM).'/ + 2' RERUN THE PROGRAM AFTER REDUCING THE NO. OF OBS. TIMES.'/) + WRITE(*,401) ISUB,SUBID + 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,1) + WRITE(47,401) ISUB,SUBID + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + TIMORD(INEXT) = TIMENEXT + + DO IOUT = 1,NOUT + + BLOCKOUT(INEXT,IOUT) = -99.D0 + CALL THESAME(TIMENEXT,TIMOUT(ISUB,IOUT,IENTRY(IOUT)),ISAME) + + IF(ISAME .EQ. 1) THEN + BLOCKOUT(INEXT,IOUT) = OUT(ISUB,IOUT,IENTRY(IOUT)) + IENTRY(IOUT) = IENTRY(IOUT) + 1 + ENDIF + + END DO + + + + INEXT = INEXT + 1 + + GO TO 20 + + + 100 NTIMORD = INEXT - 1 + + +C NOW, RECAST TIMORD TO BE THE CORRECT TIME VALUES. RECALL THAT, +C CURRENTLY, EACH TIME HAS NRESET*TIMADD ADDED TO ITS VALUE WHERE +C NRESET IS THE NO. OF TIME RESET 0'S UP TO AND INCLUDING THAT TIME +C VALUE. + +C INITIALIZE NRESET = 0. THIS IS THE RUNNING NUMBER OF TIME RESETS +C THAT HAVE OCCURED. ALSO INITIALIZE TIMERESET AS THE CURRENT AMOUNT +C OF TIME TO SUBTRACT TO DO THE RECASTING. + + NRESET = 0 + TIMERESET = TIMADD*NRESET + + DO I = 1,NTIMORD + CALL THESAME(TIMORD(I),TIMADD*(NRESET+1),ISAME) + + IF(ISAME .EQ. 1) THEN + NRESET = NRESET + 1 + TIMERESET = TIMADD*NRESET + ENDIF + + TIMORD(I) = TIMORD(I) - TIMERESET + END DO + + + RETURN + + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE GETMAXTIM(NCOVA,TIMAX) + + + + IMPLICIT REAL*8(A-H,O-Z) + CHARACTER READLINE*1000 + + +C THIS SUBROUTINE IS CALLED BY READBLOCK2 TO GET TIMAX, THE MAXIMUM TIME +C OVER ALL SUBJECTS IN FILE 66. THIS MAXIMUM TIME INCLUDES THE ENDING +C TIME FOR ALL IV RATES. + +C GO THROUGH ALL THE ROWS OF THE BLOCK FORMAT FILE. READ THE EVENT +C TIMES IN ENTRY 3. IF THE ROW IS AN IV ROW, ADD THIS VALUE TO THE +C DURATION TIME IN ENTRY 4. THEN UPDATE TIMAX IF THIS TOTAL TIME IS +C > TIMAX, WHICH IS INITIALIZED BELOW TO BE NEGATIVE. + + + TIMAX = -1.D0 + + + 10 READ(66,1,IOSTAT=IEND) READLINE + 1 FORMAT(A1000) + IF(IEND .LT. 0) RETURN + + IF(READLINE(1:1) .EQ. '#' .OR. READLINE(1:2) .EQ. '"#') GO TO 10 + + CALL AFTERCOMMA(NCOVA,READLINE,2) + BACKSPACE(57) + READ(57,*) TIMEVENT + CLOSE(57) + + + CALL AFTERCOMMA(NCOVA,READLINE,3) + BACKSPACE(57) + + READ(57,*,ERR=15) TIMDUR + GO TO 20 + 15 TIMDUR = 0.D0 + 20 TIME = TIMEVENT + TIMDUR + CLOSE(57) + + IF(TIMAX .LT. TIME) TIMAX = TIME + GO TO 10 + + + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE GETCHAR2(JSUB,CHARSUB) + + CHARACTER CHARSUB*3 + CHARACTER*1 B,C,D + +C THIS ROUTINE, CALLED BY READBLOCK2, INPUTS THE INTEGER JSUB +C (BETWEEN 1 AND 999), AND OUTPUTS THE 3-CHARACTER EQUIVALENT, CHARSUB. + + ILEFT = JSUB + + I3 = ILEFT/100 + ILEFT = ILEFT - I3*100 + I2 = ILEFT/10 + ILEFT = ILEFT - I2*10 + I1 = ILEFT + +C CONVERT THIS TO THE CHARACTER EQUIVALENT. + + IF(I3 .EQ. 1) B='1' + IF(I3 .EQ. 2) B='2' + IF(I3 .EQ. 3) B='3' + IF(I3 .EQ. 4) B='4' + IF(I3 .EQ. 5) B='5' + IF(I3 .EQ. 6) B='6' + IF(I3 .EQ. 7) B='7' + IF(I3 .EQ. 8) B='8' + IF(I3 .EQ. 9) B='9' + IF(I3 .EQ. 0) B='0' + + IF(I2 .EQ. 1) C='1' + IF(I2 .EQ. 2) C='2' + IF(I2 .EQ. 3) C='3' + + IF(I2 .EQ. 4) C='4' + IF(I2 .EQ. 5) C='5' + IF(I2 .EQ. 6) C='6' + + IF(I2 .EQ. 7) C='7' + IF(I2 .EQ. 8) C='8' + IF(I2 .EQ. 9) C='9' + IF(I2 .EQ. 0) C='0' + + + IF(I1 .EQ. 1) D='1' + IF(I1 .EQ. 2) D='2' + + IF(I1 .EQ. 3) D='3' + IF(I1 .EQ. 4) D='4' + IF(I1 .EQ. 5) D='5' + IF(I1 .EQ. 6) D='6' + IF(I1 .EQ. 7) D='7' + IF(I1 .EQ. 8) D='8' + IF(I1 .EQ. 9) D='9' + IF(I1 .EQ. 0) D='0' + + + CHARSUB = B//C//D + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE NEWCSV + +C NEWCSV IS CALLED BY MAIN TO CONVERT THE .CSV FILE IN FILE 77 TO +C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO +C n's. THIS CODE IS BASED ON THE STAND-A-LONE PROGRAM NEWCSV.FOR. + +C IN PARTICULAR, THE FOLLOWING SEQUENCES WILL BE REPLACED AS SHOWN: + + +C ,., WILL BE REPLACED BY ,n, +C ,. WILL BE REPLACED BY ,n <-- THIS OCCURS AT END OF LINES. + + +C NOTE THAT THE SECOND SEQUENCE ABOVE IS COMMA/DOT/SPACE, NOT JUST +C COMMA/DOT SINCE WE DON'T WANT ,.35 REPLACED BY ,n35, FOR EXAMPLE. + + IMPLICIT REAL*8(A-H,O-Z) + CHARACTER READLINE*1000 + + +C WRITE EACH LINE OF FILE 77 TO FILE 67, BUT REPLACE ALL MISSING VALUE +C DOTS WITH n's. + + 10 READ(77,4,IOSTAT=IEND) READLINE + 4 FORMAT(A1000) + IF(IEND .LT. 0) GO TO 100 + +C FOR THIS LINE, READLINE, FIND IENDL, THE LAST CHARACTER WHICH IS NOT +C BLANK. THEN ONLY CHARACTERS 1:IENDL WILL BE WRITTEN TO FILEOUT. + + DO IENDL = 1000,1,-1 + IF(READLINE(IENDL:IENDL) .NE. ' ') GO TO 20 + END DO + + + 20 CONTINUE + + +C BEFORE WRITING READLINE(1:IENDL) TO FILE 22, GO THROUGH THE LINE AND +C REPLACE ANY DOTS WHICH REPRESENT MISSING VALUES WITH n's. + +C NOTE THAT, AS EXPLAINED ABOVE, THIS MEANS REPLACING AS FOLLOWS: +C ,., WILL BE REPLACED BY ,n, +C ,. WILL BE REPLACED BY ,n <-- THIS OCCURS AT END OF LINES. + + + + DO I = 1,IENDL-2 + IF(READLINE(I:I+2) .EQ. ',.,') READLINE(I:I+2) = ',n,' + + + END DO + + IF(READLINE(IENDL-1:IENDL) .EQ. ',.') + 1 READLINE(IENDL-1:IENDL) = ',n' + + +C CANNOT USE WRITE(67,4) READLINE(1:IENDL) SINCE, FOR SOME REASON, +C WRITING LIKE THIS "RIGHT JUSTIFIES" THE CHARACTERS AT THE END + +C OF THE A1000 FORMAT. INSTEAD MUST WRITE (67,__) READLINE, WHERE +C THE FORMAT IS DETERMINED BY THE LAST NON-BLANK CHARACTER (IENDL) +C IN READLINE. + + IF(IENDL .LE. 26) THEN + WRITE(67,26) READLINE + 26 FORMAT(A26) + GO TO 10 + ENDIF + + IF(IENDL .LE. 51) THEN + WRITE(67,51) READLINE + 51 FORMAT(A51) + GO TO 10 + ENDIF + + IF(IENDL .LE. 76) THEN + WRITE(67,76) READLINE + 76 FORMAT(A76) + GO TO 10 + ENDIF + + IF(IENDL .LE. 101) THEN + WRITE(67,101) READLINE + 101 FORMAT(A101) + GO TO 10 + ENDIF + + + IF(IENDL .LE. 126) THEN + WRITE(67,126) READLINE + 126 FORMAT(A126) + GO TO 10 + ENDIF + + IF(IENDL .LE. 151) THEN + WRITE(67,151) READLINE + 151 FORMAT(A151) + GO TO 10 + ENDIF + + IF(IENDL .LE. 176) THEN + WRITE(67,176) READLINE + 176 FORMAT(A176) + GO TO 10 + ENDIF + + IF(IENDL .LE. 201) THEN + WRITE(67,201) READLINE + 201 FORMAT(A201) + GO TO 10 + ENDIF + + IF(IENDL .LE. 226) THEN + + + WRITE(67,226) READLINE + 226 FORMAT(A226) + GO TO 10 + ENDIF + + IF(IENDL .LE. 251) THEN + WRITE(67,251) READLINE + 251 FORMAT(A251) + GO TO 10 + ENDIF + + IF(IENDL .LE. 276) THEN + + + WRITE(67,276) READLINE + + 276 FORMAT(A276) + + GO TO 10 + ENDIF + + IF(IENDL .LE. 301) THEN + WRITE(67,301) READLINE + 301 FORMAT(A301) + GO TO 10 + ENDIF + + IF(IENDL .LE. 326) THEN + WRITE(67,326) READLINE + 326 FORMAT(A326) + GO TO 10 + + ENDIF + + IF(IENDL .LE. 351) THEN + WRITE(67,351) READLINE + 351 FORMAT(A351) + + GO TO 10 + ENDIF + + IF(IENDL .LE. 376) THEN + WRITE(67,376) READLINE + 376 FORMAT(A376) + GO TO 10 + ENDIF + + IF(IENDL .LE. 401) THEN + + WRITE(67,401) READLINE + 401 FORMAT(A401) + + GO TO 10 + ENDIF + + + IF(IENDL .LE. 426) THEN + WRITE(67,426) READLINE + 426 FORMAT(A426) + GO TO 10 + ENDIF + + + IF(IENDL .LE. 451) THEN + WRITE(67,451) READLINE + 451 FORMAT(A451) + GO TO 10 + ENDIF + + IF(IENDL .LE. 476) THEN + WRITE(67,476) READLINE + + 476 FORMAT(A476) + GO TO 10 + ENDIF + + IF(IENDL .LE. 501) THEN + WRITE(67,501) READLINE + 501 FORMAT(A501) + GO TO 10 + ENDIF + + IF(IENDL .LE. 526) THEN + WRITE(67,526) READLINE + 526 FORMAT(A526) + GO TO 10 + ENDIF + + IF(IENDL .LE. 551) THEN + WRITE(67,551) READLINE + 551 FORMAT(A551) + GO TO 10 + ENDIF + + IF(IENDL .LE. 576) THEN + WRITE(67,576) READLINE + 576 FORMAT(A576) + GO TO 10 + ENDIF + + IF(IENDL .LE. 601) THEN + WRITE(67,601) READLINE + 601 FORMAT(A601) + + GO TO 10 + ENDIF + + + + + IF(IENDL .LE. 626) THEN + + WRITE(67,626) READLINE + 626 FORMAT(A626) + GO TO 10 + + + ENDIF + + IF(IENDL .LE. 651) THEN + WRITE(67,651) READLINE + 651 FORMAT(A651) + GO TO 10 + ENDIF + + IF(IENDL .LE. 676) THEN + WRITE(67,676) READLINE + 676 FORMAT(A676) + GO TO 10 + ENDIF + + + IF(IENDL .LE. 701) THEN + WRITE(67,701) READLINE + + + + 701 FORMAT(A701) + GO TO 10 + ENDIF + + IF(IENDL .LE. 726) THEN + + WRITE(67,726) READLINE + 726 FORMAT(A726) + GO TO 10 + ENDIF + + IF(IENDL .LE. 751) THEN + WRITE(67,751) READLINE + + 751 FORMAT(A751) + GO TO 10 + ENDIF + + IF(IENDL .LE. 776) THEN + WRITE(67,776) READLINE + 776 FORMAT(A776) + + GO TO 10 + ENDIF + + IF(IENDL .LE. 801) THEN + WRITE(67,801) READLINE + 801 FORMAT(A801) + GO TO 10 + ENDIF + + IF(IENDL .LE. 826) THEN + WRITE(67,826) READLINE + 826 FORMAT(A826) + + + + GO TO 10 + ENDIF + + IF(IENDL .LE. 851) THEN + WRITE(67,851) READLINE + + 851 FORMAT(A851) + GO TO 10 + + ENDIF + + + + + IF(IENDL .LE. 876) THEN + + + + WRITE(67,876) READLINE + 876 FORMAT(A876) + GO TO 10 + ENDIF + + IF(IENDL .LE. 901) THEN + + WRITE(67,901) READLINE + 901 FORMAT(A901) + GO TO 10 + + ENDIF + + + IF(IENDL .LE. 926) THEN + WRITE(67,926) READLINE + 926 FORMAT(A926) + GO TO 10 + ENDIF + + IF(IENDL .LE. 951) THEN + WRITE(67,951) READLINE + 951 FORMAT(A951) + GO TO 10 + ENDIF + + IF(IENDL .LE. 976) THEN + WRITE(67,976) READLINE + + 976 FORMAT(A976) + GO TO 10 + + ENDIF + + WRITE(67,4) READLINE + + GO TO 10 + + + 100 CLOSE(77) + REWIND(67) + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE EQUIV(INUM,NAME) + + CHARACTER*1 A,B,C,D + CHARACTER NAME*4 + +C THIS SUBROUTINE, CALLED BY MAIN, INPUTS INTEGER INUM, AND RETURNS THE +C 4-CHARACTER EQUIVALENT IN NAME. + + I4 = INUM/1000 + ILEFT = INUM - I4*1000 + I3 = ILEFT/100 + ILEFT = ILEFT - I3*100 + I2 = ILEFT/10 + ILEFT = ILEFT - I2*10 + + I1 = ILEFT + +C CONVERT THIS TO THE CHARACTER EQUIVALENT. + + IF(I4 .EQ. 1) A='1' + IF(I4 .EQ. 2) A='2' + IF(I4 .EQ. 3) A='3' + IF(I4 .EQ. 4) A='4' + + IF(I4 .EQ. 5) A='5' + IF(I4 .EQ. 6) A='6' + IF(I4 .EQ. 7) A='7' + IF(I4 .EQ. 8) A='8' + IF(I4 .EQ. 9) A='9' + IF(I4 .EQ. 0) A='0' + + IF(I3 .EQ. 1) B='1' + IF(I3 .EQ. 2) B='2' + IF(I3 .EQ. 3) B='3' + + + IF(I3 .EQ. 4) B='4' + IF(I3 .EQ. 5) B='5' + IF(I3 .EQ. 6) B='6' + IF(I3 .EQ. 7) B='7' + + IF(I3 .EQ. 8) B='8' + IF(I3 .EQ. 9) B='9' + + IF(I3 .EQ. 0) B='0' + + IF(I2 .EQ. 1) C='1' + IF(I2 .EQ. 2) C='2' + IF(I2 .EQ. 3) C='3' + IF(I2 .EQ. 4) C='4' + IF(I2 .EQ. 5) C='5' + IF(I2 .EQ. 6) C='6' + IF(I2 .EQ. 7) C='7' + IF(I2 .EQ. 8) C='8' + IF(I2 .EQ. 9) C='9' + IF(I2 .EQ. 0) C='0' + + IF(I1 .EQ. 1) D='1' + IF(I1 .EQ. 2) D='2' + IF(I1 .EQ. 3) D='3' + IF(I1 .EQ. 4) D='4' + IF(I1 .EQ. 5) D='5' + IF(I1 .EQ. 6) D='6' + + + + + IF(I1 .EQ. 7) D='7' + IF(I1 .EQ. 8) D='8' + IF(I1 .EQ. 9) D='9' + IF(I1 .EQ. 0) D='0' + + + NAME = A//B//C//D + + RETURN + END + + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE CONVERTCSV + IMPLICIT REAL*8(A-H,O-Z) + CHARACTER READLINE*1000,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C SUBROUTINE CONVERTCSV READS FILE 87 AND WRITES SCRATCH FILE 77. +C IF FILE 87 IS ALREADY IN THE TYPICAL "AMERICAN" .CSV FORMAT, +C FILE 77 IS THE SAME AS FILE 87. + +C IF FILE 87 IS IN THE "EUROPEAN" .CSV FORMAT, WHERE SEMICOLONS +C ARE THE FIELD SEPARATORS, AND COMMAS ARE USED TO SEPARATE THE +C WHOLE AND FRACTIONAL PARTS OF NUMBERS, IT WILL BE WRITTEN TO +C FILE 77 WITH THE INDICATED CHANGES BELOW. + + +C FILE 87 IS AT LINE 1. READ PAST THIS LINE TO READ LINE 2 AND CHECK +C FOR A SEMICOLON. IF ONE IS FOUND, THEN THIS IS A "EUROPEAN" VERSION OF +C A .CSV FILE. NOTE THAT IT IS ONLY NECESSARY TO CHECK THE FIRST FEW +C CHARACTERS OF THIS LINE - EITHER THERE WILL BE COMMAS OR SEMICOLONS. +C IF THERE ARE BOTH COMMAS AND SEMICOLONS, SOMETHING IS WRONG WITH THE +C FILE; IN THIS CASE, PRINT A MESSAGE TO THE USER AND STOP. +C NOTE THAT, EVEN IN THE "EURO" VERSION, IT WILL STILL BE ASSUMED THAT +C A DOT REPRESENTS AN UNNEEDED VALUE. + + READ(87,*) + READ(87,4) READLINE + + ICOMMA = 0 + ISEMICOLON = 0 + + DO I = 1,20 + IF(READLINE(I:I) .EQ. ',') ICOMMA = 1 + IF(READLINE(I:I) .EQ. ';') ISEMICOLON = 1 + END DO + +C IF ICOMMA = 1 AND ISEMICOLON = 0, NO CONVERSION IS NEEDED AS THIS +C FILE IS A TYPICAL .CSV FILE. IN THIS CASE SET ICONVERT = 0. + +C IF ICOMMA = 0 AND ISEMICOLON = 1, CONVERT THIS FILE AS FOLLOWS: +C a. CHANGE ALL COMMAS TO PERIODS; THEN +C b. CHANGE ALL SEMICOLONS TO COMMAS. + +C IN THIS CASE, SET ICONVERT = 1. + +C IF ICOMMA = 1 AND ISEMICOLON = 1, STOP THE PROGRAM WITH A MESSAGE TO +C THE USER. + + IF(ICOMMA .EQ. 1 .AND. ISEMICOLON .EQ. 1) THEN + + + + WRITE(*,121) + 121 FORMAT(/' YOUR .CSV FILE HAS BOTH COMMAS AND SEMICOLONS IN '/ + 1' THE SECOND LINE. THIS IS A CONFLICT. IF YOU ARE USING THE '/ + 2' "EUROPEAN" VERSION OF A .CSV FILE, WITH SEMICOLONS AS FIELD'/ + 3' SEPARATORS AND COMMAS TO SEPARATE THE WHOLE AND FRACTIONAL'/ + 4' PARTS OF NUMBERS, THERE SHOULD BE NO COMMAS IN THE SECOND'/ + 5' LINE.'// + 6' SIMILARLY IF YOU ARE USING THE "AMERICAN" VERSION OF A .CSV'/ + 7' FILE, WITH COMMAS AS FIELD SEPARATORS, AND PERIODS TO SEPARTE'/ + 8' THE WHOLE AND FRACTIONAL PARTS OF NUMBERS, THERE SHOULD BE NO'/ + 9' SEMICOLONS IN THE SECOND LINE.'// + 1' PLEASE CORRECT YOUR .CSV FILE AND RERUN THE PROGRAM.'//) + + OPEN(47,FILE=ERRFIL) + WRITE(47,121) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + IF(ICOMMA .EQ. 1 .AND. ISEMICOLON .EQ. 0) ICONVERT = 0 + + + IF(ICOMMA .EQ. 0 .AND. ISEMICOLON .EQ. 1) ICONVERT = 1 + + REWIND(87) + OPEN(77) + + +C COPY FILE 87 TO FILE 77 BUT MAKE THE INDICATED CHANGES, IF +C ICONVERT = 1, LINE BY LINE. + + 10 READ(87,4,IOSTAT=IEND) READLINE + 4 FORMAT(A1000) + IF(IEND .LT. 0) GO TO 100 + +C FOR THIS LINE, READLINE, FIND IENDL, THE LAST CHARACTER WHICH IS NOT +C BLANK. THEN ONLY CHARACTERS 1:IENDL WILL BE WRITTEN TO FILEOUT. + + DO IENDL = 1000,1,-1 + IF(READLINE(IENDL:IENDL) .NE. ' ') GO TO 20 + END DO + + 20 CONTINUE + + DO I = 1,IENDL + IF(ICONVERT .EQ. 1) THEN + IF(READLINE(I:I) .EQ. ',') READLINE(I:I) = '.' + IF(READLINE(I:I) .EQ. ';') READLINE(I:I) = ',' + ENDIF + + END DO + + +C CANNOT USE WRITE(77,4) READLINE(1:IENDL) SINCE, FOR SOME REASON, +C WRITING LIKE THIS "RIGHT JUSTIFIES" THE CHARACTERS AT THE END +C OF THE A1000 FORMAT. INSTEAD MUST WRITE (77,__) READLINE, WHERE +C THE FORMAT IS DETERMINED BY THE LAST NON-BLANK CHARACTER (IENDL) +C IN READLINE. + + IF(IENDL .LE. 26) THEN + WRITE(77,26) READLINE + 26 FORMAT(A26) + GO TO 10 + ENDIF + + + + IF(IENDL .LE. 51) THEN + WRITE(77,51) READLINE + + 51 FORMAT(A51) + GO TO 10 + ENDIF + + IF(IENDL .LE. 76) THEN + WRITE(77,76) READLINE + 76 FORMAT(A76) + GO TO 10 + + ENDIF + + IF(IENDL .LE. 101) THEN + + WRITE(77,101) READLINE + 101 FORMAT(A101) + + GO TO 10 + ENDIF + + + IF(IENDL .LE. 126) THEN + WRITE(77,126) READLINE + 126 FORMAT(A126) + GO TO 10 + ENDIF + + IF(IENDL .LE. 151) THEN + WRITE(77,151) READLINE + 151 FORMAT(A151) + GO TO 10 + ENDIF + + IF(IENDL .LE. 176) THEN + WRITE(77,176) READLINE + 176 FORMAT(A176) + GO TO 10 + ENDIF + + IF(IENDL .LE. 201) THEN + WRITE(77,201) READLINE + 201 FORMAT(A201) + GO TO 10 + ENDIF + + IF(IENDL .LE. 226) THEN + WRITE(77,226) READLINE + 226 FORMAT(A226) + GO TO 10 + + ENDIF + + IF(IENDL .LE. 251) THEN + WRITE(77,251) READLINE + 251 FORMAT(A251) + GO TO 10 + ENDIF + + + IF(IENDL .LE. 276) THEN + WRITE(77,276) READLINE + 276 FORMAT(A276) + + + GO TO 10 + + ENDIF + + IF(IENDL .LE. 301) THEN + WRITE(77,301) READLINE + 301 FORMAT(A301) + GO TO 10 + ENDIF + + IF(IENDL .LE. 326) THEN + WRITE(77,326) READLINE + + 326 FORMAT(A326) + + GO TO 10 + ENDIF + + IF(IENDL .LE. 351) THEN + WRITE(77,351) READLINE + + 351 FORMAT(A351) + GO TO 10 + ENDIF + + IF(IENDL .LE. 376) THEN + WRITE(77,376) READLINE + 376 FORMAT(A376) + GO TO 10 + ENDIF + + IF(IENDL .LE. 401) THEN + WRITE(77,401) READLINE + 401 FORMAT(A401) + GO TO 10 + ENDIF + + IF(IENDL .LE. 426) THEN + WRITE(77,426) READLINE + 426 FORMAT(A426) + GO TO 10 + ENDIF + + + IF(IENDL .LE. 451) THEN + WRITE(77,451) READLINE + 451 FORMAT(A451) + + GO TO 10 + ENDIF + + IF(IENDL .LE. 476) THEN + + + WRITE(77,476) READLINE + 476 FORMAT(A476) + GO TO 10 + + ENDIF + + IF(IENDL .LE. 501) THEN + WRITE(77,501) READLINE + 501 FORMAT(A501) + GO TO 10 + ENDIF + + + IF(IENDL .LE. 526) THEN + WRITE(77,526) READLINE + 526 FORMAT(A526) + GO TO 10 + ENDIF + + + IF(IENDL .LE. 551) THEN + + WRITE(77,551) READLINE + 551 FORMAT(A551) + GO TO 10 + + ENDIF + + IF(IENDL .LE. 576) THEN + WRITE(77,576) READLINE + 576 FORMAT(A576) + GO TO 10 + ENDIF + + IF(IENDL .LE. 601) THEN + WRITE(77,601) READLINE + 601 FORMAT(A601) + GO TO 10 + ENDIF + + IF(IENDL .LE. 626) THEN + WRITE(77,626) READLINE + + + 626 FORMAT(A626) + GO TO 10 + ENDIF + + IF(IENDL .LE. 651) THEN + WRITE(77,651) READLINE + 651 FORMAT(A651) + GO TO 10 + ENDIF + + IF(IENDL .LE. 676) THEN + WRITE(77,676) READLINE + 676 FORMAT(A676) + GO TO 10 + ENDIF + + IF(IENDL .LE. 701) THEN + WRITE(77,701) READLINE + 701 FORMAT(A701) + GO TO 10 + + ENDIF + + IF(IENDL .LE. 726) THEN + WRITE(77,726) READLINE + 726 FORMAT(A726) + GO TO 10 + ENDIF + + IF(IENDL .LE. 751) THEN + WRITE(77,751) READLINE + 751 FORMAT(A751) + GO TO 10 + ENDIF + + IF(IENDL .LE. 776) THEN + WRITE(77,776) READLINE + + 776 FORMAT(A776) + GO TO 10 + ENDIF + + IF(IENDL .LE. 801) THEN + WRITE(77,801) READLINE + + 801 FORMAT(A801) + GO TO 10 + + ENDIF + + IF(IENDL .LE. 826) THEN + WRITE(77,826) READLINE + + 826 FORMAT(A826) + GO TO 10 + ENDIF + + IF(IENDL .LE. 851) THEN + WRITE(77,851) READLINE + 851 FORMAT(A851) + GO TO 10 + ENDIF + + IF(IENDL .LE. 876) THEN + WRITE(77,876) READLINE + + 876 FORMAT(A876) + GO TO 10 + ENDIF + + IF(IENDL .LE. 901) THEN + WRITE(77,901) READLINE + 901 FORMAT(A901) + GO TO 10 + ENDIF + + IF(IENDL .LE. 926) THEN + WRITE(77,926) READLINE + 926 FORMAT(A926) + + GO TO 10 + ENDIF + + IF(IENDL .LE. 951) THEN + WRITE(77,951) READLINE + 951 FORMAT(A951) + + GO TO 10 + ENDIF + + + IF(IENDL .LE. 976) THEN + WRITE(77,976) READLINE + 976 FORMAT(A976) + GO TO 10 + + ENDIF + + WRITE(77,4) READLINE + GO TO 10 + + + + + 100 CLOSE(87) + REWIND(77) + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE CSVCHANGE + +C SUBROUTINE CSVCHANGE IS CALLED BY MAIN AND SUBROUTINE GETNUMEQ TO +C CHANGE .csv FILES WITH CODE OF POPDATA DEC_11 (I.E., THOSE WITH 2 +C EXTRA COLUMNS FOR ADDL AND II) TO EQUIVALENT .csv FILES WITH CODE OF +C POPDATA APR_11 (THOSE WITHOUT THE TWO EXTRA COLUMNS). IT READS +C FILE 67, AND WRITES THE INFORMATION TO SCRATCH FILE 66. NOTE THAT IF +C THE .csv FILE READ IN ALREADY IS THE OLDER VERSION (WITH CODE +C POPDATA APR_11), THIS ROUTINE SIMPLY REWRITES IT TO FILE 66, WHICH IS +C THEN READ BY SUBROUTINE READBLOCK. + +C THIS ROUTINE IS BASED ON THE STAND-A-LONE PROGRAM, CSVCHANGE.FOR. +C AS OF IT2B104.FOR, THIS ROUTINE IS BASED ON CSVCHANGE2.FOR. + +C CSVCHANGE.FOR 12/6/11 + +C THIS PROGRAM CONVERTS THE NEW-STYLE .csv FILES (WITH TWO ADDITIONAL +C COLUMNS (ADDL AND II) TO THE PREVIOUS .csv FORMAT. + +C ADDL GIVES THE NO. OF ADDITIONAL DOSES FOR ANY DOSE EVENT, AND II +C GIVES THE INTERDOSE INTERVAL FOR THE ADDITIONAL DOSES. + +C EX: IF TIME = 0, DUR = 2, DOSE = 1000, ADDL = 2, II = 12, THIS +C PROGRAM WOULD PUT IN TWO EXTRA LINES AS FOLLOWS: + +C TIME DUR DOSE ADDL II + +C 0 2 1000 2 12 <-- ONLY LINE IN NEW-STYLE FILE +C 12 2 1000 <-- THESE TWO LINES ARE ADDED TO THE OLD +C 24 2 1000 STYLE FILE (WHICH DOESN'T HAVE ADDL AND +C II COLUMNS. + +C NOTE THAT ADDL = -1 IS A STEADY STATE DOSE INDICATOR. IN THIS CASE, +C CHANGE THE TIME OF THE DOSE TO -II, SO SUBROUTINES READBLOCK/WRITEDOS +C WILL RECOGNIZE THE LINE AS THE BEGINNING OF A STEADY STATE DOSE SET. + +C NOTE THAT ONCE ALL THE ADDITIONAL DOSES ARE ADDED TO THE DOSE +C ARRAY, THEY MUST ALL BE ORDERED AMONG THEMSELVES (UNTIL THE NEXT +C DOSE/TIME RESET) SINCE READBLOCK EXPECTS ORDERED DOSES. BUT IT IS +C OK FOR ALL THE DOSES IN A GIVEN REGION TO COME FIRST, AND THEN ALL +C THE OBSERVATIONS TO FOLLOW (I.E., THE DOSES SHOULD BE ORDERED AMONG +C THEMSELVES AND THE OBSERVATIONS FOLLOW THE DOSES, ORDERED AMONG +C THEMSELVES). + +C NOTE THAT ADDL AND II ENTRIES ARE IGNORED IF EVID = 0 (I.E.,THE +C EVENT IS AN OBSERVATION). + +C NOTE THAT IF ADDL AND II ARE MISSING FOR A DOSE EVENT (EVID = 1 OR +C 4) THEN ADDL IS ASSUME TO BE 0 (NO ADDITIONAL DOSES) AND II IS +C IRRELEVANT. + + +C NOTE THAT THIS PROGRAM WILL OPEN AND READ THE NEW-STYLE .csv +C FILE FROM FILE 67, AND THEN WRITE THE PREVIOUS .csv FORMAT TO FILE +C 66. + + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION TIMENTRY(99999),IDENTRY(99999) + + CHARACTER READLINE*1000,CODEPAT*15, + 1 READLINE2*1000,HOLDMAT(99999)*150,TIMCHAR*50,SUBID*11, + 2 SUBIDPREV*11,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + + 1 FORMAT(A1000) + 2 FORMAT(A20) + + OPEN(66) + + ICODEPAT = 0 + + + 6 FORMAT(A15) + ICODEPAT = -1 + + + READ(67,6) CODEPAT + IF(CODEPAT .EQ. '"POPDATA DEC_11') ICODEPAT = 1 + IF(CODEPAT(1:14) .EQ. 'POPDATA DEC_11') ICODEPAT = 1 + + + + IF(CODEPAT .EQ. '"POPDATA APR_11') ICODEPAT = 0 + IF(CODEPAT(1:14) .EQ. 'POPDATA APR_11') ICODEPAT = 0 + + + IF(ICODEPAT .EQ. -1) THEN + + + + WRITE(*,7) + 7 FORMAT(//' YOUR PATIENT DATA BLOCK FILE IS NOT FROM THE'/ + 1' ALLOWABLE SET OF SUCH FILES.'// + 2' A PATIENT DATA BLOCK FILE MUST HAVE "POPDATA XXX_XX IN'/ + 3' COLUMNS 1 THROUGH 15 ON LINE 1, WHERE XXX_XX IS APR_11 OR A '/ + 4' MORE RECENT DATE.'//) + WRITE(*,*)' THE PROGRAM STOPS.' + + OPEN(47,FILE=ERRFIL) + WRITE(47,7) + WRITE(47,*)' THE PROGRAM STOPS.' + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + +C IF ICODEPAT = 0, THE INPUT .csv FILE IS ALREADY IN THE CORRECT FORM +C TO BE READ BY SUBROUTINE READBLOCK. IN THIS CASE, JUST COPY FILE 67, + + +C LINE BY LINE TO FILE 66. + + IF(ICODEPAT .EQ. 0) THEN + +C WRITE THE TOP LINE (WITH THE CODE) TO FILE 66. + + CODEPAT = 'POPDATA APR_11' + WRITE(66,6) CODEPAT + + 1020 READ(67,1,IOSTAT=IEND) READLINE + IF(IEND .LT. 0) THEN + CLOSE(67) + RETURN + ENDIF + WRITE(66,1) READLINE + GO TO 1020 + + ENDIF + + +C ICODEPAT = 1. SO WRITE THE INFO IN FILE 67 TO FILE 66 IN THE OLD +C FORMAT (WITHOUT THE TWO COLUMNS FOR ADDL AND II). + +C WRITE THE TOP LINE (WITH THE CODE) TO FILE 66. + + CODEPAT = 'POPDATA APR_11' + WRITE(66,6) CODEPAT + +C READ THE 2ND LINE OF FILE 67 AND WRITE THIS LINE TO FILE 66, BUT +C WITHOUT THE ADDL AND II NAMES. + + READ(67,1) READLINE + +C SEARCH FOR THE CHARACTER STRING ",ADDL,II" IN THE EARLY PART OF + +C READLINE AND ELIMINATE IT, BEFORE WRITING THE LINE TO FILE 66. IF +C THIS STRING IS NOT FOUND, TELL THE USER HIS FILE 67 HAS AN ERROR IN +C IT, AND STOP + + DO I = 1,50 + IF(READLINE(I:I+7) .EQ. ',ADDL,II') THEN + ISS = I + GO TO 10 + ENDIF + END DO + +C TO GET HERE MEANS THE ABOVE STRING WAS NEVER FOUND. SO WRITE A +C MESSAGE TO THE USER AND STOP. + + WRITE(*,8) + 8 FORMAT(//' YOUR PATIENT DATA BLOCK FILE IS NOT FROM THE '/ + + 1' ALLOWABLE SET OF SUCH FILES.'// + 2' A PATIENT DATA BLOCK FILE MUST HAVE ",ADDL,II" AS THE 6TH AND'/ + 3' 7TH COLUMN HEADINGS ON LINE 2.'//) + WRITE(*,*)' THE PROGRAM STOPS.' + + OPEN(47,FILE=ERRFIL) + WRITE(47,8) + WRITE(47,*)' THE PROGRAM STOPS.' + CLOSE(47) + + + + CALL PAUSE + STOP + + + 10 CONTINUE + +C PUT ALL OF READLINE, EXCEPT ENTRIES ISS:ISS+7 INTO READLINE2, +C AND WRITE READLINE2 INTO FILE 66. + + READLINE2(1:ISS-1) = READLINE(1:ISS-1) + + READLINE2(ISS:992) = READLINE(ISS+8:1000) + WRITE(66,1) READLINE2 + + + +C EACH LINE IN FILE 67, STARTING WITH LINE 3 (EXCEPT FOR LINES +C BEGINNING WITH #) HAS A SUBJECT ID IN THE 1ST 11 ENTRIES. THEN +C THE ENTRIES ARE, IN ORDER, EVID, TIME, DUR, DOSE, ADDL, II, INPUT, +C ... + +C READ EACH DOSE LINE (EVID = 1 OR 4) TO OBTAIN THE VALUES OF ADDL AND +C II FOR THOSE. ADDL IS THE NO. OF ADDITIONAL DOSE LINES THAT ARE +C IDENTICAL TO THE CURRENT LINE, AND II IS THE ASSOCIATED INTERDOSE + +C INTERVAL. IF ADDL = -1, THIS REPRESENTS A STEADY STATE SET OF DOSES. + +C FOR A DOSE LINE, IF ADDL = 0 OR IS MISSING (WHICH MEANS ADDL IS +C ASSUMED TO BE 0), WRITE THE LINE, WITHOUT THE ADDL AND II VALUES, +C INTO HOLDMAT. + +C FOR EACH DOSE LINE WITH AN ADDL > 0, WRITE THAT LINE +C WITHOUT THE ADDL AND II VALUES, AND ADDL MORE SIMILAR LINES INTO THE +C HOLDMAT, MAKING SURE THAT THE TIME FOR EACH SUCCESSIVE LINE +C IS INCREASED BY II FROM THE PREVIOUS LINE. + + +C NOTE THAT THE ABOVE PROCESS CAN CAUSE THE DOSE LINES TO BE OUT OF +C ORDER IN HOLDMAT. EACH BLOCK OF DOSE LINES WILL BE +C ORDERED UP TO THE NEXT DOSE/TIME RESET LINE BELOW. AND NOTE THAT +C ALL THE DOSES IN EACH REGION (UNTIL THE NEXT TIME RESET LINE - I.E., +C UNTIL THE NEXT EVID = 4) WILL BE WRITTEN TOGETHER, AND THEN BE +C FOLLOWED BY ALL THE OBSERVATION LINES IN THAT REGION). + + +C NOTE BELOW THAT AFTERCOMMA OPENS AND PUTS INTO FILE 57 THE PART OF +C READLINE WHICH IS BETWEEN COMMA C AND COMMA C+1, WHERE C IS THE 3RD +C ARGUMENT. ALSO,NOTE THAT NCOVA MUST BE PROVIDED TO AFTERCOMMA SO IT +C WILL KNOW THE TOTAL NO. OF COMMAS IN READLINE, WHICH = 13 + NCOVA +C SINCE THIS FILE HAS 14 FIXED FIELDS (COUNTING THE 2 NEWS ONES, +C ADDL AND II). +C +C SO, FIRST FIND NCOVA FROM READLINE JUST READ IN (THE 2ND LINE OF THE +C .csv FILE). + + NCOMMA = 0 + + DO ISTART = 1,1000 + IF(READLINE(ISTART:ISTART) .EQ. ',') THEN + NCOMMA = NCOMMA + 1 + ENDIF + END DO + + NCOVA = NCOMMA - 13 + +C INITIALIZE SUBIDPREV (THE PREVIOUS SUBJECT ID), AND THE CURRENT +C SUBJECT TO BE '%^&*'. + + SUBIDPREV = '%^&*' + SUBID = '%^&*' + NROW = 0 + + + +C NROW IS THE RUNNING INDEX OF THE NEXT LINE TO BE PUT INTO THE +C HOLDMAT. + + + 20 READ(67,1,IOSTAT=IEND) READLINE + + +C IF IEND .LT. 0, THE FILE HAS BEEN READ THROUGH COMPLETELY, SO GO TO +C LABEL 100 TO WRITE THE LAST SUBJECT'S ROWS TO FILE 66. + + IF(IEND .LT. 0) GO TO 100 + +C IF READLINE(1:1) IS #, THIS LINE IS A COMMENT LINE AND CAN BE +C SKIPPED (I.E., NOT WRITTEN INTO HOLDMAT). + + IF(READLINE(1:1) .EQ. '#') GO TO 20 + + +C WILL ALSO GO TO LABEL 100 IF THIS SUBJECT ID IS DIFFERENT THAN +C SUBIDPREV (SINCE THAT MEANS THAT THE PREVIOUS SUBJECT'S LINES ARE +C READY TO BE WRITTEN TO FILE 66). + + +C THE FIRST VALUE (I.E., AFTER COMMA NO. 0) IS THE SUBJECT ID. + + CALL AFTERCOMMA(NCOVA,READLINE,0) + BACKSPACE(57) + READ(57,222) SUBID + 222 FORMAT(A11) + CLOSE(57) + +C NOTE THAT SUBID CONTAINS THE 1ST 11 CHARACTERS OF THE LINE, BUT THE +C SUBJECT ID IS JUST THE SET OF CHARACTERS PRIOR TO THE 1ST COMMA. +C CALL SUBROUTINE GETID TO CORRECT THE VALUE OF SUBID. + + CALL GETID(SUBID) + + IF(SUBID .NE. SUBIDPREV) GO TO 100 + + +C TO GET TO THIS POINT, SUBID = SUBIDPREV, WHICH MEANS THIS IS A +C LINE FOR THE CURRENT SUBJECT. + +C IF THE EVENT ID, IN ENTRY NO. 2 (I.E., AFTER COMMA NO. 1) IN +C READLINE IS 0, THE LINE REPRESENTS AN OBSERVATION AND CAN BE WRITTEN +C INTO HOLDMAT, EXCEPT FOR ADDL AND II AS DONE ABOVE. + + CALL AFTERCOMMA(NCOVA,READLINE,1) + BACKSPACE(57) + READ(57,*) IDEVENT + + CLOSE(57) + + IF(IDEVENT .EQ. 0) THEN + NROW = NROW + 1 + CALL GETCOM(NCOMMA,READLINE,I5,I7) + HOLDMAT(NROW) = READLINE(1:I5)//READLINE(I7+1:150) + ENDIF + + +C IF THE EVENT ID IS 1 OR 4, THE LINE REPRESENTS A DOSE +C EVENT (1 -> REGULAR DOSE; 4 -> TIME RESET EVENT WITH A DOSE). EITHER +C WAY IF THE ENTRY FOR ADDL IS MISSING OR A 0, IT MEANS THAT THIS LINE +C REPRESENTS A SINGLE DOSE. IF ADDL > 0, THIS LINE MUST BE COPIED +C ADDL TIMES. NOTE THAT THE ADDL ENTRY IS NO. 6, AFTER COMMA NO. 5. + + IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) THEN + + CALL AFTERCOMMA(NCOVA,READLINE,5) + BACKSPACE(57) + READ(57,*,ERR=25) IADDL + CLOSE(57) + GO TO 30 + + 25 IADDL = 0 + +C TO GET TO LABEL 25 MEANS IADDL TRIED TO READ A NON-NUMBER, WHICH +C MEANS IT IS MISSING --> IT IS EQUIVALENT TO 0. IN THIS CASE, WRITE +C THE LINE INTO HOLDMAT, EXCEPT FOR IADDL AND II AS +C DONE ABOVE. + + 30 CONTINUE + + + IF(IADDL .GE. 0) THEN + NROW = NROW + 1 + CALL GETCOM(NCOMMA,READLINE,I5,I7) + HOLDMAT(NROW) = READLINE(1:I5)//READLINE(I7+1:150) + ENDIF + + IF(IADDL .GT. 0) THEN + + +C THIS LINE MUST BE COPIED IADDL TIMES, BUT EACH LINE MUST HAVE ITS +C TIME ENTRY INCREASED BY XII (THE INTERDOSE INTERVAL) FROM THE +C PREVIOUS LINE. FIRST FIND THE VALUE OF XII, IN THE 7TH ENTRY, AFTER +C THE 6TH COMMA. IF XII IS MISSING, STOP THE PROGRAM TELLING THE USER +C THAT THE .cvs FILE HAS AN ERROR; IT HAS A ROW WITH AN IADDL > 0, BUT +C WITH AN ACCOMPANYING INTERDOSE INTERVAL WHICH IS MISSING. NOTE THAT +C THIS LINE NO. IS 2 (THE TOP 2 LINES) + NROW + 1 = NROW + 3. + + + CALL AFTERCOMMA(NCOVA,READLINE,6) + BACKSPACE(57) + READ(57,*,ERR=35) XII + CLOSE(57) + GO TO 40 + + 35 WRITE(*,36) NROW + 3 + 36 FORMAT(/' THE INTERDOSE INTERVAL IS MISSING ON LINE NO. ',I6// + 1' PLEASE CORRECT YOUR .csv FILE AND RERUN THE PROGRAM.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,36) NROW + 3 + CLOSE(47) + + + + CALL PAUSE + STOP + + + 40 CONTINUE + + + +C THE TIME FOR THE ORIGINAL DOSE IS IN ENTRY NO. 3, AFTER COMMA NO. 2. + + CALL AFTERCOMMA(NCOVA,READLINE,2) + BACKSPACE(57) + READ(57,*) TIM + CLOSE(57) + + DO IADD = 1,IADDL + + +C NOTE THAT THE ORIGINAL LINE FOR THIS DOSE HAS ALREADY BEEN WRITTEN +C TO HOLDMAT (IN THE IF(IADDL .GE. 0) SECTION ABOVE). SO +C NOW MUST WRITE IADDL LINES TO HOLDMAT, EACH IDENTICAL TO +C THE CURRENT LINE, EXCEPT EACH TIM WILL BE INCREMENTED BY +C XII. TO DO THIS, WRITE THE NEXT TIM + XII TO SCRATCH FILE 57; THEN +C REREAD THIS VALUE AS A CHARACTER SO IT CAN BE INSERTED INTO +C THE CHARACTER STRING READLINE AND THEN WRITTEN TO THE HOLDING +C MATRIX. + +C ... AND ... + + +C BUG CORRECTION FOR BESTDOS106.FOR. EACH REPEATED ROW MUST HAVE +C IDEVENT SET = 1. I.E.,IF IDEVENT FOR THE ORIGINAL ROW (WHICH IS BEING +C REPEATED IADDL TIMES) IS 4, THIS IS A TIME RESET EVENT, BUT THE +C REPEATED ROWS WILL ALL HAVE IDEVENTS OF 1 (OTHERWISE IT WOULD LOOK +C LIKE REPEATED TIME RESET EVENTS WHICH IS NOT WHAT IS INTENDED). +C FOR EXAMPLE, IADDL = 3 IN AN IDEVENT = 4 LINE --> THE FIRST LINE IN +C FILE 66 SHOULD HAVE IDEVENT = 4, BUT THE NEXT TWO LINES MUST HAVE +C IDEVENT = 1 (I.E., THEY ARE REGULAR DOSE LINES THAT FOLLOW THE +C IDEVENT = 4 LINE AT TIME INTERVALS OF XII). + +C FIRST RESET READLINE TO HOLDMAT(NROW), WHICH DOES NOT HAVE THE +C ADDL AND II ENTRIES. + + READLINE(1:150) = HOLDMAT(NROW) + + OPEN(57,STATUS='SCRATCH') + WRITE(57,*) TIM + XII*IADD + BACKSPACE(57) + READ(57,41) TIMCHAR + 41 FORMAT(A50) + CLOSE(57) + +C TAKE OUT ALL SPACES AT THE END OF TIMCHAR. + + + DO IEND = 50,1,-1 + IF(TIMCHAR(IEND:IEND) .NE. ' ') GO TO 50 + + END DO + + 50 CONTINUE + + +C NOW TIMCHAR(1:IEND) IS THE CONDENSED FORM OF THE TIME FOR THIS +C ROW. REPLACE WHAT IS CURRENTLY BETWEEN COMMAS 2 AND 3 OF +C HOLDMAT(NROW) WITH THIS, AND STORE IT INTO THE NEXT ROW OF HOLDMAT. +C ALSO, DETERMINE I1 = CHARACTER NO. FOR COMMA 1, IN ORDER TO KNOW +C WHERE TO WRITE THE IDEVENT NO. WHICH WILL ALWAYS BE 1. + + ICOMMA = 0 + + DO I = 1,150 + IF(READLINE(I:I) .EQ. ',') THEN + ICOMMA = ICOMMA + 1 + IF(ICOMMA .EQ. 1) I1 = I + IF(ICOMMA .EQ. 2) I2 = I + IF(ICOMMA .EQ. 3) THEN + I3 = I + GO TO 60 + ENDIF + ENDIF + END DO + + 60 READLINE2 = + 1 READLINE(1:I1)//'1,'//TIMCHAR(1:IEND)//READLINE(I3:150) + NROW = NROW + 1 + HOLDMAT(NROW) = READLINE2(1:150) + + END DO + +C THE ABOVE END DO IS FOR THE DO IADD = 1,IADDL LOOP. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IADDL .GT. 0) CONDITION. + + + + IF(IADDL .EQ. -1) THEN + + +C WRITE JUST ONE LINE TO THE NEW .CSV FILE, EVEN THOUGH IADDL = -1 +C REPRESENTS A STEADY STATE DOSE SET OF 100 DOSES. MAKE THE TIME FOR +C THIS EVENT = -II SO READBLOCK/WRITEDOS WILL KNOW THIS IS A LINE WITH +C STEADY STATE DOSE INFO. + + CALL AFTERCOMMA(NCOVA,READLINE,6) + BACKSPACE(57) + READ(57,*,ERR=65) XII + CLOSE(57) + GO TO 70 + + 65 WRITE(*,36) NROW + 3 + + OPEN(47,FILE=ERRFIL) + WRITE(47,36) NROW + 3 + CLOSE(47) + + + + CALL PAUSE + STOP + + 70 CONTINUE + + + +C NOW ESTABLISH THE NEXT LINE OF HOLDMAT AS THE CURRENT +C READLINE, BUT WITHOUT THE ENTRIES FOR ADDL AND II; THEN RESET +C READLINE TO BE THIS NEW LINE. + + NROW = NROW + 1 + CALL GETCOM(NCOMMA,READLINE,I5,I7) + HOLDMAT(NROW) = READLINE(1:I5)//READLINE(I7+1:150) + READLINE(1:150) = HOLDMAT(NROW) + +C NOW ESTABLISH READLINE2 = READLINE, BUT WITH THE TIME VALUE RESET +C TO BE TIME = -XII. TO DO THIS, WRITE -XII TO SCRATCH FILE 57; THEN +C REREAD THIS VALUE AS A CHARACTER SO IT CAN BE INSERTED INTO +C THE CHARACTER STRING READLINE AND THEN WRITTEN TO THE HOLDING +C MATRIX. + + OPEN(57,STATUS='SCRATCH') + WRITE(57,*) -XII + BACKSPACE(57) + READ(57,41) TIMCHAR + + CLOSE(57) + +C TAKE OUT ALL SPACES AT THE END OF TIMCHAR. + + DO IEND = 50,1,-1 + IF(TIMCHAR(IEND:IEND) .NE. ' ') GO TO 80 + END DO + + 80 CONTINUE + + +C NOW TIMCHAR(1:IEND) IS THE CONDENSED FORM OF THE TIME FOR THIS +C ROW. REPLACE WHAT IS CURRENTLY BETWEEN COMMAS 2 AND 3 OF +C HOLDMAT(NROW) WITH THIS, AND STORE IT BACK INTO THE SAME ROW OF +C HOLDMAT. + + ICOMMA = 0 + + DO I = 1,150 + IF(READLINE(I:I) .EQ. ',') THEN + ICOMMA = ICOMMA + 1 + IF(ICOMMA .EQ. 2) I2 = I + + IF(ICOMMA .EQ. 3) THEN + I3 = I + GO TO 90 + ENDIF + ENDIF + END DO + + 90 READLINE2 = + 1 READLINE(1:I2)//TIMCHAR(1:IEND)//READLINE(I3:150) + HOLDMAT(NROW) = READLINE2(1:150) + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(IADDL .EQ. -1) CONDITION. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) CONDITION. + + + GO TO 20 + + + 100 CONTINUE + +C AS OF NPAG109.FOR, WRITE LINE TO THE SCREEN TELLING THE USER WHICH +C SUBJECT IS BEING CONVERTED, IN CASE THERE ARE A LARGE NO. OF PATIENTS +C WITH A LOT OF DATA. OTHERWISE, THERE COULD BE A LONG "DEAD" TIME ON +C THE SCREEN MAKING THE PROGRAM LOOK LIKE IT HAS "HUNG". + + + + WRITE(*,103) SUBID + 103 FORMAT(' EXAMINING .CSV FORMAT FOR SUBJECT ',A11) + + + +C THE FIRST TWO LINES OF FILE 66 WERE WRITTEN ABOVE. NOW WRITE THE +C REST OF THE FILE. + +C NOTE THAT IN EACH SECTION OF DOSES (I.E., UNTIL THE NEXT IDEVENT +C = 4), MUST ORDER THE DOSES SINCE THEY COULD BE OUT OF ORDER DUE TO +C THE ADDL ENTRY. + +C FOR EXAMPLE, A DOSE OF T = 0 WITH ADDL = 2 AND II = 12 --> DOSES AT +C T = 0, 12, AND 24. THEN ANOTHER DOSE (FOR A DIFFERENT DRUG, OR THE +C SAME DRUG WITH A DIFFERENT ROUTE) COULD OCCUR AT T = 8. THEN, FROM +C THE ABOVE CODE, THE CURRENT DOSE TIMES WOULD BE [0 12 24 8]. + +C SO GO THROUGH THE NROW ROWS OF HOLDMAT, AND ORDER THE ROWS IN EACH +C SECTION (I.E., UNTL THE NEXT IDEVENT = 4 ROW). IN PARTICULAR, FIRST +C ORDER THE DOSE ROWS (IDEVENT = 1). IF THESE ROWS FOLLOW AN +C IDEVENT = 4 ROW, THAT ROW GOES FIRST OF COURSE. THEN WRITE IN THE +C OBSERVATION ROWS (THEY SHOULD ALREADY BE IN ORDER). + +C PUT ALL THE IDEVENT ENTRIES IN HOLDMAT INTO IDENTRY(.), AND PUT ALL +C THE TIME ENTRIES IN HOLDMAT INTO TIMENTRY(.). + + DO I = 1,NROW + + READLINE(1:150) = HOLDMAT(I) + + CALL AFTERCOMMA(NCOVA,READLINE,1) + + BACKSPACE(57) + READ(57,*) IDEVENT + IDENTRY(I) = IDEVENT + + CLOSE(57) + + CALL AFTERCOMMA(NCOVA,READLINE,2) + BACKSPACE(57) + READ(57,*) TIM + TIMENTRY(I) = TIM + CLOSE(57) + + END DO + + + NN = 0 + NFIRST = 1 + +C NN IS THE RUNNING INDEX OF THE ROW IN HOLDMAT UNDER CONSIDERATION. + +C NFIRST IS THE RUNNING INDEX OF THE FIRST ROW IN THE NEXT SECTION + +C UNDER CONSIDERATION. + + 150 CONTINUE + + + +C ORDER ALL THE ROWS UNTIL THE NEXT IDENTRY(.) = 4, OR UNTIL THE +C END OF THE ROWS IS ENCOUNTERED, WHICHEVER COMES FIRST. + + NN = NN + 1 + IF(NN .GT. NROW) GO TO 200 + + IF(IDENTRY(NN) .NE. 4 .AND. NN .LT. NROW) GO TO 150 + +C ORDER THE ENTRIES IN HOLDMAT FROM NFIRST TO EITHER NROW +C (IF NN = NROW) OR TO NN-1 (IF IDENTRY(NN) = 4), AND THEN + + +C WRITE THEM INTO FILE 66. + + IF(NN .EQ. NROW) NLAST = NROW + IF(IDENTRY(NN) .EQ. 4) NLAST = NN - 1 + CALL ORDERHOLD(HOLDMAT,NFIRST,NLAST,IDENTRY,TIMENTRY) + + + 151 FORMAT(A150) + + + + DO I = NFIRST,NLAST + WRITE(66,151) HOLDMAT(I) + END DO + + + NFIRST = NLAST + 1 + + GO TO 150 + + + 200 CONTINUE + +C IF FILE 67 HAS BEEN COMPLETELY READ, RETURN. + + IF(IEND .LT. 0) THEN + CLOSE(67) + RETURN + + ENDIF + + +C SINCE IEND .GE. 0, THE FILE HAS NOT BEEN COMPLETELY READ. SO, RESET +C SUBIDPREV = SUBID AND NROW TO BE 0, AND BACKSPACE FILE 67 SINCE THE +C FIRST LINE FOR THE NEXT SUBJECT WAS ALREADY READ (I.E., THE NEXT +C READ OF FILE 67 SHOULD REREAD THIS FIRST LINE) AND GO BACK TO LABEL +C 20 TO CONTINUE READING THE FILE. + + + SUBIDPREV = SUBID + NROW = 0 + BACKSPACE(67) + GO TO 20 + + + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE GETCOM(NCOMMA,READLINE,I5,I7) + + CHARACTER READLINE*1000,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C GETCOM IS CALLED BY CVSCHANGE TO FIND THE ENTRY NO. FOR COMMA NO. 5 +C (I5), AND THE ENTRY FOR COMMA NO. 7 (I7). + + + 1 FORMAT(A1000) + + ICOMMA = 0 + + DO I = 1,300 + IF(READLINE(I:I) .EQ. ',') THEN + ICOMMA = ICOMMA + 1 + + IF(ICOMMA .EQ. 5) I5 = I + + IF(ICOMMA .EQ. 7) THEN + I7 = I + RETURN + ENDIF + ENDIF + END DO + +C TO GET TO THIS POINT MEANS THAT READLINE DOESN'T HAVE 7 COMMAS IN +C IT. REPORT THIS ERROR TO THE USER AND STOP. + + WRITE(*,2) NCOMMA,READLINE(1:70) + 2 FORMAT(/' ONE OF THE LINES IN YOUR .cvs FILE HAS AN ERROR.'/ + 1' IT IS SUPPOSED TO HAVE ',I2,' COMMAS, BUT IT HAS FEWER THAN'/ + 2' 7. THE FOLLOWING LINE SHOWS THE 1ST 70 CHARACTERS OF THE LINE:'/ + 3' ',A70// + 4' THE PROGRAM STOPS.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,2) NCOMMA,READLINE(1:70) + CLOSE(47) + + + + CALL PAUSE + STOP + + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE ORDERHOLD(HOLDMAT,NFIRST,NLAST,IDENTRY,TIMENTRY) + + IMPLICIT REAL*8(A-H,O-Z) + + DIMENSION TIMENTRY(99999),IDENTRY(99999),IZ(99999),IZZ(99999), + 1 DOSTIME(99999) + CHARACTER HOLDMAT(99999)*150,HOLDMAT2(99999)*150 + +C ORDER THE ENTRIES IN HOLDMAT FROM NFIRST TO NLAST, AS FOLLOWS: + +C 1. PUT ALL THE DOSE EVENTS (IDENTRY(.) = 1 OR 4) FIRST, ORDERED BY +C INCREASING TIMENTRY(.). + +C 2. PUT ALL THE OBSERVATION EVENTS (IDENTRY(.) = 0) AFTER THE DOSE +C EVENTS (THEY SHOULD ALREADY BE ORDERED). + + + +C FIRST, STORE THE DOSE ROWS FROM NFIRST TO NLAST IN HOLDMAT TO +C HOLDMAT2, STARTING AT ROW 1 IN HOLDMAT2. + +C ALSO, PUT ALL THE DOSE EVENTS TIMES INTO DOSTIME, AND INITIALIZE + +C VECTOR IZ TO BE -99 IN ALL ITS NDOSE LOCATIONS + + NDOSE = 0 + + DO I = NFIRST,NLAST + + IF(IDENTRY(I) .EQ. 1 .OR. IDENTRY(I) .EQ. 4) THEN + + NDOSE = NDOSE + 1 + + HOLDMAT2(NDOSE) = HOLDMAT(I) + DOSTIME(NDOSE) = TIMENTRY(I) + IZ(NDOSE) = -99 + ENDIF + END DO + +C NOW, FOR EXAMPLE, IF ENTRY 17 IS THE SMALLEST VALUE IN DOSTIME, +C IZ(17) WILL BE SET = 0, AND THE PROGRAM WILL KNOW NOT TO CHECK THE +C 17TH ENTRY AGAIN (SINCE IT HAS ALREADY BEEN SELECTED). IF THE NEXT +C SMALLEST ENTRY HAS INDEX 37, THEN IZ(37) WILL BE SET = 0, ETC. + +C NOTE THAT IZZ WILL BE THE ARRAY WHICH CONTAINS THE ACTUAL ORDERING. +C IN THE EXAMPLE ABOVE, IZZ(1) = 17, IZZ(2) = 37. IT WILL BE EASY TO +C ASSIGN ORDERED VALUES BACK INTO HOLDMAT USING IZZ. IN THE EXAMPLE +C ABOVE, HOLDMAT(1) WILL HAVE DOSE TIME = DOSTIME(IZZ(1)) = +C DOSTIME(17); HOLDMAT(2) WILL HAVE DOSE TIME = DOSTIME(IZZ(2)) = +C DOSTIME(37); ETC. + + +C NOW PUT THE OBSERVATION ROWS FROM NFIRST TO NLAST IN HOLDMAT TO +C HOLDMAT2, STARTING AT ROW NDOSE + 1 IN HOLDMAT2. + + NEXT = NDOSE + + DO I = NFIRST,NLAST + IF(IDENTRY(I) .EQ. 0) THEN + NEXT = NEXT + 1 + HOLDMAT2(NEXT) = HOLDMAT(I) + + ENDIF + END DO + + +C NOW ORDER THE FIRST NDOSE ROWS IN HOLDMAT2 ACCORDING TO THE DOSE +C TIMES, LOW TO HIGH. + + DO IPLACE = 1,NDOSE + +C PUT THE NEXT LOWEST VALUE OF DOSTIME INTO THE IPLACE LOCATION OF +C IZZ. + + +C TEMP IS THE RUNNING VALUE OF THE NEXT VALUE TO BE PLACED INTO +C DOSTIME. INITIALIZE IT TO BE VERY HIGH VALUE SO THE FIRST VALUE +C OF DOSTIME WILL BE SURE TO BE LOWER THAN IT IS. + + TEMP = 1.D50 + + DO I=1,NDOSE + + IF(DOSTIME(I) .LT. TEMP .AND. IZ(I) .EQ. -99) THEN + + TEMP = DOSTIME(I) + IND = I + ENDIF + END DO + + +C AT THIS POINT, IND IS THE INDEX OF THE SMALLEST REMAINING VALUE +C (TEMP) IN DOSTIME. PUT THIS INFORMATION INTO IZZ. ALSO, SET +C IZ(IND) = 0 --> THE IND LOCATION IN DOSTIME HAS BEEN USED. + + IZZ(IPLACE) = IND + IZ(IND) = 0 + + END DO + +C AT THIS POINT IZZ CONTAINS THE ORDERED INDICES (LOW TO HIGH) OF THE +C NDOSE VALUES IN DOSTIME, AND SO GIVES THE ORDER THAT THE NDOSE ROWS +C NOW IN HOLDMAT2 SHOULD BE WRITTEN. + +C WRITE THESE NDOSE DOSE ROWS IN THE CORRECT ORDER INTO HOLDMAT, AND +C THEN WRITE THE REMAINING ROWS (OBSERVATION ROWS) INTO HOLDMAT. + + DO IDOSE = 1,NDOSE + HOLDMAT(NFIRST-1+IDOSE) = HOLDMAT2(IZZ(IDOSE)) + END DO + +C STORE THE OBSERVATION ROWS INTO ENTRIES NFIRST + NDOSE,..., NLAST OF +C HOLDMAT. THEY WERE STORED INTO THE LAST NOBS ROWS OF HOLDMAT2 ABOVE. + + NEXT = NDOSE + + DO IOBS = NFIRST + NDOSE,NLAST + NEXT = NEXT + 1 + HOLDMAT(IOBS) = HOLDMAT2(NEXT) + END DO + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE MAKETMP(TNEXT,MAXOBDIM,ND42) + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION RS(34),YO(MAXNUMEQ),TIM41(594) + CHARACTER READLINE*1000,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + COMMON/TOCALCTP/M41,TIM41 + +C THIS SUBROUTINE, CALLED BY MAIN, READS WORKING COPY FILES 41 +C (TMPFILE1) AND 42 (TMPFILE2) AND MAKES ANOTHER WORKING COPY FILE, +C 43 (TMPFILE) WHICH HAS THE FOLLOWING CHARACTERISTICS: +C IT HAS ALL THE DOSES (BUT NOT THE OBSERVATIONS IN FILE 41). +C IT HAS ALL THE DOSES AND OBSERVATIONS IN FILE 42, BUT WITH EACH OF +C THE CORRESPONDING TIMES INCREASED BY TNEXT. + +C NOTE THAT THIS ROUTINE RETURNS ND42 (THE NO. OF DOSES IN FILE 42), +C WHERE THE DOSES TO BE OPTIMIZED OVER ARE ND41+1 TO ND IN FILE 42, +C WHERE ND41 + ND42 = ND. + + + 1 FORMAT(A1000) + +C WRITE ALL THE LINES FROM FILE 41 TO FILE 43, DOWN TO AND INCLUDING +C THE LINE WITH THE NO. OF DRUGS ON IT. + + 10 READ(41,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF DRUGS') THEN + WRITE(43,1) READLINE + GO TO 10 + ENDIF + + WRITE(43,1) READLINE + +C BACKSPACE AND READ THE NO. OF DRUGS FROM FILE 41, FOLLOWED BY THE +C NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE EVENTS. + + + BACKSPACE(41) + + 3 FORMAT(T2,I5) + READ(41,3) NDRUG41 + + + IF(NDRUG41 .GT. 7) THEN + + WRITE(*,124) NDRUG41 + 124 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ + 1' THE SUBJECT HAS ',I3,' DRUGS, MORE THAN THE ALLOWABLE 7.'// + 2' THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,124) NDRUG41 + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + READ(41,3) NADD41 + +C BACKSPACE FILE 41, AND WRITE THIS LINE (NO. OF ADDTIONAL COVS) TO +C FILE 43. + + BACKSPACE(41) + READ(41,1) READLINE + WRITE(43,1) READLINE + + +C NOW VERIFY THAT FILE 42 HAS THE SAME NO. OF DRUGS AND ADDITIONAL +C COVARIATES AS FILE 41. IF NOT, WRITE MESSAGE TO USER AND STOP. + + 20 READ(42,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 20 + +C BACKSPACE AND READ THE NO. OF DRUGS FROM FILE 42, FOLLOWED BY THE +C NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE EVENTS. + + BACKSPACE(42) + READ(42,3) NDRUG42 + + + IF(NDRUG42 .NE. NDRUG41) THEN + + WRITE(*,126) NDRUG41,NDRUG42 + 126 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ + 1' THE SUBJECT HAS ',I3,' DRUGS, BUT THE FILE WITH THE "FUTURE" '/ + 2' FOR THIS SUBJECT HAS ',I3,' DRUGS. THE NO. OF DRUGS MUST BE'/ + 3' THE SAME IN THESE TWO FILES. THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,126) NDRUG41,NDRUG42 + CLOSE(47) + + CALL PAUSE + STOP + + + ENDIF + +C VERIFY THAT THTE NO. OF DRUGS IS NOT .GT. 7. IF SO, WRITE MESSAGE + +C AND STOP. + + IF(NDRUG41 .GT. 7) THEN + + WRITE(*,123) + 123 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 7'/ + 1' DRUGS. THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,123) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + READ(42,3) NADD42 + + IF(NADD42 .NE. NADD41) THEN + + WRITE(*,127) NADD41,NADD42 + 127 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ + 1' THE SUBJECT HAS ',I3,' ADDITIONAL COVARIATES, BUT THE FILE'/ + 2' WITH THE "FUTURE" FOR THIS SUBJECT HAS ',I3,' ADDITIONAL'/ + 3' COVARIATES. THE NO. OF ADDITIONAL COVARIATES MUST BE THE SAME'/ + 4' IN THESE TWO FILES. THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,127) NADD41,NADD42 + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + +C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND +C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE +C BEYOND THE FIRST 4 ABOVE, AGE, SEX, HEIGHT, AND ETHNICITY FLAG). + + NI = 2*NDRUG41 + NADD41 + + + IF(NI .GT. 34) THEN + + WRITE(*,132) + 132 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY COLUMNS IN '/ + 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ + 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ + 3' NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,132) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + +C BOTH FILE 41 AND FILE 42 ARE AT THE LINE WHERE THE NO. OF DOSE +C EVENTS IS READ. HAVE EACH FILE READ THE NO. OF DOSE EVENTS, AND +C THEN ADD THEM TO GET THE NO. OF DOSE EVENTS FOR FILE 43. + + + READ(41,3) ND41 + READ(42,3) ND42 + ND = ND41 + ND42 + +C WRITE ND AS THE NO. OF DOSE EVENTS TO FILE 43, AFTER VERIFYING THAT +C THIS NO. IS .LE. 5000 (THE MAXIMUM ALLOWED). + + + IF(ND .GT. 5000) THEN + + WRITE(*,133) ND41,ND42 + 133 FORMAT(' THE PATIENT DATA FILE WHICH IS TO CONTAIN THE DOSES '/ + 1' FOR BOTH THE "PAST" HISTORY, AND THE "FUTURE" HAS MORE THAN'/ + 2' 5000 DOSES ... ',I4,' IN THE "PAST", AND ',I4,' IN THE '/ + 3' "FUTURE". THIS IS TOO MANY. THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,133) ND41,ND42 + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + WRITE(43,13) ND + 13 FORMAT(I6,' ... NO. OF DOSE EVENTS') + +C WRITE THE LINES DOWN TO "TIME, IV/PO,.." WHICH STARTS IN COL. 5 +C TO FILE 43. AND THEN WRITE THIS LINE TO FILE 43. + + 30 READ(41,1) READLINE + IF(READLINE(5:15) .NE. 'TIME, IV/PO') THEN + WRITE(43,1) READLINE + GO TO 30 + + ENDIF + + WRITE(43,1) READLINE + +C OF THE ND = ND41 + ND42 DOSE EVENTS, THE FIRST ND41 COME FROM +C FILE 41. WRITE THESE DOSE EVENTS TO FILE 43. + + DO I = 1,ND41 + READ(41,*) SIG,(RS(J),J=1,NI) + WRITE(43,*) SIG,(RS(J),J=1,NI) + END DO + +C AS OF BESTDOS119.FOR, MUST SAVE + +C WRITE THE LAST ND42 DOSE EVENTS (THOSE FROM FILE 42) TO FILE 43, + +C BUT INCREASE EACH TIME BY TNEXT. BUT FIRST READ FILE 42 DOWN TO +C WHERE THE DOSE EVENTS OCCUR. + + 60 READ(42,1) READLINE + IF(READLINE(5:15) .NE. 'TIME, IV/PO') GO TO 60 + + DO I = 1,ND42 + READ(42,*) SIG,(RS(J),J=1,NI) + WRITE(43,*) SIG + TNEXT,(RS(J),J=1,NI) + END DO + + +C ALL 3 FILES ARE AT THE END OF THEIR DOSE EVENTS. WRITE THE LINES +C DOWN TO THE LINE WITH THE TOTAL NO. OF OUTPUT EQS. TO FILE 43, +C INCLUDING THIS LINE. + + 40 READ(41,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') THEN + WRITE(43,1) READLINE + GO TO 40 + ENDIF + + WRITE(43,1) READLINE + +C BACKSPACE FILE 41 AND READ THE NO. OF OUTPUT EQS. + + BACKSPACE(41) + READ(41,3) NUMEQT41 + +C AS OF BESTDOS110.FOR, SAVE THE OBSERVED VALUE TIMES FROM THE +C "PAST" INTO AN ARRAY THAT WILL BE PROVIDED BY COMMON/TOCALCTP TO +C SUBROUTINE CALCTPRED. THESE VALUES ARE NOT NEEDED IN THE WRITING OF +C FILE 43 IN THIS ROUTINE, BUT THEY WILL BE NEEDED IN SUBROUTINE +C CALCTPRED. + + READ(41,3) M41 + + DO I = 1,M41 + READ(41,*) TIM41(I) + END DO + + +C READ THESE SAME VALUES FROM FILE 42. + + 50 READ(42,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 50 + BACKSPACE(42) + READ(42,3) NUMEQT42 + NUMEQT = NUMEQT42 + + READ(42,3) M42 + +C VERIFY THAT FILE 42 HAS THE SAME NO. OF OUTPUT EQS. AS FILE 41. +C IF NOT, WRITE A MESSAGE TO THE USER AND STOP. + + IF(NUMEQT42 .NE. NUMEQT41) THEN + + + + WRITE(*,128) NUMEQT41,NUMEQT42 + 128 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ + 1' THE SUBJECT HAS ',I3,' OUTPUT EQS., BUT THE FILE WITH THE'/ + 2' "FUTURE" FOR THIS SUBJECT HAS ',I3,' OUTPUT EQS. THE NO. OF'/ + 3' OUTPUT EQS. MUST BE THE SAME IN THESE TWO FILES. THE PROGRAM'/ + 4' IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,128) NUMEQT41,NUMEQT42 + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + + +C VERIFY THAT THE NO. OF OUTPUT EQS. IS NOT .GT. MAXNUMEQ. + + IF(NUMEQT41 .GT. MAXNUMEQ) THEN + + + + WRITE(*,129) MAXNUMEQ + 129 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY OUTPUT EQUATION'/ + 1' COLUMNS. THIS NO. CANNOT EXCEED ',I2,'. THE PROGRAM IS NOW '/ + 2' STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,129) MAXNUMEQ + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + +C NOTE THAT THE NO. OF OBSERVED VALUES IS M, WHICH +C FOR THIS PATIENT WILL BE M42 (I.E., ONLY THE OBSERVED VALUES FROM +C THE "FUTURE" WILL BE PUT INTO FILE 43). + + M = M42 + +C WRITE M AS THE NO. OF OBSERVED VALUE TIMES TO FILE 43, AFTER +C VERIFYING THAT THIS NO. IS .LE. MAXOBDIM (THE MAXIMUM ALLOWED). + + + IF(M .GT. MAXOBDIM) THEN + + + + WRITE(*,131) M,MAXOBDIM + 131 FORMAT(' THE PATIENT DATA FILE WHICH IS THE "FUTURE" OF THE '/ + 1' SUBJECT HAS ',I4,' OBSERVED VALUES, MORE THAN THE MAXIMUM'/ + 2' ALLOWED VALUE OF ',I4,'. THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,131) M,MAXOBDIM + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + +C WRITE THE LINE WITH THE NO. OF OBSERVED VALUE TIMES TO FILE 43. +C THEN WRITE THE M = M42 OBSERVED VALUES FROM FILE 42, ALONG WITH +C THE CORRESPONDING TIMES, BUT INCREASE EACH TIME BY TNEXT. + + WRITE(43,14) M + 14 FORMAT(I6,' ... NO. OF OBSERVED VALUE TIMES') + + DO I = 1,M + READ(42,*) TIM,(YO(J),J=1,NUMEQT) + WRITE(43,*) TIM + TNEXT,(YO(J),J=1,NUMEQT) + END DO + +C NOW COPY THE REST OF FILE 42 (WHICH INCLUDES THE COVARIATE NAMES, +C AND VALUES, AND THE ASSAY COEFFICIENTS) TO FILE 43. + + + 70 READ(42,1,IOSTAT=IEND) READLINE + IF(IEND .LT. 0) GO TO 100 + WRITE(43,1) READLINE + GO TO 70 + + 100 CLOSE(43) + CLOSE(42) + CLOSE(41) + + RETURN + END + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE INSPECTOBS(MAXOBDIM,IPRIOROBS) + +C INSPECTOBS IS CALLED BY MAIN TO READ FILE 21 AND RETURN 1 IF THERE +C ARE NON-MISSING OBSERVATIONS, AND 0 OTHERWISE. + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + DIMENSION YO(MAXOBDIM,MAXNUMEQ) + CHARACTER READLINE*1000 + + 1 FORMAT(A1000) + 3 FORMAT(T2,I5) + +C READ DOWN TO THE OBSERVATIONS ... TO THE LINE WITH +C 'NO. OF TOTAL' AS ENTRIES 12:23. + + 10 READ(21,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 10 + +C BACKSPACE AND READ THE NO. OF OUTPUT EQS. AND THEN READ THE +C NO. OF OBSERVED VALUE TIMES. + + BACKSPACE(21) + READ(21,3) NUMEQT + READ(21,3) M + + DO I = 1,M + READ(21,*) TIM,(YO(I,J),J=1,NUMEQT) + END DO + +C DEFAULT IPRIOROBS = 0. IT WILL CHANGE TO BE 1 IF ANY OF THE +C OBSERVED VALUES ARE NOT MISSING (I.E., NOT = -99). + +C NOTE THAT ISAME, RETURNED FROM CALL TO THESAME, IS 1 IF THE TWO +C ARGUMENTS ARE WITHIN 1.D-10 OF EACH OTHER (I.E., VIRTUALLY THE SAME +C VALUE); OTHERWISE IT RETURNS AS 0. + + IPRIOROBS = 0 + + DO I =1,M + DO J = 1,NUMEQT + CALL THESAME(YO(I,J),-99.D0,ISAME) + IF(ISAME .EQ. 0) IPRIOROBS = 1 + END DO + END DO + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C +C??? AFTER FINISHING THIS ROUTINE, WILL HAVE TO MODIFY CALCTPRED2 +CIN A SIMILAR WAY I THINK SINCE IT IS ALSO BASED ON FILD37, WHICH +CHAS STEADY STATE DOSE SETS POSSIBLE IN THE PAST. + + + + + SUBROUTINE CALCTPRED(IDELTA,NOBSER,TNEXT,NUMT,TPRED,TPREDREL) +C??? TPREDREL ADDED ABOVE. 7/4. + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION TPRED(72000),TIM(594),SIG(5000),RS(5000,34), + 1 BS(5000,7),YOO(594,MAXNUMEQ),TVECT(72000),TIM41(594), + 2 TPREDREL(72000) +C??? TPREDREL ADDED ABOVE. 7/4. + + COMMON/OBSER/ TIM,SIG,RS,YOO,BS + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/TOCALCTP/M41,TIM41 + +C??? EDITED COMMENTS BELOW. 7/4. +C AS OF BESTDOS119.FOR, THE LOGIC OF CALCTPRED FROM BESTDOS108.FOR +C IS PUT BACK INTO THIS ROUTINE. THAT LOGIC ALLOWED STEADY STATE +C DOSE SETS (AND TIME RESETS, ALTHOUGH THERE WILL BE NO TIME RESETS +C FOR THE TIME BEING AT LEAST). NOTE THERE CAN BE AT MOST 1 STEADY +C STATE DOSE SET, AND IT HAS TO BE AT THE BEGINNING OF THE PATIENT +C FILE IF IT OCCURS. + +C NOTE THAT THE LOGIC OF ADDING OBSERVATION AND DOSE TIMES TO THE +C REGULAR PREDICTED TIMES (WHICH ARE IDELTA/60 HOURS APART) IS +C TEMPORARILY REMOVED ... IT CAN BE PUT BACK IN AFTER VERIFYING THAT +C THE REGULAR PREDICTED TIMES GET PUT IN PROPERLY. + + +C THIS ROUTINE IS CALLED BY MAIN TO CALCULATE THE NUMT TIMES TO BE +C PUT INTO TPRED. THESE WILL BE THE REGULAR PREDICTED +C TIMES WHICH START AT 0, ARE IDELTA/60 HOURS APART, AND CONTINUE UNTIL +C 24 HOURS AFTER THE LAST OBSERVATION TIME, ALONG WITH ALL THE DOSE AND +C ALL THE OBSERVATION TIMES (REDUNDANT TIMES WILL BE IGNORED OF +C COURSE). <-- FOR NOW SKIP THE DOSE AND OBSERVATION TIMES. + +C NOTE THAT THE REGULAR TIMES ARE TO BE IDELTA MINUTES APART, SUBJECT +C TO THE CONSTRAINT THAT THE MAXIMUM NO. OF TIMES BE 72000. +C BUT NOTE BELOW THAT THE TIMES IN TPRED ARE IN HOURS, NOT MINUTES. +C AND NOTE IF A STEADY STATE DOSE SET OCCURS AT THE BEGINNING OF A +C PATIENT FILE (THE ONLY PLACE IT CAN OCCUR IN THIS PROGRAM), TIMES IN +C TPRED WILL START AT THE END OF IT, RATHER THAN AT 0. + +C FOR EXAMPLE, IF THERE IS A STEADY STATE DOSE SET WITH INTERDOSE +C INTERVAL = DOSEINT, THEN THE TIMES WILL START AT 100*DOSEINT +C (SINCE EACH STEADY STATE DOSE SET IS ASSUMED TO HAVE 100 DOSES). +C AS A SPECIFIC EXAMPLE, IF A STEADY STATE DOSE SET WITH INTERDOSE +C INTERVAL OF 2 HOURS STARTS AT TIME 0 AND THE 1ST OBS. TIME IS AT +C 205, IT REALLY MEANS THAT THE OBSERVATIONS START 5 HOURS AFTER THE +C END OF THE STEADY STATE DOSE SET. IN THIS CASE, THE TIMES IN TPRED +C STILL START AT 200. + +C BUT, ALSO ESTABLISH TPREDREL(.) WHICH IS SIMILAR +C TO TPRED, BUT HAS "RELATIVE" INSTEAD OF "REAL" TIMES AFTER STEADY +C STATE DOSES. IN THE EXAMPLE ABOVE WITH AN INTERDOSE INTERVAL OF 2 +C HOURS, THE TPRED(.) VALUES START AT 200 AND THE TPREDREL(.) VALUES +C START AT 0. AND EACH TPREDREL(I) = TPRED(I) - 200. + +C !!! AS OF BESTDOS119.FOR, TPRED VALUES WILL START AT 0 UNLESS THE +C CORRESPONDING DOSES FOR THIS TIME BLOCK START WITH A STEADY STATE +C SET. IN THAT CASE, THE TPRED VALUES WILL START FROM THE END OF THE +C STEADY STATE SET. THE STARTING DOSE TIME IS IN SIG(1). IF +C THIS VALUE IS < 0, IT REPRESENTS THE START OF A STEADY STATE DOSE +C SET, WITH INTERDOSE INTERVAL = -SIG(1). OTHERWISE, SIG(1) SHOULD +C BE 0 (I.E., IF THERE IS NO STEADY STATE SET). + +C NOTE THAT, AS INDICATED ABOVE, THE TPREDREL VALUES WILL ALWAYS START +C AT 0. + + TBEG = 0.D0 + IF(SIG(1) .LT. 0.D0) TBEG = 100.D0*(-SIG(1)) + + + +C THERE ARE NOBSER OBSERVATION TIMES IN TIM. SET TIMMAX TO THE LAST +C ONE, WHICH IS THE LARGEST, AND THEN SET T_END = 24 HOURS AFTER +C TIMMAX. + + TIMMAX = TIM(NOBSER) + T_END = TIMMAX + 24.D0 + +C PUT THE REGULAR TIMES IN TVECT; THEY START AT TBEG AND END AT T_END, +C AND ARE IDELTA/60 HOURS APART. SO THERE WILL BE +C (T_END - TBEG)*60/IDELTA + 1 OF THEM. NOTE THAT IF 60/IDELTA IS NOT +C AN INTEGER, THE ENDING TIME WILL BE A LITTLE DIFFERENT THAN EXACTLY +C 24 HOURS AFTER TIMMAX. + + NUMT2 = (T_END - TBEG)*60/IDELTA + + NUMTT = 1 + TVECT(NUMTT) = TBEG + + + + DO I=1,NUMT2 + NUMTT = NUMTT + 1 + TVECT(NUMTT) = TVECT(NUMTT-1) + IDELTA/60.D0 + END DO + + +C AS IF BESTDOS109.FOR, ADD INTO TVECT ALL THE OBSERVATION AND DOSE +C TIMES. THEN CALL PUTORDER TO ORDER ALL THE TIMES IN TVECT; AND +C FINALLY, REMOVE ALL DUPLICATE TIMES. + + DO I = 1,NOBSER + NUMTT = NUMTT + 1 + TVECT(NUMTT) = TIM(I) + + + END DO + +C ADD IN THE DOSE TIMES, BUT ONLY THOSE THAT OCCUR AFTER TBEG. FOR +C EXAMPLE, IF SIG(1) = -2 (INDICATING A STEADY STATE DOSE SET WHICH +C ENDS AT TBEG = 200, THEN WE WANT TO ADD ONLY THOSE DOSE TIMES THAT +C OCCUR AFTER THE END OF THIS STEADY STATE DOSE SET. + + DO I = 1,ND + IF(SIG(I) .GT. TBEG) THEN + NUMTT = NUMTT + 1 + TVECT(NUMTT) = SIG(I) + ENDIF + END DO + + + +C AS OF BESTDOS110.FOR, ALSO ADD INTO TVECT THE OBSERVATION TIMES +C FROM THE "PAST". + +C NOTE THAT THE NOBSER OBSERVATION TIMES IN TIM(.) ADDED ABOVE TO +C TVECT WERE JUST FROM THE "FUTURE", BECAUSE THESE VALUES WERE +C FILLED IN SUBROUTINE FILRED, WHEN IT READ FILE 37 (AND FILE 37 +C WAS EITHER JUST THE "FUTURE" IF INCLUDPAST = 0 IN MAIN; OR +C WAS "BOTHFILES.ZPJ", CREATED BY SUBROUTINE MAKETMP IF THERE WAS +C A "PAST", AND "BOTHFILES.ZPJ DOES NOT INCLUDE "PAST" OBSERVATIONS). + +C NOTE THAT IF INCLUDPAST = 0 IN MAIN, THEN M41 WAS SET = 0. IN THIS +C CASE, OF COURSE, THERE ARE NO TIMES TO ADD SINCE THERE WAS NO +C "PAST" HISTORY.N + +C NOTE THAT SIG(1) = 0 MEANS THAT THE PATIENT DOES NOT HAVE ITS +C REGIMEN BEGINNING WITH A STEADY STATE DOSE SET. BUT SIG(1) < 0 +C MEANS THAT THE REGIMEN DOES BEGIN WITH A STEADY STATE DOSE SET. +C IN THIS CASE, THE TIM41(.) VALUES REFER TO TIMES AFTER THE END OF +C THE STEADY STATE DOSES. I.E., THEY SHOULD BE INCREASED BY +C 100*(-SIG(1)). + +C EX: SIG(1) = -2.0 AND TIM(.) = 5, 10, 20 --> THESE TIMES ARE +C ACTUALLY AT REAL TIMES 205, 210, AND 220. +C SO ADD 100*(-SIG(1)) TO ALL OBS. TIMES IN TIM41(.) IF SIG(1) < 0. + + + + IF(M41 .GT. 0) THEN + DO I = 1,M41 + NUMTT = NUMTT + 1 + IF(SIG(1) .LT. 0.D0) TVECT(NUMTT) = TIM41(I) - 100.D0*SIG(1) + IF(SIG(1) .GE. 0.D0) TVECT(NUMTT) = TIM41(I) + END DO + ENDIF + +C ADD IN THE TIME WHICH STARTS THE "FUTURE". THIS IS TNEXT IF +C THERE IS NO STEADY STATE DOSE SET TO START THE PATIENT FILE, OR +C TNEXT + 100*(-SIG(1)) OTHERWISE. ACTUALLY THIS LATTER FORMULA +C WORKS REGARDLESS, SINCE SIG(1) = 0 IF THESE IS NO STEADY STATE +C DOSE SEST. + + NUMTT = NUMTT + 1 + TVECT(NUMTT) = TNEXT - 100.D0*SIG(1) + +C ORDER ALL THE TIMES IN TVECT. + + CALL PUTORDER(NUMTT,TVECT) + +C THE NUMTT VALUES ARE NOW ORDERED IN TVECT. NOW REMOVE DUPLICATE +C TIMES BELOW. NUMT WILL BE THE RUNNING NO. OF TIMES CURRENTLY +C STORED INTO TVECT, WHEN DUPLICATE TIMES ARE IGNORED. + + TIMELAST = -1.D39 + + NUMT = 0 + + DO I = 1,NUMTT + + TIME = TVECT(I) + CALL THESAME(TIME,TIMELAST,ISAME) + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TIME = TIMELAST (OR AT +C LEAST, THEY ARE WITHIN 1.D-10), AND THIS TIME CAN BE IGNORED SINCE IT +C WAS ALREADY PUT INTO TVECT BY A PREVIOUS TIME. + + IF(ISAME .EQ. 1) GO TO 30 + +C TO GET HERE, ISAME = 0, WHICH MEANS THIS IS A NEW TIME. SO PUT +C TIME INTO TVECT. THEN SET TIMELAST = TIME AND CONTINUE THE LOOP. + + NUMT = NUMT + 1 + TVECT(NUMT) = TIME + TIMELAST = TIME + + 30 CONTINUE + + END DO +C THE ABOVE END DO IS FOR THE DO I = 1,NUMTT LOOP. + + +C NOW STORE THESE NUMT TIMES INTO TPRED, BUT IF NUMT IS > 72000, +C ONLY STORE THE FIRST 72000, AND WRITE MESSAGE TO THE SCREEN AND +C THE OUTPUT FILE. ALSO ESTABLISH TPREDREL(.) WHICH ARE THE TIMES +C RELATIVE TO THE END OF A STEADY STATE DOSE SET IF THERE IS ONE. + + IF(NUMT .GT. 72000) THEN + + DO I = 1,72000 + TPRED(I) = TVECT(I) + TPREDREL(I) = TPRED(I) - TBEG + END DO + + WRITE(*,2031) + WRITE(56,2031) + + + 2031 FORMAT(//' THE MAXIMUM NO. OF PREDICTED VALUES HAS BEEN REACHED.'/ + 1' THIS MEANS THERE WILL NOT BE A COMPLETE SET OF PREDICTED '/ + 2' VALUES FOR EACH GRID PT. IN THE OUTPUT FILE.'/) + + NUMT = 72000 + RETURN + + ENDIF +C THE ABOVE ENDIF IS FOR THE IF(NUMT .GT. 72000) CONDITION. + + +C NOW ASSIGN TPRED VALUES IF NUMT .LE. 72000. IN THIS CASE, THERE WILL + +C BE NO WARNING MESSAGE TO THE SCREEN OR THE OUTPUT FILE. + + + DO I = 1,NUMT + TPRED(I) = TVECT(I) + TPREDREL(I) = TPRED(I) - TBEG + END DO + + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE CALCTPRED2(NOBSER,TNEXT,IDELTA,NUMT,TPRED) + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION TPRED(72000),TIM(594),SIG(5000),RS(5000,34), + 1 BS(5000,7),YOO(594,MAXNUMEQ),TVECT(72000),TIM41(594) + + CHARACTER ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + COMMON/OBSER/ TIM,SIG,RS,YOO,BS + +C THIS ROUTINE IS CALLED BY WSUMSQ TO CALCULATE THE NUMT TIMES TO BE +C PUT INTO TPRED. THESE SHOULD BE A RICH SET OF TIMES BETWEEN TBEG AND +C THE LAST OBSERVED VALUE TIME, ALONG WITH ALL THE NOBSER OBSERVATION +C TIMES (REDUNDANT TIMES WILL BE IGNORED OF COURSE). + +C NOTE THAT THE TIMES IN TPRED WILL BE IDELTA MINUTES APART, BETWEEN +C TBEG AND THE LAST OBS. TIME, ALONG WITH THE OBS. TIMES THEMSELVES. + +C !!! AS OF BESTDOS119.FOR, THE CODE WILL ALLOW FOR A STEADY STATE +C DOSE SET AT THE BEGINNING OF THE PATIENT FILE. SO TPRED VALUES WILL +C START AT 0 UNLESS THE CORRESPONDING DOSES FOR THIS TIME BLOCK START +C WITH A STEADY STATE SET. IN THAT CASE, THE TPRED VALUES WILL START +C FROM THE END OF THE STEADY STATE SET. THE STARTING DOSE TIME IS IN +C SIG(1). IF THIS VALUE IS < 0, IT REPRESENTS THE START OF A STEADY +C STATE DOSE SET, WITH INTERDOSE INTERVAL = -SIG(1). OTHERWISE, SIG(1) +C SHOULD BE 0 (I.E., IF THERE IS NO STEADY STATE SET). + +C THE LAST OBSERVATION TIME IS TIM(NOBSER). SINCE THE TIMES IN TPRED +C WILL BE IDELTA MINUTES APART, THE NO. OF TIMES WILL BE +C TIM(OBSER)*60/IDELTA + 1, ALONG WITH ANY ADDITIONAL OBSERVATION +C TIMES. + + TBEG = 0.D0 + IF(SIG(1) .LT. 0.D0) TBEG = 100.D0*(-SIG(1)) + +C THERE ARE NOBSER OBSERVATION TIMES IN TIM. SET TIMMAX TO THE LAST +C ONE, WHICH IS THE LARGEST. + + TIMMAX = TIM(NOBSER) + +C PUT THE REGULAR TIMES IN TVECT; THEY START AT TBEG AND END AT +C TIMMAX, AND ARE IDELTA/60 HOURS APART. SO THERE WILL BE +C (TIMMAX - TBEG)*60/IDELTA + 1 OF THEM. NOTE THAT IF 60/IDELTA IS NOT +C AN INTEGER, THE ENDING TIME WILL BE A LITTLE DIFFERENT THAN EXACTLY +C TIMMAX. + + NUMT2 = (TIMMAX - TBEG)*60/IDELTA + NUMTT = 1 + TVECT(NUMTT) = TBEG + + DO I=1,NUMT2 + NUMTT = NUMTT + 1 + TVECT(NUMTT) = TVECT(NUMTT-1) + IDELTA/60.D0 + END DO + + +C NOW ADD INTO TVECT ALL THE OBSERVATION TIMES. + + DO I = 1,NOBSER + NUMTT = NUMTT + 1 + TVECT(NUMTT) = TIM(I) + END DO + + +C ADD IN THE TIME WHICH STARTS THE "FUTURE". THIS IS TNEXT IF +C THERE IS NO STEADY STATE DOSE SET TO START THE PATIENT FILE, OR +C TNEXT + 100*(-SIG(1)) OTHERWISE. ACTUALLY THIS LATTER FORMULA +C WORKS REGARDLESS, SINCE SIG(1) = 0 IF THESE IS NO STEADY STATE +C DOSE SEST. + + NUMTT = NUMTT + 1 + TVECT(NUMTT) = TNEXT - 100.D0*SIG(1) + + +C CALL PUTORDER TO ORDER ALL THE TIMES IN TVECT. + + CALL PUTORDER(NUMTT,TVECT) + +C THE NUMTT VALUES ARE NOW ORDERED IN TVECT. NOW REMOVE DUPLICATE +C TIMES BELOW. NUMT WILL BE THE RUNNING NO. OF TIMES CURRENTLY +C STORED INTO TVECT, WHEN DUPLICATE TIMES ARE IGNORED. + + TIMELAST = -1.D39 + + NUMT = 0 + + DO I = 1,NUMTT + + TIME = TVECT(I) + CALL THESAME(TIME,TIMELAST,ISAME) + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TIME = TIMELAST (OR AT +C LEAST, THEY ARE WITHIN 1.D-10), AND THIS TIME CAN BE IGNORED SINCE IT +C WAS ALREADY PUT INTO TVECT BY A PREVIOUS TIME. + + IF(ISAME .EQ. 1) GO TO 30 + +C TO GET HERE, ISAME = 0, WHICH MEANS THIS IS A NEW TIME. SO PUT +C TIME INTO TVECT. THEN SET TIMELAST = TIME AND CONTINUE THE LOOP. + + NUMT = NUMT + 1 + +C IF NUMT > 72000, STOP THE PROGRAM WITH A MESSAGE TO THE USER. + + IF(NUMT .GT. 72000) THEN + + WRITE(*,2031) + WRITE(56,2031) + 2031 FORMAT(//' THE MAXIMUM NO. OF PREDICTED VALUES HAS BEEN REACHED'/ + 1' IN SUBROUTINE CALCTPRED2. THE PROGRAM STOPS. PLEASE RERUN '/ + 2' AFTER SETTING IDELTA TO A LARGER NUMBER, OR REDUCING THE '/ + 3' LAST OBSERVATION TIME IN THE "FUTURE" FILE.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,2031) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + + TVECT(NUMT) = TIME + TIMELAST = TIME + + 30 CONTINUE + + END DO +C THE ABOVE END DO IS FOR THE DO I = 1,NUMTT LOOP. + + +C NOW STORE THESE NUMT TIMES INTO TPRED. + + DO I = 1,NUMT + TPRED(I) = TVECT(I) + END DO + + + RETURN + END + +C This file contains source code for the BLAS routines that are used by BIGNPAG +C These are separated out here since it may be more efficient to just compile +C bignpag.f and link to an optimized math library containing the BLAS than to +C compile bignpag.f and this file blasnpag.f together. +C contents: +c dgemm: blas level 3 +c dgemv: blas level 2 +c dsyrk: blas level 3 +c dtrsm: blas level 1 +c dcopy: blas levle 1 +c dscal: blas level 1 +c daxpy: blas level 1 +c ddot: blas level 1 +c idamax: blas level 1 +c dswap: blas level 1 +c dasum: blas level 1 +c dnrm2: blas level 1 + SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 TRANSA, TRANSB + INTEGER M, N, K, LDA, LDB, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* DGEMM performs one of the matrix-matrix operations +* +* C := alpha*op( A )*op( B ) + beta*C, +* +* where op( X ) is one of +* +* op( X ) = X or op( X ) = X', +* +* alpha and beta are scalars, and A, B and C are matrices, with op( A ) +* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. +* +* Parameters +* ========== +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n', op( A ) = A. +* +* TRANSA = 'T' or 't', op( A ) = A'. +* +* TRANSA = 'C' or 'c', op( A ) = A'. +* +* Unchanged on exit. +* +* TRANSB - CHARACTER*1. +* On entry, TRANSB specifies the form of op( B ) to be used in +* the matrix multiplication as follows: +* +* TRANSB = 'N' or 'n', op( B ) = B. +* +* TRANSB = 'T' or 't', op( B ) = B'. +* +* TRANSB = 'C' or 'c', op( B ) = B'. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix +* op( A ) and of the matrix C. M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix +* op( B ) and the number of columns of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - INTEGER. +* On entry, K specifies the number of columns of the matrix +* op( A ) and the number of rows of the matrix op( B ). K must +* be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +* k when TRANSA = 'N' or 'n', and is m otherwise. +* Before entry with TRANSA = 'N' or 'n', the leading m by k +* part of the array A must contain the matrix A, otherwise +* the leading k by m part of the array A must contain the +* matrix A. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANSA = 'N' or 'n' then +* LDA must be at least max( 1, m ), otherwise LDA must be at +* least max( 1, k ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is +* n when TRANSB = 'N' or 'n', and is k otherwise. +* Before entry with TRANSB = 'N' or 'n', the leading k by n +* part of the array B must contain the matrix B, otherwise +* the leading n by k part of the array B must contain the +* matrix B. +* Unchanged on exit. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. When TRANSB = 'N' or 'n' then +* LDB must be at least max( 1, k ), otherwise LDB must be at +* least max( 1, n ). +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then C need not be set on input. +* Unchanged on exit. +* +* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). +* Before entry, the leading m by n part of the array C must +* contain the matrix C, except when beta is zero, in which +* case C need not be set on entry. +* On exit, the array C is overwritten by the m by n matrix +* ( alpha*op( A )*op( B ) + beta*C ). +* +* LDC - INTEGER. +* On entry, LDC specifies the first dimension of C as declared +* in the calling (sub) program. LDC must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL NOTA, NOTB + INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Set NOTA and NOTB as true if A and B respectively are not +* transposed and set NROWA, NCOLA and NROWB as the number of rows +* and columns of A and the number of rows of B respectively. +* + NOTA = LSAME( TRANSA, 'N' ) + NOTB = LSAME( TRANSB, 'N' ) + IF( NOTA )THEN + NROWA = M + NCOLA = K + ELSE + NROWA = K + NCOLA = M + END IF + IF( NOTB )THEN + NROWB = K + ELSE + NROWB = N + END IF +* +* Test the input parameters. +* + INFO = 0 + IF( ( .NOT.NOTA ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.NOTB ).AND. + $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. + $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN + INFO = 2 + ELSE IF( M .LT.0 )THEN + INFO = 3 + ELSE IF( N .LT.0 )THEN + INFO = 4 + ELSE IF( K .LT.0 )THEN + INFO = 5 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 8 + ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN + INFO = 10 + ELSE IF( LDC.LT.MAX( 1, M ) )THEN + INFO = 13 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And if alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, M + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + RETURN + END IF +* +* Start the operations. +* + IF( NOTB )THEN + IF( NOTA )THEN +* +* Form C := alpha*A*B + beta*C. +* + DO 90, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 50, I = 1, M + C( I, J ) = ZERO + 50 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 60, I = 1, M + C( I, J ) = BETA*C( I, J ) + 60 CONTINUE + END IF + DO 80, L = 1, K + IF( B( L, J ).NE.ZERO )THEN + TEMP = ALPHA*B( L, J ) + DO 70, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 70 CONTINUE + END IF + 80 CONTINUE + 90 CONTINUE + ELSE +* +* Form C := alpha*A'*B + beta*C +* + DO 120, J = 1, N + DO 110, I = 1, M + TEMP = ZERO + DO 100, L = 1, K + TEMP = TEMP + A( L, I )*B( L, J ) + 100 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 110 CONTINUE + 120 CONTINUE + END IF + ELSE + IF( NOTA )THEN +* +* Form C := alpha*A*B' + beta*C +* + DO 170, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 130, I = 1, M + C( I, J ) = ZERO + 130 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 140, I = 1, M + C( I, J ) = BETA*C( I, J ) + 140 CONTINUE + END IF + DO 160, L = 1, K + IF( B( J, L ).NE.ZERO )THEN + TEMP = ALPHA*B( J, L ) + DO 150, I = 1, M + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 150 CONTINUE + END IF + 160 CONTINUE + 170 CONTINUE + ELSE +* +* Form C := alpha*A'*B' + beta*C +* + DO 200, J = 1, N + DO 190, I = 1, M + TEMP = ZERO + DO 180, L = 1, K + TEMP = TEMP + A( L, I )*B( J, L ) + 180 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 190 CONTINUE + 200 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMM . +* + END + SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, + $ BETA, Y, INCY ) +* .. Scalar Arguments .. + DOUBLE PRECISION ALPHA, BETA + INTEGER INCX, INCY, LDA, M, N + CHARACTER*1 TRANS +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) +* .. +* +* Purpose +* ======= +* +* DGEMV performs one of the matrix-vector operations +* +* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, +* +* where alpha and beta are scalars, x and y are vectors and A is an +* m by n matrix. +* +* Parameters +* ========== +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. +* +* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. +* +* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of the matrix A. +* M must be at least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of the matrix A. +* N must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). +* Before entry, the leading m by n part of the array A must +* contain the matrix of coefficients. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. LDA must be at least +* max( 1, m ). +* Unchanged on exit. +* +* X - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. +* Before entry, the incremented array X must contain the +* vector x. +* Unchanged on exit. +* +* INCX - INTEGER. +* On entry, INCX specifies the increment for the elements of +* X. INCX must not be zero. +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. When BETA is +* supplied as zero then Y need not be set on input. +* Unchanged on exit. +* +* Y - DOUBLE PRECISION array of DIMENSION at least +* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' +* and at least +* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. +* Before entry with BETA non-zero, the incremented array Y +* must contain the vector y. On exit, Y is overwritten by the +* updated vector y. +* +* INCY - INTEGER. +* On entry, INCY specifies the increment for the elements of +* Y. INCY must not be zero. +* Unchanged on exit. +* +* +* Level 2 Blas routine. +* +* -- Written on 22-October-1986. +* Jack Dongarra, Argonne National Lab. +* Jeremy Du Croz, Nag Central Office. +* Sven Hammarling, Nag Central Office. +* Richard Hanson, Sandia National Labs. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + DOUBLE PRECISION TEMP + INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + IF ( .NOT.LSAME( TRANS, 'N' ).AND. + $ .NOT.LSAME( TRANS, 'T' ).AND. + $ .NOT.LSAME( TRANS, 'C' ) )THEN + INFO = 1 + ELSE IF( M.LT.0 )THEN + INFO = 2 + ELSE IF( N.LT.0 )THEN + INFO = 3 + ELSE IF( LDA.LT.MAX( 1, M ) )THEN + INFO = 6 + ELSE IF( INCX.EQ.0 )THEN + INFO = 8 + ELSE IF( INCY.EQ.0 )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DGEMV ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. + $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* Set LENX and LENY, the lengths of the vectors x and y, and set +* up the start points in X and Y. +* + IF( LSAME( TRANS, 'N' ) )THEN + LENX = N + LENY = M + ELSE + LENX = M + LENY = N + END IF + IF( INCX.GT.0 )THEN + KX = 1 + ELSE + KX = 1 - ( LENX - 1 )*INCX + END IF + IF( INCY.GT.0 )THEN + KY = 1 + ELSE + KY = 1 - ( LENY - 1 )*INCY + END IF +* +* Start the operations. In this version the elements of A are +* accessed sequentially with one pass through A. +* +* First form y := beta*y. +* + IF( BETA.NE.ONE )THEN + IF( INCY.EQ.1 )THEN + IF( BETA.EQ.ZERO )THEN + DO 10, I = 1, LENY + Y( I ) = ZERO + 10 CONTINUE + ELSE + DO 20, I = 1, LENY + Y( I ) = BETA*Y( I ) + 20 CONTINUE + END IF + ELSE + IY = KY + IF( BETA.EQ.ZERO )THEN + DO 30, I = 1, LENY + Y( IY ) = ZERO + IY = IY + INCY + 30 CONTINUE + ELSE + DO 40, I = 1, LENY + Y( IY ) = BETA*Y( IY ) + IY = IY + INCY + 40 CONTINUE + END IF + END IF + END IF + IF( ALPHA.EQ.ZERO ) + $ RETURN + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form y := alpha*A*x + y. +* + JX = KX + IF( INCY.EQ.1 )THEN + DO 60, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + DO 50, I = 1, M + Y( I ) = Y( I ) + TEMP*A( I, J ) + 50 CONTINUE + END IF + JX = JX + INCX + 60 CONTINUE + ELSE + DO 80, J = 1, N + IF( X( JX ).NE.ZERO )THEN + TEMP = ALPHA*X( JX ) + IY = KY + DO 70, I = 1, M + Y( IY ) = Y( IY ) + TEMP*A( I, J ) + IY = IY + INCY + 70 CONTINUE + END IF + JX = JX + INCX + 80 CONTINUE + END IF + ELSE +* +* Form y := alpha*A'*x + y. +* + JY = KY + IF( INCX.EQ.1 )THEN + DO 100, J = 1, N + TEMP = ZERO + DO 90, I = 1, M + TEMP = TEMP + A( I, J )*X( I ) + 90 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 100 CONTINUE + ELSE + DO 120, J = 1, N + TEMP = ZERO + IX = KX + DO 110, I = 1, M + TEMP = TEMP + A( I, J )*X( IX ) + IX = IX + INCX + 110 CONTINUE + Y( JY ) = Y( JY ) + ALPHA*TEMP + JY = JY + INCY + 120 CONTINUE + END IF + END IF +* + RETURN +* +* End of DGEMV . +* + END + SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, + $ BETA, C, LDC ) +* .. Scalar Arguments .. + CHARACTER*1 UPLO, TRANS + INTEGER N, K, LDA, LDC + DOUBLE PRECISION ALPHA, BETA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), C( LDC, * ) +* .. +* +* Purpose +* ======= +* +* DSYRK performs one of the symmetric rank k operations +* +* C := alpha*A*A' + beta*C, +* +* or +* +* C := alpha*A'*A + beta*C, +* +* where alpha and beta are scalars, C is an n by n symmetric matrix +* and A is an n by k matrix in the first case and a k by n matrix +* in the second case. +* +* Parameters +* ========== +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the upper or lower +* triangular part of the array C is to be referenced as +* follows: +* +* UPLO = 'U' or 'u' Only the upper triangular part of C +* is to be referenced. +* +* UPLO = 'L' or 'l' Only the lower triangular part of C +* is to be referenced. +* +* Unchanged on exit. +* +* TRANS - CHARACTER*1. +* On entry, TRANS specifies the operation to be performed as +* follows: +* +* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. +* +* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. +* +* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. +* +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the order of the matrix C. N must be +* at least zero. +* Unchanged on exit. +* +* K - INTEGER. +* On entry with TRANS = 'N' or 'n', K specifies the number +* of columns of the matrix A, and on entry with +* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number +* of rows of the matrix A. K must be at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is +* k when TRANS = 'N' or 'n', and is n otherwise. +* Before entry with TRANS = 'N' or 'n', the leading n by k +* part of the array A must contain the matrix A, otherwise +* the leading k by n part of the array A must contain the +* matrix A. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When TRANS = 'N' or 'n' +* then LDA must be at least max( 1, n ), otherwise LDA must +* be at least max( 1, k ). +* Unchanged on exit. +* +* BETA - DOUBLE PRECISION. +* On entry, BETA specifies the scalar beta. +* Unchanged on exit. +* +* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). +* Before entry with UPLO = 'U' or 'u', the leading n by n +* upper triangular part of the array C must contain the upper +* triangular part of the symmetric matrix and the strictly +* lower triangular part of C is not referenced. On exit, the +* upper triangular part of the array C is overwritten by the +* upper triangular part of the updated matrix. +* Before entry with UPLO = 'L' or 'l', the leading n by n +* lower triangular part of the array C must contain the lower +* triangular part of the symmetric matrix and the strictly +* upper triangular part of C is not referenced. On exit, the +* lower triangular part of the array C is overwritten by the +* lower triangular part of the updated matrix. +* +* LDC - INTEGER. +* On entry, LDC specifies the first dimension of C as declared +* in the calling (sub) program. LDC must be at least +* max( 1, n ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL UPPER + INTEGER I, INFO, J, L, NROWA + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + IF( LSAME( TRANS, 'N' ) )THEN + NROWA = N + ELSE + NROWA = K + END IF + UPPER = LSAME( UPLO, 'U' ) +* + INFO = 0 + IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN + INFO = 2 + ELSE IF( N .LT.0 )THEN + INFO = 3 + ELSE IF( K .LT.0 )THEN + INFO = 4 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 7 + ELSE IF( LDC.LT.MAX( 1, N ) )THEN + INFO = 10 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DSYRK ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( ( N.EQ.0 ).OR. + $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + IF( UPPER )THEN + IF( BETA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, J + C( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + ELSE + DO 40, J = 1, N + DO 30, I = 1, J + C( I, J ) = BETA*C( I, J ) + 30 CONTINUE + 40 CONTINUE + END IF + ELSE + IF( BETA.EQ.ZERO )THEN + DO 60, J = 1, N + DO 50, I = J, N + C( I, J ) = ZERO + 50 CONTINUE + 60 CONTINUE + ELSE + DO 80, J = 1, N + DO 70, I = J, N + C( I, J ) = BETA*C( I, J ) + 70 CONTINUE + 80 CONTINUE + END IF + END IF + RETURN + END IF +* +* Start the operations. +* + IF( LSAME( TRANS, 'N' ) )THEN +* +* Form C := alpha*A*A' + beta*C. +* + IF( UPPER )THEN + DO 130, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 90, I = 1, J + C( I, J ) = ZERO + 90 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 100, I = 1, J + C( I, J ) = BETA*C( I, J ) + 100 CONTINUE + END IF + DO 120, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 110, I = 1, J + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 110 CONTINUE + END IF + 120 CONTINUE + 130 CONTINUE + ELSE + DO 180, J = 1, N + IF( BETA.EQ.ZERO )THEN + DO 140, I = J, N + C( I, J ) = ZERO + 140 CONTINUE + ELSE IF( BETA.NE.ONE )THEN + DO 150, I = J, N + C( I, J ) = BETA*C( I, J ) + 150 CONTINUE + END IF + DO 170, L = 1, K + IF( A( J, L ).NE.ZERO )THEN + TEMP = ALPHA*A( J, L ) + DO 160, I = J, N + C( I, J ) = C( I, J ) + TEMP*A( I, L ) + 160 CONTINUE + END IF + 170 CONTINUE + 180 CONTINUE + END IF + ELSE +* +* Form C := alpha*A'*A + beta*C. +* + IF( UPPER )THEN + DO 210, J = 1, N + DO 200, I = 1, J + TEMP = ZERO + DO 190, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 190 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 200 CONTINUE + 210 CONTINUE + ELSE + DO 240, J = 1, N + DO 230, I = J, N + TEMP = ZERO + DO 220, L = 1, K + TEMP = TEMP + A( L, I )*A( L, J ) + 220 CONTINUE + IF( BETA.EQ.ZERO )THEN + C( I, J ) = ALPHA*TEMP + ELSE + C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) + END IF + 230 CONTINUE + 240 CONTINUE + END IF + END IF +* + RETURN +* +* End of DSYRK . +* + END + SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, + $ B, LDB ) +* .. Scalar Arguments .. + CHARACTER*1 SIDE, UPLO, TRANSA, DIAG + INTEGER M, N, LDA, LDB + DOUBLE PRECISION ALPHA +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DTRSM solves one of the matrix equations +* +* op( A )*X = alpha*B, or X*op( A ) = alpha*B, +* +* where alpha is a scalar, X and B are m by n matrices, A is a unit, or +* non-unit, upper or lower triangular matrix and op( A ) is one of +* +* op( A ) = A or op( A ) = A'. +* +* The matrix X is overwritten on B. +* +* Parameters +* ========== +* +* SIDE - CHARACTER*1. +* On entry, SIDE specifies whether op( A ) appears on the left +* or right of X as follows: +* +* SIDE = 'L' or 'l' op( A )*X = alpha*B. +* +* SIDE = 'R' or 'r' X*op( A ) = alpha*B. +* +* Unchanged on exit. +* +* UPLO - CHARACTER*1. +* On entry, UPLO specifies whether the matrix A is an upper or +* lower triangular matrix as follows: +* +* UPLO = 'U' or 'u' A is an upper triangular matrix. +* +* UPLO = 'L' or 'l' A is a lower triangular matrix. +* +* Unchanged on exit. +* +* TRANSA - CHARACTER*1. +* On entry, TRANSA specifies the form of op( A ) to be used in +* the matrix multiplication as follows: +* +* TRANSA = 'N' or 'n' op( A ) = A. +* +* TRANSA = 'T' or 't' op( A ) = A'. +* +* TRANSA = 'C' or 'c' op( A ) = A'. +* +* Unchanged on exit. +* +* DIAG - CHARACTER*1. +* On entry, DIAG specifies whether or not A is unit triangular +* as follows: +* +* DIAG = 'U' or 'u' A is assumed to be unit triangular. +* +* DIAG = 'N' or 'n' A is not assumed to be unit +* triangular. +* +* Unchanged on exit. +* +* M - INTEGER. +* On entry, M specifies the number of rows of B. M must be at +* least zero. +* Unchanged on exit. +* +* N - INTEGER. +* On entry, N specifies the number of columns of B. N must be +* at least zero. +* Unchanged on exit. +* +* ALPHA - DOUBLE PRECISION. +* On entry, ALPHA specifies the scalar alpha. When alpha is +* zero then A is not referenced and B need not be set before +* entry. +* Unchanged on exit. +* +* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m +* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. +* Before entry with UPLO = 'U' or 'u', the leading k by k +* upper triangular part of the array A must contain the upper +* triangular matrix and the strictly lower triangular part of +* A is not referenced. +* Before entry with UPLO = 'L' or 'l', the leading k by k +* lower triangular part of the array A must contain the lower +* triangular matrix and the strictly upper triangular part of +* A is not referenced. +* Note that when DIAG = 'U' or 'u', the diagonal elements of +* A are not referenced either, but are assumed to be unity. +* Unchanged on exit. +* +* LDA - INTEGER. +* On entry, LDA specifies the first dimension of A as declared +* in the calling (sub) program. When SIDE = 'L' or 'l' then +* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' +* then LDA must be at least max( 1, n ). +* Unchanged on exit. +* +* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). +* Before entry, the leading m by n part of the array B must +* contain the right-hand side matrix B, and on exit is +* overwritten by the solution matrix X. +* +* LDB - INTEGER. +* On entry, LDB specifies the first dimension of B as declared +* in the calling (sub) program. LDB must be at least +* max( 1, m ). +* Unchanged on exit. +* +* +* Level 3 Blas routine. +* +* +* -- Written on 8-February-1989. +* Jack Dongarra, Argonne National Laboratory. +* Iain Duff, AERE Harwell. +* Jeremy Du Croz, Numerical Algorithms Group Ltd. +* Sven Hammarling, Numerical Algorithms Group Ltd. +* +* +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. External Subroutines .. + EXTERNAL XERBLA +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. Local Scalars .. + LOGICAL LSIDE, NOUNIT, UPPER + INTEGER I, INFO, J, K, NROWA + DOUBLE PRECISION TEMP +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + LSIDE = LSAME( SIDE , 'L' ) + IF( LSIDE )THEN + NROWA = M + ELSE + NROWA = N + END IF + NOUNIT = LSAME( DIAG , 'N' ) + UPPER = LSAME( UPLO , 'U' ) +* + INFO = 0 + IF( ( .NOT.LSIDE ).AND. + $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN + INFO = 1 + ELSE IF( ( .NOT.UPPER ).AND. + $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN + INFO = 2 + ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. + $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN + INFO = 3 + ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. + $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN + INFO = 4 + ELSE IF( M .LT.0 )THEN + INFO = 5 + ELSE IF( N .LT.0 )THEN + INFO = 6 + ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN + INFO = 9 + ELSE IF( LDB.LT.MAX( 1, M ) )THEN + INFO = 11 + END IF + IF( INFO.NE.0 )THEN + CALL XERBLA( 'DTRSM ', INFO ) + RETURN + END IF +* +* Quick return if possible. +* + IF( N.EQ.0 ) + $ RETURN +* +* And when alpha.eq.zero. +* + IF( ALPHA.EQ.ZERO )THEN + DO 20, J = 1, N + DO 10, I = 1, M + B( I, J ) = ZERO + 10 CONTINUE + 20 CONTINUE + RETURN + END IF +* +* Start the operations. +* + IF( LSIDE )THEN + IF( LSAME( TRANSA, 'N' ) )THEN +* +* Form B := alpha*inv( A )*B. +* + IF( UPPER )THEN + DO 60, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 30, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 30 CONTINUE + END IF + DO 50, K = M, 1, -1 + IF( B( K, J ).NE.ZERO )THEN + IF( NOUNIT ) + $ B( K, J ) = B( K, J )/A( K, K ) + DO 40, I = 1, K - 1 + B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) + 40 CONTINUE + END IF + 50 CONTINUE + 60 CONTINUE + ELSE + DO 100, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 70, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 70 CONTINUE + END IF + DO 90 K = 1, M + IF( B( K, J ).NE.ZERO )THEN + IF( NOUNIT ) + $ B( K, J ) = B( K, J )/A( K, K ) + DO 80, I = K + 1, M + B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) + 80 CONTINUE + END IF + 90 CONTINUE + 100 CONTINUE + END IF + ELSE +* +* Form B := alpha*inv( A' )*B. +* + IF( UPPER )THEN + DO 130, J = 1, N + DO 120, I = 1, M + TEMP = ALPHA*B( I, J ) + DO 110, K = 1, I - 1 + TEMP = TEMP - A( K, I )*B( K, J ) + 110 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( I, I ) + B( I, J ) = TEMP + 120 CONTINUE + 130 CONTINUE + ELSE + DO 160, J = 1, N + DO 150, I = M, 1, -1 + TEMP = ALPHA*B( I, J ) + DO 140, K = I + 1, M + TEMP = TEMP - A( K, I )*B( K, J ) + 140 CONTINUE + IF( NOUNIT ) + $ TEMP = TEMP/A( I, I ) + B( I, J ) = TEMP + 150 CONTINUE + 160 CONTINUE + END IF + END IF + ELSE + IF( LSAME( TRANSA, 'N' ) )THEN +* +* Form B := alpha*B*inv( A ). +* + IF( UPPER )THEN + DO 210, J = 1, N + IF( ALPHA.NE.ONE )THEN + DO 170, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 170 CONTINUE + END IF + DO 190, K = 1, J - 1 + IF( A( K, J ).NE.ZERO )THEN + DO 180, I = 1, M + B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) + 180 CONTINUE + END IF + 190 CONTINUE + IF( NOUNIT )THEN + TEMP = ONE/A( J, J ) + DO 200, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 200 CONTINUE + END IF + 210 CONTINUE + ELSE + DO 260, J = N, 1, -1 + IF( ALPHA.NE.ONE )THEN + DO 220, I = 1, M + B( I, J ) = ALPHA*B( I, J ) + 220 CONTINUE + END IF + DO 240, K = J + 1, N + IF( A( K, J ).NE.ZERO )THEN + DO 230, I = 1, M + B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) + 230 CONTINUE + END IF + 240 CONTINUE + IF( NOUNIT )THEN + TEMP = ONE/A( J, J ) + DO 250, I = 1, M + B( I, J ) = TEMP*B( I, J ) + 250 CONTINUE + END IF + 260 CONTINUE + END IF + ELSE +* +* Form B := alpha*B*inv( A' ). +* + IF( UPPER )THEN + DO 310, K = N, 1, -1 + IF( NOUNIT )THEN + TEMP = ONE/A( K, K ) + DO 270, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 270 CONTINUE + END IF + DO 290, J = 1, K - 1 + IF( A( J, K ).NE.ZERO )THEN + TEMP = A( J, K ) + DO 280, I = 1, M + B( I, J ) = B( I, J ) - TEMP*B( I, K ) + 280 CONTINUE + END IF + 290 CONTINUE + IF( ALPHA.NE.ONE )THEN + DO 300, I = 1, M + B( I, K ) = ALPHA*B( I, K ) + 300 CONTINUE + END IF + 310 CONTINUE + ELSE + DO 360, K = 1, N + IF( NOUNIT )THEN + TEMP = ONE/A( K, K ) + DO 320, I = 1, M + B( I, K ) = TEMP*B( I, K ) + 320 CONTINUE + END IF + DO 340, J = K + 1, N + IF( A( J, K ).NE.ZERO )THEN + TEMP = A( J, K ) + DO 330, I = 1, M + B( I, J ) = B( I, J ) - TEMP*B( I, K ) + 330 CONTINUE + END IF + 340 CONTINUE + IF( ALPHA.NE.ONE )THEN + DO 350, I = 1, M + B( I, K ) = ALPHA*B( I, K ) + 350 CONTINUE + END IF + 360 CONTINUE + END IF + END IF + END IF +* + RETURN +* +* End of DTRSM . +* + END + subroutine dcopy(n,dx,incx,dy,incy) +c +c copies a vector, x, to a vector, y. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*) + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,7) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dx(i) + 30 continue + if( n .lt. 7 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,7 + dy(i) = dx(i) + dy(i + 1) = dx(i + 1) + dy(i + 2) = dx(i + 2) + dy(i + 3) = dx(i + 3) + dy(i + 4) = dx(i + 4) + dy(i + 5) = dx(i + 5) + dy(i + 6) = dx(i + 6) + 50 continue + return + end + +C----------------------------------------------------------------------- + + subroutine dscal(n,da,dx,incx) +c +c scales a vector by a constant. +c uses unrolled loops for increment equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision da,dx(*) + integer i,incx,m,mp1,n,nincx +c + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dx(i) = da*dx(i) + 10 continue + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dx(i) = da*dx(i) + 30 continue + if( n .lt. 5 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dx(i) = da*dx(i) + dx(i + 1) = da*dx(i + 1) + dx(i + 2) = da*dx(i + 2) + dx(i + 3) = da*dx(i + 3) + dx(i + 4) = da*dx(i + 4) + 50 continue + return + end + +C----------------------------------------------------------------------- + + subroutine daxpy(n,da,dx,incx,dy,incy) +c +c constant times a vector plus a vector. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),da + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if (da .eq. 0.0d0) return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dy(iy) = dy(iy) + da*dx(ix) + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,4) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dy(i) = dy(i) + da*dx(i) + 30 continue + if( n .lt. 4 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,4 + dy(i) = dy(i) + da*dx(i) + dy(i + 1) = dy(i + 1) + da*dx(i + 1) + dy(i + 2) = dy(i + 2) + da*dx(i + 2) + dy(i + 3) = dy(i + 3) + da*dx(i + 3) + 50 continue + return + end + +C----------------------------------------------------------------------- + + double precision function ddot(n,dx,incx,dy,incy) +c +c forms the dot product of two vectors. +c uses unrolled loops for increments equal to one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + ddot = 0.0d0 + dtemp = 0.0d0 + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments +c not equal to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dtemp + dx(ix)*dy(iy) + ix = ix + incx + iy = iy + incy + 10 continue + ddot = dtemp + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,5) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dx(i)*dy(i) + 30 continue + if( n .lt. 5 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,5 + dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + + * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) + 50 continue + 60 ddot = dtemp + return + end + + +C----------------------------------------------------------------------- + + integer function idamax(n,dx,incx) +c +c finds the index of element having max. absolute value. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dmax + integer i,incx,ix,n +c + idamax = 0 + if( n.lt.1 .or. incx.le.0 ) return + idamax = 1 + if(n.eq.1)return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + ix = 1 + dmax = dabs(dx(1)) + ix = ix + incx + do 10 i = 2,n + if(dabs(dx(ix)).le.dmax) go to 5 + idamax = i + dmax = dabs(dx(ix)) + 5 ix = ix + incx + 10 continue + return +c +c code for increment equal to 1 +c + 20 dmax = dabs(dx(1)) + do 30 i = 2,n + if(dabs(dx(i)).le.dmax) go to 30 + idamax = i + dmax = dabs(dx(i)) + 30 continue + return + end + +C----------------------------------------------------------------------- + + subroutine dswap (n,dx,incx,dy,incy) +c +c interchanges two vectors. +c uses unrolled loops for increments equal one. +c jack dongarra, linpack, 3/11/78. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dy(*),dtemp + integer i,incx,incy,ix,iy,m,mp1,n +c + if(n.le.0)return + if(incx.eq.1.and.incy.eq.1)go to 20 +c +c code for unequal increments or equal increments not equal +c to 1 +c + ix = 1 + iy = 1 + if(incx.lt.0)ix = (-n+1)*incx + 1 + if(incy.lt.0)iy = (-n+1)*incy + 1 + do 10 i = 1,n + dtemp = dx(ix) + dx(ix) = dy(iy) + dy(iy) = dtemp + ix = ix + incx + iy = iy + incy + 10 continue + return +c +c code for both increments equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,3) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + 30 continue + if( n .lt. 3 ) return + 40 mp1 = m + 1 + do 50 i = mp1,n,3 + dtemp = dx(i) + dx(i) = dy(i) + dy(i) = dtemp + dtemp = dx(i + 1) + dx(i + 1) = dy(i + 1) + dy(i + 1) = dtemp + dtemp = dx(i + 2) + dx(i + 2) = dy(i + 2) + dy(i + 2) = dtemp + 50 continue + return + end + double precision function dasum(n,dx,incx) +c +c takes the sum of the absolute values. +c jack dongarra, linpack, 3/11/78. +c modified 3/93 to return if incx .le. 0. +c modified 12/3/93, array(1) declarations changed to array(*) +c + double precision dx(*),dtemp + integer i,incx,m,mp1,n,nincx +c + dasum = 0.0d0 + dtemp = 0.0d0 + if( n.le.0 .or. incx.le.0 )return + if(incx.eq.1)go to 20 +c +c code for increment not equal to 1 +c + nincx = n*incx + do 10 i = 1,nincx,incx + dtemp = dtemp + dabs(dx(i)) + 10 continue + dasum = dtemp + return +c +c code for increment equal to 1 +c +c +c clean-up loop +c + 20 m = mod(n,6) + if( m .eq. 0 ) go to 40 + do 30 i = 1,m + dtemp = dtemp + dabs(dx(i)) + 30 continue + if( n .lt. 6 ) go to 60 + 40 mp1 = m + 1 + do 50 i = mp1,n,6 + dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) + * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) + 50 continue + 60 dasum = dtemp + return + end + DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) +* .. Scalar Arguments .. + INTEGER INCX, N +* .. Array Arguments .. + DOUBLE PRECISION X( * ) +* .. +* +* DNRM2 returns the euclidean norm of a vector via the function +* name, so that +* +* DNRM2 := sqrt( x'*x ) +* +* +* +* -- This version written on 25-October-1982. +* Modified on 14-October-1993 to inline the call to DLASSQ. +* Sven Hammarling, Nag Ltd. +* +* +* .. Parameters .. + DOUBLE PRECISION ONE , ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. Local Scalars .. + INTEGER IX + DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ +* .. Intrinsic Functions .. + INTRINSIC ABS, SQRT +* .. +* .. Executable Statements .. + IF( N.LT.1 .OR. INCX.LT.1 )THEN + NORM = ZERO + ELSE IF( N.EQ.1 )THEN + NORM = ABS( X( 1 ) ) + ELSE + SCALE = ZERO + SSQ = ONE +* The following loop is equivalent to this call to the LAPACK +* auxiliary routine: +* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) +* + DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX + IF( X( IX ).NE.ZERO )THEN + ABSXI = ABS( X( IX ) ) + IF( SCALE.LT.ABSXI )THEN + SSQ = ONE + SSQ*( SCALE/ABSXI )**2 + SCALE = ABSXI + ELSE + SSQ = SSQ + ( ABSXI/SCALE )**2 + END IF + END IF + 10 CONTINUE + NORM = SCALE * SQRT( SSQ ) + END IF +* + DNRM2 = NORM + RETURN +* +* End of DNRM2. +* + END +C CALCBST15.FOR 7/7/14 + +C CALCBST15 HAS THE FOLLOWING CHANGES FROM CALCBST14: + +C 1. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN +C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx +C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING +C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT +C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT +C USING COMMON/ERR/ERRFIL. + +C 2. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, +C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET +C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED +C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT +C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS +C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL +C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 +C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO +C MAXNUMEQ. + +C 3. IN SUBROUTINE GETPRED, THE DIMENSIONS OF 6 IN XSTORE AND XPRED +C HAVE BEEN CHANGED TO 20, AS THEY SHOULD HAVE BEEN ALL ALONG (I.E., +C THIS REPRESENTS THE MAXIMUM NO. OF COMPARTMENTS ALLOWED). + +C 4. THE TWO WRITE STATEMENTS TO FILE 25 ARE REMOVED, SINCE FILE 25 IS +C NOT ACTIVE IN THIS PROGRAM. + +C 5. IN SUBROUTINE GETPRED, COMMON/ERROR/ERRFIL IS ADDED; ERRFIL IS +C DECLARED CHARACTER*20; AND FORMAT 111 AND SIG(.) ARE WRITTEN TO +C ERRFIL JUST BEFORE THE PROGRAM STOPS IF THE PATIENT DATA FILE +C HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE +C RESET ROW. + +C 6. A BUG IS FIXED IN SUBROUTINE WSUMSQ.IN THE IF(ITARGET .EQ. 2) +C PORTION OF THE CODE, AUC IS NO LONGER SET BACK TO 0 IF +C TPRED(I) = TNEXT ... SINCE AUCs ARE CUMULATIVE FROM TIME 0 IN THE +C "PAST", AS OF BESTDOS118.FOR. THIS BUG EXISTED ONLY IN +C BESTDOS118.FOR, AND IS NOW FIXED IN BESTDOS119.FOR, WHICH IS THE +C FIRST PROGRAM TO USE CALCBST15.FOR. + +C----------------------------------------------------------------------- + +C CALCBST14.FOR 11/4/13 + +C CALCBST14 HAS THE FOLLOWING CHANGE TO CALCBST13. "XLAM" IS REPLACED +C BY "BIASWEIGHT". THIS IS DONE TO REMOVE ANY CONFUSION WITH LAMBDA, +C WHICH IS A TERM USED IN THE ASSAY ERROR FUNCTION. + +C CALCBST14.FOR IS A MODULE IN THE NEW BESTDOS117.FOR PROGRAM. + +C----------------------------------------------------------------------- + +C CALCBST13.FOR 10/16/13 + +C CALCBST13 HAS THE FOLLOWING CHANGES TO CALCBST12: + +C IF THE USER SELECTS ITARGET = 2 (SEE BELOW), THE AUCs NOW WILL BE +C RELATIVE TO TIME 0 IN THE "FUTURE", AS OPPOSED TO TIME 0 IN THE +C "PAST". + +C THIS REQUIRES CHANGES IN SUBROUTINE WSUMSQ. THE AUC AT TIME TNEXT +C (WHICH IS THE BEGINNING TIME FOR THE "FUTURE") IS RESET BACK TO 0. + +C NOTE ALSO THAT TNEXT IS NOW INCLUDED IN COMMON/TOSUMSQ, SO THAT +C IT CAN BE ADDED TO THE TIMES WHICH ARE ESTABLISHED BY ROUTINE +C CALCTPRED2. + +C NOTE THAT THIS PROGRAM IS NOW LINKED WITH BESTDOS116.FOR. + +C----------------------------------------------------------------------- + +C CALCBST12.FOR 10/6/13 + +C CALCBST12 HAS THE FOLLOWING CHANGES FROM CALCBST11: + +C 1. THERE ARE A NUMBER OF CHANGES IN SUBROUTINE WSUMSQ TO ALLOW FOR +C THE NEW CASE THAT THE OBSERVED VALUES COULD BE TARGET AUCs, RATHER +C THAN TARGET CONCENTRATIONS. + +C NOTE ALSO THAT THE NEW COMMON/TOSUMSQ PROVIDES INFO NEEDED BY +C WSUMSQ FROM MAIN. + +C 2. THE DIMENSION 71281 FOR YYPRED AND TPRED HAS BEEN CHANGED TO +C 72000 TO BE CONSISTENT WITH THTE DIMENSIONS NOW IN BESTDOS115.FOR. + +C 3. NOTE THAT XLAM HAS BEEN MOVED IN FRONT OF THE INTEGER ARGUMENTS +C IN COMMON/TOCALC TO AVOID A WARNING WHEN THIS PROGRAM IS COMPILED +C WITH gfortran. + +C THIS MODULE IS PART OF THE NEW PROGRAM, BESTDOS115.FOR. + +C----------------------------------------------------------------------- + +C CALCBST11.FOR 9/16/13 + +C CALCBST11 HAS THE FOLLOWING CHANGES TO CALCBST10: + +C 1. THE COST FUNCTION TO BE MINIMIZED IN SUBROUTINE CALCS IS CHANGED +C TO NOW INCLUDE A BIAS TERM ALSO. THIS REQUIRES SEVERAL CHANGES IN +C SUBROUTINES CALCS AND WSUMSQ. AND IT REQUIRES XLAM TO BE PROVIDED +C TO CALCS VIA COMMON/TOCALC. + +C 2. IN WHAT IS NOW THE FIRST PART OF THE COST FUNCTION, THE +C WEIGHT(.,.) ARRAY IS ELIMINATED. I.E., NOW THAT PART OF THE COST +C FUNCTION WILL NO LONGER BE WEIGHTED BY THE ASSAY NOISE. + +C 3. EXTRA/NEW VALUES ARE RETURNED TO MAIN VIA COMMON/PREDVAL. INSTEAD +C OF JUST PREDMIN AND SUMM, NOW PREDMIN, EEXPSUMMIN, SUMMIN, AND +C BIASMIN ARE RETURNED. + +C----------------------------------------------------------------------- + +C CALCBST10.FOR 3/26/13 + +C CALCBST10 HAS THE FOLLOWING CHANGES FROM CALCBST9: + +C THE CODE IN CALCPRED/GETPRED IS NOW BASED IN idm1x14.f, RATHER THAN +C idm1x6.f. THIS BRINGS THE BESTDOS106/CALCBST10 PROGRAM UP TO THE +C LEVEL OF THE NPAG AND IT2B PROGRAMS, EXCEPT THAT THIS PROGRAM STILL +C DOES NOT ACCOMMODATE STEADY STATE DOSE SETS --> THERE IS EXTRA UNUSED +C CODE RELATED TO STEADY STATE DOSE SETS IN GETPRED (WHICH MAY BE USED +C IN A LATER VERSION). + +C NOTE, IN PARTICULAR, THAT ALL DIMENSIONS OF 500 RELATED TO THE NO. OF +C DOSES ARE NOW CHANGED TO 5000. + +C----------------------------------------------------------------------- + +C CALCBST9.FOR 3/2/13 + +C CALCBST9 HAS THE FOLLOWING CHANGES FROM CALCBST8: + +C 1. COMMON/TOCALC, SUPPLIED TO SUBROUTINE CALCS, NOW INCLUDES AN +C EXTRA ARGUMENT, NDD41, AND THIS ARGUMENT (WITH NAME CHANGED TO +C ND41) IS SUPPLIED TO SUBROUTINE WSUMSQ. IN THAT ROUTINE, IT IS USED +C TO CHANGE THE DO I = 1,ND LOOP TO DO I = ND41+1,ND. + +C 2. THIS MODULE IS A PART OF THE NEW PROGRAM, BESTDOS105.FOR. + +C----------------------------------------------------------------------- + +C CALCBST8.FOR 2/13/13 + +C CALCBST8 HAS THE FOLLOWING CHANGES FROM CALCBST7: + +C IT OPTIMIZES OVER ALL DOSES IN THE PATIENT FILE, BOLUSES AS WELL +C AS IV RATES (CALCBST7 ASSUMED THAT THE BOLUSES WERE FIXED, AND ONLY +C OPTIMIZED OVER THE IV RATES). CALCBST8 IS USED WITH THE NEW MAIN +C PROGRAM, BESTDOS104.FOR. + +C NOTE THAT THE ONLY CHANGES REQUIRED ARE IN SUBROUTINE WSUMSQ. + +C----------------------------------------------------------------------- + +C CALCBST7.FOR 6/17/11 + +C CALCBST7 IS THE SAME AS CALCBST6 EXCEPT THAT ROUTINES USERANAL +C AND JACOB HAVE BEEN REMOVED (SINCE THEY ARE NOW PROVIDED IN THE +C NEW MODULE IDM1X6.FOR FOR THE BESTDOS101.FOR PROGRAM). + +C----------------------------------------------------------------------- + +C CALCBST6.FOR 1/27/11 + +C CALCBST6 HAS THE CHANGES FROM CALCBST5 (IN SUBROUTINE GETPRED) that +C idm1x6.f HAS FROM idm1x3.f. THESE CHANGES, IN ADDITION TO CORRECTING +C A COUPLE OF BUGS, MAKE THIS PROGRAM NOW COMPATIBLE WITH MODEL +C TEMPLATE FILE, TSTMULTH.FOR (UPDATED FROM TSTMULTG.FOR). THIS MODULE +C IS LINKED FIRST WITH MAIN MODULE, BESTDOS8.FOR. + +C----------------------------------------------------------------------- + +C CALCBST5.FOR 10/15/09 + +C CALCBST5 HAS THE FOLLOWING CHANGES FROM CALCBST4: + +C 1. IT IS A MODULE IN THE BESTDOS7.FOR PROGRAM. THIS PROGRAM IS +C AT THE "LEVEL" OF THE NPBIG15C.FOR PROGRAM. I.E., IT ALLOWS MULTIPLE +C DRUGS AND MULTIPLE OUTPUTS. + +C 2. CODE CHANGES, AND DIMENSION CHANGES OCCUR IN SUBROUTINES +C WSUMSQ, CALCPRED, GETPRED, USERANAL (ONLY CHANGE IS THAT WARNING +C STATEMENT IS SUPPRESSED) AND MAKEVEC. + +C NOTE THAT THE MODEL FILE CONSISTENT WITH THIS PROGRAM IS NOW +C TSTMULTG.FOR. NOTE ALSO, THAT THE SHIFT MODULE COMPILED AND +C LINKED WITH THIS PROGRAM IS NOW SHIFT5.F. + +C----------------------------------------------------------------------- + +C CALCBST4.FOR 3/1/08 + +C CALCBST4 HAS THE FOLLOWING CHANGES FROM CALCBST3: + +C 1. IN SUBROUTINE CALCS, ANY CANDIDATE VECTOR OF DOSES WHICH INCLUDES +C A NEGATIVE VALUE IS IMMEDIATELY REJECTED BY RETURNING A LARGE +C (UNATTRACTIVE) VALUE FOR THE OBJECTIVE FUNCTION, EXPSUM. THIS +C REQUIREMENT SHOULD HAVE BEEN IN PLACE ALL ALONG. + +C 2. IT IS LINKED WITH THE BESTDOS6 PROGRAM. + +C----------------------------------------------------------------------- + +C CALCBST3.FOR 11-14-02 + +C CALCBST3 IS A MAJOR VARIATION TO CALCBST2.FOR. THE MAJOR CHANGE IS +C THAT THIS MODULE IS LINKED WITH BESTDOS4.FOR, WHEREAS CALCBST2 IS +C LINKED WITH BESTDOS3.FOR. BESTDOS4.FOR/CALCBST3.FOR ALLOW GENERAL +C MODELS WHICH CAN BE DESCRIBED BY DIFFERENTIAL EQUATIONS AND OUTPUT +C EQUATION(S) CODED BY THE USER INTO SUBROUTINES DIFFEQ, OUTPUT, AND +C SYMBOL OF FILE, npemdriv.f. I.E., THE MODEL IS NO LONGER LIMITED TO +C THE STANDARD 3-COMPARTMENT LINEAR MODEL. + +C THE MAJOR CODING CHANGES REQUIRED ARE AS FOLLOWS: + +C 1. SUBROUTINES PARNAM AND PARNAM2 HAVE BEEN REMOVED - THEY ARE +C NOT APPLICABLE NOW SINCE THE MENU 1/2 CODE HAS BEEN REMOVED +C FROM THIS PROGRAM. + +C 2. SEVERAL DIMENSIONS HAVE BEEN CHANGED TO BE CONSISTENT ACROSS +C ALL ROUTINES WHICH HAVE THE SAME COMMONS. E.G., TIM(150) HAS +C BE CHANGED TO TIM(594) AND YO(150,4) HAS BEEN CHANGED TO +C YO(594,6). BOTH OF THESE ARE IN COMMON/OBSER. + +C 3. M HAS BEEN REMOVED FROM THE ARGUMENT LIST OF SUBROUTINE GETPRED; +C IT WILL BE PASSED VIA COMMON/SUM2 + +C 4. NVAR WAS REMOVED AS AN ARGUMENT TO SUBROUTINES WSUMSQ AND +C CALCPRED. IT WILL BE REPLACED BY NP (TOTAL NO. OF BOTH RANDOM +C AND FIXED PARAMETERS IN CALCPRED). + +C 5. SUBROUTINE CALCPRED WAS CHANGED TO BE LIKE MAIN OF idfix5f.f. + +C 6. SUBROUTINE GETPRED WAS CHANGED TO BE ESSENTIALLY LIKE SUBROUTINE +C FUNC OF MODULE, idfix5f.f. + +C 7. SUBROUTINES ANAL3, CASE1,...,CASE4 HAVE BEEN REMOVED. + +C 8. SUBROUTINES USERANAL AND JACOB ARE PUT IN FROM idfix5f.f. +C SUBROUTINE MAKEVEC IS PUT IN FROM bignpaglap1.f. MAKEVEC IS +C CALLED BELOW TO PUT INTO ONE VECTOR ALL THE PARAMETER VALUES +C (RANDOM AND FIXED) FOR EACH GRID POINT. + +C 9. NEW COMMON/FROMBEST PROVIDES THE VALUES NEEDED IN THE CALL TO +C NEW SUBROUTINE MAKEVEC (SEE ABOVE). + +C 10. THE MODULES, npemdriv.f (EDITED AS DESIRED BY THE USER) AND +C vodtot.f, WILL ALSO BE LINKED WITH THIS MODULE TO BE PART OF THE +C BESTDOS4.FOR PROGRAM. vodtot.f MUST BE LINKED SINCE SUBROUTINE DVODE +C IS CALLED BY SUBROUTINE USERANAL. + +C 11. SUBROUTINE OUTPUT HAS BEEN REMOVED SINCE IT WILL NOW BE A PART +C OF MODULE, npemdriv.f, WHICH WILL BE EDITED BY THE USER. + +C 12. THE MAXIMUM NO. OF GRID POINTS WHICH CAN BE USED (I.E., THE NO. +C OF GRID POINTS READ IN FROM THE MATLAB FILE BY BESTDOS4.FOR) IS +C CURRENTLY SET = MAXGRD = 5003. + +C----------------------------------------------------------------------- + +C CALCBST2.FOR 9-29-01 + +C CALCBST2 IS A SLIGHT EXTENSION TO CALCBEST. THE DIFFERENCE IS THAT, +C FOR EACH GRID POINT IN THE INPUT DENSITY, THE ACHIEVED CONCENTRATIONS +C FOR THE CURRENT BEST SET OF DOSES (I.E., THOSE GIVING THE MINIMUM +C EXPSUM IN SUBROUTINE CALCS) ARE STORED IN COMMON/PREDVAL, WHICH WILL +C BE USED IN MAIN. + +C----------------------------------------------------------------------- + +C CALCBEST.FOR 8-25-01 + +C CALCBEST (SUBROUTINE CALCS) IS A VARIATION OF CALCS.FOR ... TO BE +C USED WITH BESTDOSE.FOR. BESTDOSE CALLS ELDERY (WHICH USES THE +C NELDER MEED ALGORITHM) TO FIND THE BEST SET OF NDOS DOSES (AT THE +C TIMES READ IN FROM THE PATIENT DATA FILE BY SUBROUTINE FILRED - +C THESE TIMES ARE PUT INTO COMMON BY FILRED) TO MINIMIZE THE EXPECTED +C WEIGHTED SUM OF SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET + + +C CONCENTRATIONS (THE OBSERVATION TIMES AND TARGET CONCENTRATIONS ARE +C ALSO READ IN BY FILRED AND PUT INTO COMMONS TO BE USED BY SUBROUTINE +C CALCS). THE EXPECTED VALUE IS OVER THE PRIOR DENSITY (HAVING +C PARAMETER VALUES AND CORRESPONDING DENSITIES). + +C----------------------------------------------------------------------- + + SUBROUTINE CALCS(NDOS,DOSES,EXPSUM) + + PARAMETER(MAXGRD=5003, MAXDIM=25) + PARAMETER(MAXNUMEQ=7) + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION DOSES(5000),DENSITY(MAXGRD,MAXDIM+1),THETA(30), + 1 PRED(594,MAXNUMEQ),GRIDPRED(MAXGRD,594,MAXNUMEQ), + 2 YBAR(594,MAXNUMEQ),YOO(594,MAXNUMEQ), + 3 PREDMIN(MAXGRD,594,MAXNUMEQ),IRAN(32),VALFIX(20),PX(32) + + DATA EXPSUMMIN/1.D38/ + + COMMON/PREDVAL/PREDMIN,EEXPSUMMIN,SUMMIN,BIASMIN + COMMON/TOCALC/DENSITY,BIASWEIGHT,NOBSER,NUMEQT,NGRD,NVAR,NDD41 + COMMON/FROMBEST/NOFIX,IRAN,VALFIX + +C COMMON/PREVAL CONTAINS PREDMIN WHICH CONTAINS THE PREDICTED VALUES +C FOR EACH GRID POINT FOR THE BEST SET OF DOSES SO FAR (I.E., THOSE +C FOR WHICH THE EXPSUM IS MINIMUM SO FAR). ALSO, SUMM IS THE MINIMUM +C ACHIEVED VALUE OF EXPSUM SO FAR, AND CORRESPONDS TO PREDMIN VALUES. + +C COMMON/TOCALC CONTAINS THE FOLLOWING INFO: + +C 1. NOBSER = NO. OF OBSERVED VALUE TIMES IN THE PATIENT DATA FILE. +C 2. NGRD = NO. OF GRID POINTS OVER WHICH THE ABOVE EXPECTED VALUE +C IS TO BE CALCULATED. +C 3. NVAR = NO. OF DIMENSIONS IN THE RANDOM PARAMETER VECTOR. +C 4. DENSITY(I,J) = VALUE OF THE JTH RANDOM VARIABLE FOR GRID POINT I, +C J=1,NVAR; I=1,NGRD. +C DENSITY(I,NVAR+1) = DISCRETE DENSITY ASSOCIATED WITH GRID PT. I. +C 5. BIASWEIGHT = WEIGHT ASSIGNED TO THE BIAS TERM IN CALCULATION OF +C EXPSUM; 1 - BIASWEIGHT = WEIGHT ASSIGNED TO THE MEAN SQUARE ERROR +C TERM IN THE CALCULATION. +C 6. NUMEQT = NO. OF OUTPUT EQUATIONS IN THE PATIENT DATA FILE. +C 7. NDD41 = NO. OF DOSE EVENTS IN THE "PAST". + +C COMMON/FROMBEST PROVIDES THE VALUES TO THIS ROUTINE WHICH ARE +C IN THE CALL TO MAKEVEC BELOW. + + +C THIS ROUTINE, CALLED BY ELDERY, FINDS THE FUNCTIONAL VALUE, EXPSUM + + +C FOR THE SUPPLIED VARIABLE VECTOR, DOSES(I),I=1,NDOS. + +C EXPSUM CONSISTS OF TWO TERMS: + +C THE FIRST IS THE EXPECTED SUM OF SQUARES OF DIFFERENCES BETWEEN +C OBSERVED AND TARGET VALUES (THE OBSERVATION TIMES AND TARGET +C VALUES ARE READ IN BY FILRED AND PUT INTO COMMONS +C TO BE USED BY OTHER ROUTINES CALLED BY THIS ROUTINE). THE +C EXPECTED VALUE IS OVER THE PRIOR DENSITY (HAVING PARAMETER VALUES +C AND CORRESPONDING DENSITIES). + +C THE SECOND IS THE EXPECTED SUM OF SQUARES OF DIFFERENCES BETWEEN +C THE MEAN RESPONSES AND THE TARGETS (THIS IS ALSO CALLED THE +C BIAS TERM). + + + +C 1ST CHECK THAT ALL THE ENTRIES IN DOSES ARE NON-NEGATIVE. IF ANY + +C ISN'T, RETURN A LARGE POSITIVE VALUE (AN UNATTRACTIVE VALUE) FOR +C EXPSUM. THIS CHECK IS ADDED AS OF CALCBST4.FOR (IT SHOULD HAVE BEEN +C IN PLACE ALL ALONG). + + DO I=1,NDOS + IF(DOSES(I) .LT. 0.D0) THEN + EXPSUM = 1.D38 + RETURN + ENDIF + END DO + + +C CALCULATE EXPSUM AS DEFINED ABOVE. + +C INITIALIZE THE MEAN RESPONSE AT EACH OUTPUT TIME, FOR EACH +C OUTPUT EQ. TO BE 0. AT THE END OF THE DO IGRD LOOP, YBAR(I,J) +C WIL BE THE MEAN RESPONSE OVER ALL THE GRID PTS. FOR OBS. I +C AND OUTPUT EQ. J. + + + + DO I=1,NOBSER + DO J=1,NUMEQT + YBAR(I,J) = 0.D0 + END DO + END DO + + + SUM = 0.D0 + + DO IGRD = 1,NGRD + +C STORE INTO THETA THE PARAMETER VALUES FOR GRID POINT IGRD. + + DO J=1,NVAR + THETA(J) = DENSITY(IGRD,J) + END DO + +C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO +C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL +C MAKEVEC TO DO THIS. + + CALL MAKEVEC(NVAR,NOFIX,IRAN,THETA,VALFIX,PX) + + ND41 = NDD41 + +C MUST CHANGE THE NAME OF NDD41 TO ND41 SINCE IT IS SUPPLIED AS AN +C ARGUMENT TO WSUMSQ. + + CALL WSUMSQ(NOBSER,PX,NDOS,DOSES,WSS,PRED,ND41,YOO) + + +C STORE THE VALUES IN PRED INTO GRIDPRED IN CASE THE EXPSUM BELOW +C TURNS OUT TO BE THE MINIMUM SUM SO FAR, IN WHICH CASE ALL THESE +C PREDICTED VALUES WILL BE STORED INTO COMMON/PREDVAL FOR USE BY +C MAIN. + + DO I=1,NOBSER + DO J=1,NUMEQT + GRIDPRED(IGRD,I,J) = PRED(I,J) + END DO + END DO + +C ADD DENSITY(IGRD,NVAR+1)*PRED(.,.) TO YBAR(.,.). + + DO I=1,NOBSER + DO J=1,NUMEQT + YBAR(I,J) = YBAR(I,J) + DENSITY(IGRD,NVAR+1)*PRED(I,J) + END DO + END DO + + +C WSS RETURNS AS THE SUM OF SQUARES OF DIFFERENCES BETWEEN +C THE TARGET AND OBSERVED VALUES GIVEN INPUT INFO. + + SUM = SUM + DENSITY(IGRD,NVAR+1)*WSS + + + END DO + +C THE ABOVE END DO IS FOR THE DO IGRD = 1,NGRD LOOP. + + +C NOW YBAR(I,J) IS THE WEIGHTED MEAN RESPONSE FOR THE ITH TIME AND +C THE JTH OUTPUT EQ. CALCULATE THE MEAN-SQUARE BIAS ERROR AS THE +C SUM OF SQUARES OF DIFFERENCES BETWEEN YBAR(.,.) AND THE TRUE +C OBSERVED VALUES, YO(I,J). + + BIAS = 0.D0 + + DO I=1,NOBSER + DO J=1,NUMEQT + BIAS = BIAS + (YBAR(I,J) - YOO(I,J))**2.D0 + END DO + END DO + + + EXPSUM = (1.D0 - BIASWEIGHT)*SUM + BIASWEIGHT*BIAS + +C IF THIS EXPSUM IS LESS THAN THE CURRENT EXPSUMMIN THEN STORE THE +C VALUES IN GRIDPRED INTO PREDMIN WHICH IS PUT INTO COMMON/PREDVAL. +C ALSO STORE THESE BEST VALUES OF EXPSUMMIN, SUMMIN, AND BIASMIN. + + IF(EXPSUM .LT. EXPSUMMIN) THEN + EXPSUMMIN = EXPSUM + SUMMIN = SUM + BIASMIN = BIAS + DO IGRD = 1,NGRD + DO I=1,NOBSER + DO J=1,NUMEQT + PREDMIN(IGRD,I,J) = GRIDPRED(IGRD,I,J) + END DO + END DO + END DO + ENDIF + + EEXPSUMMIN = EXPSUMMIN + + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE WSUMSQ(NOBSER,PX,NDOS,DOSES,WSS,PRED,ND41,YOO) + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION DOSES(5000),TIM(594),SIG(5000),YOO(594,MAXNUMEQ), + 1 RS(5000,34),YO(594,MAXNUMEQ),BS(5000,7),PRED(594,MAXNUMEQ), + 2 PX(32),YYPRED(72000,MAXNUMEQ),TPRED(72000) + + COMMON/OBSER/ TIM,SIG,RS,YO,BS + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/CNST2/ NPL,NUMEQT,NDRUG,NADD + COMMON/TOSUMSQ/ITARGET,NVAR,NOFIX,NDIM,IDELTA,TNEXT + +C NOTE THAT COMMON/TOSUMSQ VALUES ARE PROVIDED TO THIS ROUTINE VIA +C MAIN. + + +C THIS ROUTINE IS CALLED BY SUBROUTINE CALCS TO CALCULATE WSS, WHICH IS +C THE SUM OF SQUARES OF DIFFERENCES BETWEEN TARGET AND ACTUAL VALUES, +C GIVEN PARAMETER VALUES (RANDOM AND FIXED) IN PX, AND THE DOSE AMOUNTS +C IN THE DOSES VECTOR. + +C FIRST STORE THE DOSES INTO RS. NOTE THAT THOSE DOSES WHICH ARE +C NOT OPTIMIZED OVER CONTINUE TO BE THEIR ORGINAL VALUES. AND NOTE THAT +C THE ONLY DOSES OPTIMIZED OVER ARE THE NON-0 ONES THAT OCCUR IN THE +C "FUTURE" (I.E, FROM DOSE EVENT ND41+1 TO ND). + + IDOS = 0 + + DO I = ND41+1,ND + DO J = 1,NDRUG + IF(RS(I,2*J-1) .GT. 0.D0) THEN + IDOS = IDOS + 1 + RS(I,2*J-1) = DOSES(IDOS) + ENDIF + IF(RS(I,2*J) .GT. 0.D0) THEN + IDOS = IDOS + 1 + RS(I,2*J) = DOSES(IDOS) + ENDIF + END DO + END DO + +C AS OF BESTDOS104.FOR/CALCBST8.FOR, MUST REESTABLISH THE BOLUS +C VALUES HERE SINCE THEY WERE ASSIGNED THEIR VALUES FROM THE CALL TO +C FILRED WHICH OCCURRED BEFORE ELDERY WAS CALLED. BUT NOW ELDERY CAN +C OPTIMIZE OVER BOLUS VALUES ALSO, WHICH MEANS THAT IT COULD CHANGE +C THE BOLUS VALUES, AND SO THEY MUST BE REESTABLISHED HERE. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + +C NOTE THAT YO(I,J); I=1,NOBSER; J=1,NUMEQT ARE THE "TARGET" OBSERVED +C VALUES WHICH WERE READ FROM THE PATIENT DATA FILE BY SUBROUTINE +C FILRED (AND PLACED INTO COMMON/OBSER). + +C PRIOR TO CALCBST12.FOR, THESE Y0(.,.) VALUES WERE ALWAYS +C CONCENTRATIONS. BUT AS OF CALCBST12 ... +C IF ITARGET = 1, THESE OBSERVED VALUES ARE CONCENTRATIONS; +C IF ITARGET = 2, THESE OBSERVED VALUES ARE AUCs. + +C SO IF ITARGET = 1, CALL CALCPRED TO GET PRED(.,.), JUST AS IN +C CALCBST11.FOR AND PRIOR PROGRAMS. + +C BUT IF ITARGET = 2, CALL CALCTPRED2 TO GET A RICH SUPPLY OF PREDICTED +C TIMES OVER WHICH CONCENTRATIONS CAN BE FOUND, AND FROM WHICH ACCURATE +C AUCs CAN BE CALCULATED (SEE BELOW). + + IF(ITARGET .EQ. 1) THEN + +C CALL CALCPRED, WHICH CALCULATES THE ACTUAL PREDICTED VALUES ASSUMING +C THE DOSE AMOUNTS, DOSES(I),I=1,NDOS (WHICH OCCUR AT THE TIMES WHICH +C WERE STORED INTO SIG(I),I=1,ND IN COMMON/OBSER BY SUBROUTINE FILRED +C PREVIOUSLY), AND THE PARAMETER VALUES STORED INTO PX. + + + CALL CALCPRED(PX,PRED) + + ENDIF + + + IF(ITARGET .EQ. 2) THEN + +C NOTE THAT THE SUM OF SQUARES, WSS, WILL BE CALCULATED OVER THE +C NOBSER x NUMEQT OBSERVED VALUES, WHICH OCCUR AT TIMES, +C TIM(I),I=1,NOBSER. THESE OBSERVED VALUES ARE TARGET AUCs. IN ORDER +C TO CALCULATE ACCURATE AUCs, USING THE TRAPEZOIDAL RULE, IT IS +C NECESSARY TO HAVE A RELATIVELY RICH SET OF CONCENTRATIONS (I.E., THE +C TRAPEZOIDAL RULE GIVES AN ACCURATE ESTIMATE OF THE TRUE INTEGRAL AS +C LONG AS THE DELTA BETWEEN 2 CONSECUTIVE CONCENTRATION TIMES IS SMALL, +C SO THAT THE CURVE RUNNING THROUGH THESE CONCENTRATIONS CAN BE +C REASONABLY WELL APPROXIMATED BY A STRAIGHT LINE). + +C CALL SUBROUTINE CALCTPRED2 TO ESTABLISH THE RICH SET OF TIMES +C TO BE USED TO CALCULATE THE AUCs. + + CALL CALCTPRED2(NOBSER,TNEXT,IDELTA,NUMT,TPRED) + + + +C CALL SUBROUTINE IDCALCYY FOR THE PARAMETERS IN PX. +C THIS IS A VERSION OF THE ID PROGRAM WHICH CALCULATES THE PREDICTED +C VALUES OF Y(I,J) (OUTPUT CONCENTRATION OF THE JTH OUTPUT EQ. AT TIME +C TPRED(I),I=1,NUMT), ASSUMING THE GIVEN GRID PT. NOTE THAT IN +C DCALCYY, THE PREDICTED VALUES ARE SUPPLIED IN TPRED, RATHER THAN +C INPUT VIA COMMON/OBSER FROM THE PATIENT'S DATA FILE. ALSO, THE NO. +C OF OBSERVED TIMES IS NUMT, RATHER THAN M WHICH IS SUPPLIED VIA +C COMMON/SUM2. AND NOTE THAT NUMT AND TPRED(.) ARE FOUND FROM THE CALL +C TO CALCTPRED2 ABOVE. + + CALL IDCALCYY(NVAR+NOFIX,NDIM,PX,TPRED,NUMT,YYPRED,NUMEQT) + + DO J = 1,NUMEQT + +C INEXTTIM WILL BE THE INDEX OF THE NEXT OBSERVATION TIME. INITIALIZE +C IT TO BE 1. + + INEXTTIM = 1 + +C THE AUC STARTS AT 0 AT TPRED(1), WHICH WILL BE 0. THEN IT WILL +C BE UPDATED FOR EACH INTERVAL, USING THE TRAPEZOIDAL RULE. + + DO I = 1,NUMT + + IF(I .EQ. 1) AUC = 0.D0 + +C AS OF BESTDOS116.FOR, AUCs IN THE "FUTURE" ARE RELATIVE TO THE +C BEGINNING OF THE "FUTURE", WHICH OCCURS AT TNEXT. SO SET AUC BACK +C TO 0 AT TIME TNEXT. + +C NO! AS OF BESTDOS118.FOR, THE AUCs WILL BE CUMULATIVE FROM TIME 0 IN +C THE "PAST". SO COMMENT OUT THE CODE BELOW TO CALL THESAME, AND +C COMMENT OUT THE RESETTING OF AUC IF ISAME = 1. + +C CALL THESAME(TPRED(I),TNEXT,ISAME) + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TPRED(I) = TNEXT, +C OR AT LEAST, THEY ARE WITHIN 1.D-10 OF EACH OTHER. IN THIS CASE, +C SET AUC BACK TO 0. + + IF(I .GT. 1) THEN + DELTA = TPRED(I) - TPRED(I-1) + AUC = AUC + (YYPRED(I,J) + YYPRED(I-1,J))/2.D0 * DELTA +C IF(ISAME .EQ. 1) AUC = 0 + ENDIF + +C IF THE CURRENT TPRED(I) IS THE NEXT OBSERVATION TIME, THEN STORE THE +C AUC INTO PRED(I,J). + + CALL THESAME(TPRED(I),TIM(INEXTTIM),ISAME) + +C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TPRED(I) = THE NEXT +C OBSERVATION TIME, TIM(INEXTTIM), OR AT LEAST, THEY ARE WITHIN 1.D-10 +C OF EACH OTHER. IN THIS CASE, STORE THE AUC INTO PRED(INEXTTIM,J). + + IF(ISAME .EQ. 1) THEN + PRED(INEXTTIM,J) = AUC + INEXTTIM = INEXTTIM + 1 + END IF + + END DO +C THE ABOVE END DO IS FOR THE DO I = 1,NUMT LOOP. + + END DO +C THE ABOVE END DO IS FOR THE DO J = 1,NUMEQT LOOP. + + + ENDIF +C THE ABOVE ENDIF IS FOR THE IF(ITARGET .EQ. 2) CONDITION. + + +C NOW CALCULATE WSS. + +C NOTE THAT YO(I,J),I=1,NOBSER; J=1,NUMEQT ARE THE "TARGET" OBSERVED +C VALUES WHICH WERE READ FROM THE PATIENT DATA FILE BY SUBROUTINE +C FILRED (AND PLACED INTO COMMON/OBSER). MUST CHECK YO VALUES FOR -99 + +C (MISSING VALUE CODE), AND IGNORE ANY IN THE FOLLOWING LOOPS. +C ALSO NOTE THAT YOO(.,.) IS SET = YO(.,.) IN THE LOOPS BELOW SO YOO +C CAN BE PASSED BACK TO SUBROUTINE CALCS. + + + SUM = 0.D0 + DO I=1,NOBSER + DO J=1,NUMEQT + IF(YO(I,J) .NE. -99) + 1 SUM = SUM + (PRED(I,J) - YO(I,J))**2.D0 + YOO(I,J) = YO(I,J) + END DO + END DO + + WSS = SUM + + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE CALCPRED(PX,PRED) + +C THIS ROUTINE IS CALLED BY SUBROUTINE WSUMSQ TO CALCULATE PRED, THE +C ARRAY OF PREDICTED CONCENTRATIONS, BASED ON THE DOSES, DOSE TIMES, +C AND OBSERVATION TIMES IN COMMON/OBSER, AND THE PARAMETER VECTOR +C PX, WHICH INCLUDES BOTH RANDOM AND FIXED VALUES. + +C INPUT ARE: + +C PX = VECTOR OF RANDOM AND FIXED PARAMETER VALUES. + +C INFORMATION FROM A SUBJECT DATA FILE WHOSE INFO IS PASSED TO THE +C ROUTINES IN THIS MODULE VIA COMMONS /OBSER/, /CNST/, /CNST2/, AND +C /SUM2/. + + +C OUTPUT IS: + +C PRED(I,J),I=1,M; J=1,NUMEQT THE PREDICTED CONCENTRATION VALUES +C (SEE ABOVE). + +C----------------------------------------------------------------------- +C NOTE: CALCPRED IS A VARIATION OF THE MAIN ROUTINE IN idm1x3.f. + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION PX(32),P(32),PRED(594,MAXNUMEQ) + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/PARAMD/ P + +C*****INITIALIZE PROGRAM***** + + CALL SYMBOL + +C THE ABOVE CALL OBTAINS N AND NP AND NTLAG VIA COMMON/CNST ... + +C PUT MODEL PARAMETER VALUES (RANDOM AND FIXED) INTO P. + + DO I=1,NP + P(I) = PX(I) + END DO + + CALL GETPRED(PRED) + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE GETPRED(PRED) + +C PROGRAM TO DETERMINE PRED(I) = PREDICTED CONCENTRATION AT TIME I, +C GIVEN P IN COMMON/PARAMD. + +C NOTE THAT THIS ROUTINE IS BASED ON idm1x14.f IN THE NPAG PROGRAM. + + IMPLICIT REAL*8(A-H,O-Z) + COMMON/BOLUSCOMP/NBCOMP + COMMON/SUM2/ M,NPNL + COMMON/OBSER/ TIM,SIG,RS,YO,BS + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/INPUT/ R,B + COMMON/PARAMD/ P + COMMON/CNST2/ NPL,NOS,NDRUG,NADD + COMMON/STATE/ X + COMMON/ERROR/ERRFIL + PARAMETER(MAXNUMEQ=7) + +C COMMON/ERR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. + + + DIMENSION X(20),P(32),TIM(594),SIG(5000),SIGO(5000),R(37), + 1 RS(5000,34),RSO(5000,34),YT(MAXNUMEQ),YO(594,MAXNUMEQ), + 2 BS(5000,7),Y(594,MAXNUMEQ),B(20),NBCOMP(7), + 3 PRED(594,MAXNUMEQ),FA(7),TLAG(7),XSTORE(100,20),XPRED(20) + + CHARACTER ERRFIL*20 + + +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + +C NOTE THAT AS OF CALCBST15.FOR, THE DIMENSIONS OF 6 IN XSTORE AND +C XPRED HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN +C ALL ALONG (I.E., THE SAME AS FOR X). + +C NOTE THAT THE DIMENSIONS RELATED TO THE NO. OF OUTPUT EQS. IN +C YO, YT, Y AND PRED ARE CHANGED TO MAXNUMEQ (FROM 6). NUMEQT COULD NOT +C BE USED BECAUSE THESE ARRAYS WERE NOT PASSED TO THIS ROUTINE AS +C DUMMY ARGUMENTS. + +C NOTE THAT "7" IN THE ABOVE ARRAYS INDICATE THE NO. OF DRUGS ALLOWED. + +C R(7) CHANGED TO R(20) <-- No. of 'rate inputs' +C B(3) CHANGED TO B(20) <-- No. of different bolus inputs +C CHANGED X(3) TO X(20) <-- No. of compartments +C IC(10) CHANGED TO IC(20) <-- Initial conditions in compartments; +C should have been changed to 20 previously (like X,B). +C NBCOMP(10) CHANGED TO NBCOMP(20) <-- Same remarks as for IC. +C P(10) CHANGED TO P(32) <-- No. of parameters + + +C*****ODE CONSTANTS AND INITIALIZATION***** + + KNS=1 + KNT=1 + +C NOTE THAT KNT IS THE RUNNING INDEX OF THE NEXT OBSERVATION TIME, +C AND KNS IS THE RUNNING INDEX OF THE NEXT DOSAGE TIME. + + T=0.0D0 + +C INITIALIZE ISKIPBOL = 0. SEE CODE BELOW. IT IS ONLY NEEDED FOR A +C STEADY STATE DOSE SET WHICH HAS BOLUS DOSES. + + ISKIPBOL = 0 + + + + DO I = 1,NDRUG + R(2*I-1) = 0.D0 + END DO + +c AS OF idm1x7.f, instead of R(1) = 0, the code has been changed to +c set R(2*I-1) = 0, for I = 1,NDRUG. I.E., All IV rates for all NDRUG +c drugs are initialized to be 0 ... in case the 1st obs. time is 0, +c which means that OUTPUT is called before the R(I) are set below. + + +C CALL SUBROUTINE GETFA IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETFA IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF FA FOR EACH +C OF THE NDRUG DRUGS. + +C AS OF idm1x13.f, BEFORE CALLING GETFA, MUST SET +C THE R(.) IN CASE ANY OF THE FA(.) ARE FUNCTIONS OF THE +C COVARIATES WHICH ARE ESTABLISHED FROM THE R(.) VALUES IN +C GETFA. + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + CALL GETFA(FA) + + +C NOTE THAT NBCOMP(I),I=1,NDRUG WAS SET IN SUBROUTINE SYMBOL AND + +C PASSED TO THIS ROUTINE VIA COMMON/BOLUSCOMP. + + +C As of idm1x12.f, the code to save ND0, SIGO, RSO, is moved to before +c the IF(N .EQ. 0) GO TO 75 statement. The reason is that before this +c routine returns, ND, SIG, and RS are reset back to these values, +c even if N = 0, and so they must be established at this time. + +C AS OF idm1x9.f, SAVE ND, SIG, AND RS WHETHER OR NOT NTL = 1, SINCE +C IF THERE ARE STEADY STATE DOSE SETS, THE FIRST SIG(.) VALUE IN EACH +C SET WILL BE CHANGED TO BE 0 BELOW. + + NDO = ND + DO I=1,ND + SIGO(I) = SIG(I) + DO J=1,NI + RSO(I,J) = RS(I,J) + END DO + END DO + + +C IF N = 0, THE OUTPUT EQUATION(S) FOR Y ARE CODED EXPLICITLY INTO +C SUBROUTINE OUTPUT, AND NO D.E. SOLUTIONS (VIA USERANAL/DIFFEQ) ARE + +C TO BE USED. IN THIS CASE, SKIP THE CODE REGARDING INITIAL CONDITIONS +C OF THE COMPARTMENTS, SINCE THEY ARE IRRELEVANT (I.E., THE COMPARTMENT +C AMOUNTS DON'T NEED TO BE INITIALIZED SINCE THEY WON'T BE UPDATED BY +C INTEGRATING D.E.'S). IN FACT, COULD PROBABLY SKIP TIMELAGS TOO, +C SINCE THEY CHANGE THE TIME THAT BOLUS DOSES ARE GIVEN, AND THIS +C THEORETICALLY ONLY AFFECTS COMPARTMENT AMOUNTS (WHICH ARE NOT USED + +C IF N = 0), BUT JUST SKIP INITIAL CONDITIONS FOR NOW. + + IF(N .EQ. 0) GO TO 75 + + +C CALL SUBROUTINE GETIX IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETIX IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF X (THE INITIAL +C COMPARTMENT AMOUNT) FOR EACH OF THE N COMPARTMENTS. + + CALL GETIX(N,X) + + + +C CALL SUBROUTINE GETTLAG IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETTLAG IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF THE TIMELAG +C FOR EACH OF THE NDRUG DRUGS. + + 75 CALL GETTLAG(TLAG) + +C IF ANY TLAG(.) VALUES RETURN AS .NE. 0, THEN, CALL SUBROUTINE SHIFT +C TO ADJUST THE DOSAGE REGIMEN APPROPRIATELY. + + NTL = 0 + DO ID = 1,NDRUG + IF(TLAG(ID) .NE. 0) NTL = 1 + END DO + + IF(NTL .EQ. 1) THEN + +C STORE INCOMING VALUES IN ND, SIG, AND RS (WHICH CONTAINS BS VALUES) +C SINCE THEY WILL BE CHANGED IN THE CALL TO SUBROUTINE SHIFT, WHICH +C "SHIFTS" THE DOSAGE REGIMEN MATRIX TO ACCOUNT FOR THE TIMELAG +C PARAMETER(S), TLAG(I). AT THE END OF THIS ROUTINE, THE VALUES IN ND, +C SIG, AND RS WILL BE RESET TO THEIR INCOMING VALUES - TO BE READY FOR +C THE NEXT CALL TO THIS ROUTINE WITH POSSIBLY DIFFERENT VALUES FOR +C TLAG(I). + + + CALL SHIFT(TLAG,ND,SIG,NDRUG,NADD,RS) + + +C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NTL .EQ. 1) CONDITION. + + IF(TIM(KNT).GE.SIG(KNS)) GO TO 12 + IF(TIM(KNT).NE.0.0D0) GO TO 45 + +C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) +C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. + + CALL OUTPUT(0.D0,YT) + DO 2000 I=1,NOS +2000 Y(KNT,I)=YT(I) + KNT=KNT+1 + GO TO 45 + +12 IF(TIM(KNT).GT.SIG(KNS)) GO TO 13 + IF(TIM(KNT).NE.0.0D0) GO TO 45 + +C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) +C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. + + CALL OUTPUT(0.D0,YT) + DO 2005 I=1,NOS +2005 Y(KNT,I)=YT(I) + KNT=KNT+1 + +13 IF(SIG(KNS) .GT. 0.0D0) GO TO 45 + +C CHECK TO SEE IF SIG(KNS) < 0. IF SO, IT MEANS THAT 100 STEADY STATE +C DOSES SHOULD NOW BE APPLIED WITH AN INTERDOSE INTERVAL EQUAL TO +C -SIG(KNS). + + ISTEADY = 0 + + IF(SIG(KNS) .LT. 0.D0) THEN + + ISTEADY = 1 + NSET = 1 + +C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE +C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 +C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... +C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. +C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE +C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE +C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE +C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC +C OF PREDLAST3 REQUIRES). + +C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT +C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS +C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF +C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE +C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. + +C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF +C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL +C INTEGRATED THROUGH, WHICHEVER COMES FIRST. + + DOSEINT = -SIG(KNS) + +C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START +C OF 100 DOSE SETS THAT BEGIN AT TIME 0. + + + SIG(KNS) = 0 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. + + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + IF(NDRUG .EQ. 0) GO TO 81 + +C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT +C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED +C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. + + CALL GETFA(FA) + + + IF(N .EQ. 0) GO TO 120 + + DO I=1,NDRUG + X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS,I)*FA(I) + END DO + +C NOTE THAT FA(I) IS THE FRACTION OF DRUG AVAILABLE FROM A BOLUS INPUT +C FOR DRUG I INTO ITS ABSORPTIVE COMPARTMENT. + + GO TO 81 + +120 DO I=1,NDRUG + B(I)=BS(KNS,I)*FA(I) + END DO + +81 KNS = KNS+1 + + +C*****INTEGRATION OF EQUATIONS***** + + +C DETERMINE IF, OBSER(ID=0), OR DOSE(ID=1), OR BOTH(ID=2). + +45 IF(KNS .GT. ND) GO TO 15 + + +C CODE CHANGE BELOW FOR idm1x8.f. + + IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) THEN + +C AS OF idm1x7.f, A TIME RESET NO LONGER REQUIRES ALL INITIAL +C COMPARTMENT AMOUNTS TO BE RESET TO 0. THIS IS BECAUSE A TIME RESET +C NO LONGER HAS TO MEAN THAT AN "INFINITE" AMOUNT OF TIME HAS OCCURRED +C WITH NO DOSING; IT CAN ALSO NOW MEAN THAT AN "INFINITE" AMOUNT OF +C TIME HAS OCCURRED WITH UNKNOWN DOSING (IN THIS CASE, SUBROUTINE +C GETIX WILL BE CALLED BELOW TO ESTABLISH INITIAL CONDITIONS FOR THIS +C TIME PERIOD). + +C ADVANCE KNS TO THE NEXT VALUE THAT HAS SIG(KNS) .LE. 0. I.E., ONCE +C TIMN(KNT) = 0, IT MEANS THAT WE ARE DONE WITH THE OUTPUT OBS. +C TIMES IN THE PREVIOUS SECTION --> THERE IS NO POINT IN CONTINUING +C TO INTEGRATE TILL THE END OF THE DOSES IN THE PREVIOUS SECTION +C (IF THERE ARE ANY). + + DO IKNS = KNS,ND + IF(SIG(IKNS) .LE. 0.D0) GO TO 110 + END DO + + +C TO GET HERE MEANS THAT NO VALUE IN SIG(.) FROM KNS TO ND HAS A +C VALUE .LE. 0, AND THIS IS AN ERROR. IT MEANS THAT THE PATIENT DATA +C FILE HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING +C DOSE RESET ROW. TELL THE USER AND STOP. + + WRITE(*,111) ND,KNS,SIG(KNS) +111 FORMAT(//' IN SUBROUTINE GETPRED, THE CURRENT SUBJECT HAS AN'/ + 1' OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE'/ + 2' RESET ROW. THE PROGRAM NOW STOPS. '// + 3' REVIEW YOUR PATIENT FILES AND CORRECT THE ERROR.'// + 4' NOTE THAT THE ',I4,' DOSE TIMES (POSSIBLY ALTERED BY TIMELAGS'/ + 5' ARE THE FOLLOWING (AND THERE IS NO TIME .LE. 0 AFTER TIME'/ + 6' NO. ',I4,' WHICH HAS CORRESPONDING TIME ',F15.4,'):') + + + DO I = 1,ND + WRITE(*,*) SIG(I) + END DO + + OPEN(47,FILE=ERRFIL) + WRITE(47,111) ND,KNS,SIG(KNS) + DO I = 1,ND + WRITE(47,*) SIG(I) + END DO + CLOSE(47) + + + CALL PAUSE + STOP + + + 110 KNS = IKNS + + +C THERE ARE TWO POSSIBILITES AT THIS POINT, EITHER SIG(KNS) = 0 +C OR SIG(KNS) < 0. + +C IF SIG(KNS) = 0, THIS REPRESENTS A TIME RESET (T WILL BE SET = 0 +C BELOW) WITH A SINGLE DOSE LINE TO START. IN THIS CASE, CALL GETIX +C AGAIN (JUST AS WAS DONE NEAR THE TOP OF THIS ROUTINE) TO OBTAIN +C INITIAL COMPARTMENT AMOUNTS. NOTE THAT BY DEFAULT, IN GETIX, ALL +C COMPARTMENT AMOUNTS ARE SET = 0 (WHICH WOULD BE THE CASE IF IN THE +C LONG TIME PERIOD BETWEEN THE LAST SET OF DOSES AND THIS NEW +C BEGINNING, NO DOSES HAVE BEEN GIVEN). BUT THE USER MAY ALSO HAVE +C CODED INTO GETIX EQUATIONS THAT SET ONE OR MORE OF THE X(I) TO +C FUNCTIONS OF COVARIATE AND PARAMETER VALUES (WHICH WOULD BE THE +C SITUATION IF AN UNKNOWN DOSING REGIMEN HAS TAKEN PLACE BUT IT +C DOESN'T MATTER WHAT IT WAS BECAUSE THE PATIENT COMES TO A LAB AND +C SIMPLY HAS HIS COMPARTMENT VALUES ESTABLISHED BEFORE CONTINUING +C WITH THE OTHER VALUES IN HIS PATIENT FILE). + +C IF SIG(KNS) < 0, THIS REPRESENTS A TIME RESET WITH A STEADY STATE +C SET OF 100 DOSES ABOUT TO BEGIN. IN THIS CASE, WE ASSUME THAT THE +C PATIENT IS ABOUT TO GET 100 SETS OF DOSES SO THAT HIS COMPARTMENT +C AMOUNTS WILL ACHIEVE STEADY STATE VALUES. THESE STEADY STATE VALUES +C WILL BE ESTIMATED IN THE BLOCK OF CODE BELOW THAT STARTS WITH +C IF(ISTEADY .EQ. 1). IN THIS CASE, WE WILL STILL CALL GETIX TO +C MAKE SURE THAT ANY RESIDUAL COMPARTMENT AMOUNTS FROM A PREVIOUS +C SET OF DOSES IS ZEROED OUT (OR SET = VALUES AS DETERMINED BY +C SUBROUTINE GETIX). + +C AS OF idm1x14.f, BEFORE CALLING GETIX, MUST SET +C THE R(.) IN CASE ANY OF THE INITIAL CONDITIONS FOR THE X(.) +C ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM THE +C R(.) VALUES IN GETFA. + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + + + CALL GETIX(N,X) + +C MUST ALSO RESET T = 0 SINCE THE INTEGRATION WILL AGAIN START FROM +C TIME 0. + + T = 0.D0 + +C IF SIG(KNS) .LT. 0, THIS IS NOT ONLY A TIME RESET, IT IS THE +C BEGINNING OF A STEADY STATE DOSE SET. IN THIS CASE, APPLY 100 +C STEADY STATE DOSES WITH AN INTERDOSE INTERVAL EQUAL TO -SIG(KNS). + + ISTEADY = 0 + + IF(SIG(KNS) .LT. 0.D0) THEN + + ISTEADY = 1 + NSET = 1 + +C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE +C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 +C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... +C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. +C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE +C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE + +C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE +C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC +C OF PREDLAST3 REQUIRES). + + +C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT +C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS +C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF +C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE +C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. + +C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF +C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL +C INTEGRATED THROUGH, WHICHEVER COMES FIRST. + + DOSEINT = -SIG(KNS) + +C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START +C OF 100 DOSE SETS THAT BEGIN AT TIME 0. + + SIG(KNS) = 0 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) CONDITION. + + + + IF(TIM(KNT) .NE. SIG(KNS)) GO TO 20 + ID=2 + TOUT=TIM(KNT) + KNT=KNT+1 + KNS=KNS+1 + + IF(N .EQ. 0) GO TO 31 + GO TO 30 + +20 IF(TIM(KNT) .GT. SIG(KNS) .AND. SIG(KNS) .GT. 0) GO TO 25 + + +15 ID=0 + TOUT=TIM(KNT) + KNT=KNT+1 + IF(N .EQ. 0) GO TO 31 + GO TO 30 + +25 ID=1 + TOUT=SIG(KNS) + KNS=KNS+1 + IF(N .EQ. 0) GO TO 31 + +30 CONTINUE +32 IF(N .NE. -1) CALL USERANAL(X,T,TOUT) + IF(N .EQ. -1) CALL ANAL3(X,T,TOUT) + + + +C IF ISTEADY = 1, THIS IS INSIDE A STEADY STATE DOSE SET. CHECK TO SEE +C IF TOUT IS A MULTIPLE OF DOSEINT. IF SO, RECORD THE COMPARTMENT +C AMOUNTS. THEN, AFTER COMPARTMENT AMOUNTS HAVE BEEN STORED FOR AT +C LEAST THE 1ST 5 MULTIPLES OF DOSEINT, STOP AND CALL SUBROUTINE +C PREDLAST3 WHICH PREDICTS THE FINAL (STEADY STATE) COMP. AMOUNTS +C AFTER THE LAST (100TH) DOSE SET. + +C IF PREDLAST3 HAS PREDICTED VALUES WHICH "CONVERGE", ASSIGN THE +C PREDICTED VALUES TO X, INCREASE KNS TO BE THE INDEX OF THE FIRST +C DOSE EVENT WHICH OCCURS AFTER THE STEADY STATE DOSE SET ENDS AND +C CONTINUE. + +C IF PREDLAST3 VALUES DON'T CONVERGE, CONTINUE THE PROCESS WITH +C COMPARTMENT AMOUNTS FOR MULTIPLES 2 - 6 OF DOSEINT, TEST FOR +C "CONVERGENCE", ETC. THIS PROCESS CONTINUES UNTIL "CONVERGENCE" IS +C ACHIEVED FOR A SET OF 5 COMPARTMENT AMOUNTS (OR SETS OF AMOUNTS IF +C NDRUG IS > 1), OR UNTIL ALL 100 DOSE SETS IN THE STEADY STATE +C REGIMEN HAVE FINISHED. + + IF(ISTEADY .EQ. 1) THEN + + +C THE NEXT DOSE SET END TIME IS DOSEINT*NSET. IF TOUT = DOSEINT*NSET, +C STORE THE COMPARTMENT AMOUNTS. IF NSET .GE. 5, CALL PREDLAST3 AND +C PROCEED AS INDICATED ABOVE. + + CALL THESAME(TOUT,DOSEINT*NSET,ISAME) + + IF(ISAME .EQ. 1) THEN + + NN = N + IF(N .EQ. -1) NN = 3 + + DO J = 1,NN + XSTORE(NSET,J) = X(J) + END DO + + + IF(NSET .GE. 5) THEN + + CALL PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) + + + IF(ICONV .EQ. 1) THEN + +C SINCE THE PREDICTED VALUES ARE CONSIDERED ACCURATE (I.E., +C "CONVERGENCE WAS ACHIEVED IN PREDLAST), RESET ISTEADY TO 0, +C WHICH MEANS THAT THE STEADY STATE DOSES ARE FINISHED; ASSIGN THE +C COMPARTMENT AMOUNTS TO BE THE PREDICTED VALUES; AND SET KNS TO THE +C FIRST DOSE EVENT AFTER THE END OF THE STEADY STATE DOSE SET. ALSO, +C SET T = THE ENDING TIME OF THE STEADY STATE DOSE SET = 100*DOSEINT, +C SINCE THAT IS WHAT IT WOULD HAVE BEEN HAD ALL 100 DOSE SETS BEEN +C RUN. + + ISTEADY = 0 + + DO J = 1,NN + X(J) = XPRED(J) + END DO + + T = 100.D0*DOSEINT + + +C ADVANCE KNS TO BE THE FIRST DOSE PAST THE 100 DOSE SETS IN THIS +C STEADY STATE SET. NOTE THAT THIS SET ENDS BEFORE 100*DOSEINT, SO +C FIND THE FIRST SIG(.) THAT IS .GE. 100*DOSEINT, OR THAT IS = 0 +C (WHICH SIGNIFIES A TIME RESET) OR THAT IS < 0 (WHICH SIGNIFIES +C ANOTHER STEADY STATE SET). + + DO I = KNS,ND + IF(SIG(I) .GE. 100.D0*DOSEINT .OR. SIG(I) .LE. 0.D0) THEN + KNSNEW = I + GO TO 100 + + ENDIF + END DO + +C TO GET HERE MEANS THAT THERE ARE NO DOSE TIMES PAST THE END OF THIS +C STEADY STATE DOSE SET. IN THIS CASE, SET KNS TO ND+1. + + KNS = ND+1 + GO TO 200 + + 100 KNS = KNSNEW + 200 CONTINUE + + +C SET ISKIPBOL = 1 WHENEVER CONVERGENCE OCCURS IN +C THE STEADY STATE DOSES SINCE IN THIS CASE, WE DON'T WANT TO +C REAPPLY THE LAST BOLUS FROM THE STEADY STATE SET BELOW LABEL 83. + + ISKIPBOL = 1 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICONV .EQ. 1) CONDITION. + +C IF ICONV = 0, ISTEADY IS STILL = 1, +C WHICH MEANS THAT THE ATTEMPT TO PREDICT THE FINAL (STEADY STATE) +C COMPARTMENT AMOUNTS CONTINUES. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NSET .GE. 5) CONDITION. + +C SINCE ISAME = 1, THE END OF THE SET NO. NSET HAS OCCURRED --> +C INCREASE NSET BY 1. + + + NSET = NSET + 1 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISTEADY .EQ. 1) CONDITION. + + + +31 CONTINUE + +C RECORD OBSERVATION AND SUPPLY NEW DOSE + + IF(ID .EQ. 1) GO TO 35 + KNTM1=KNT-1 + +C NOTE THAT THE TIME AT WHICH THE OUTPUT IS DESIRED IS TIM(KNTM1); THIS +C IS CLEAR SINCE THE RETURNING VALUE(S) IN YT ARE PUT INTO ROW NO. +C KNTM1 OF Y. + + CALL OUTPUT(TIM(KNTM1),YT) + + DO 2010 I=1,NOS +2010 Y(KNTM1,I)=YT(I) + +55 IF(ID.EQ.0) GO TO 40 + + 35 CONTINUE + + IF(NI .EQ. 0) GO TO 83 + + DO I=1,NI + R(I)=RS(KNS-1,I) + END DO + +C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT +C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED +C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. + + + CALL GETFA(FA) + + +83 IF(NDRUG .EQ. 0 .OR. N .EQ. 0) GO TO 82 + +C ADDING N .EQ. 0 TO ABOVE IF STATEMENT SHOWS CLEARLY THAT IF +C N = 0 (IN WHICH CASE ANALYTIC SOLUTIONS ARE CODED DIRECTLY INTO +C SUBROUTINE OUTPUT, WHICH MAKES THE COMPARTMENT AMOUNTS IRRELEVANT) +C SETTING VALUES FOR THE COMPARTMENTS, X, IS UNNECESSARY. + + +C IF ISKIPBOL = 1, DO NOT APPLY BOLUSES FROM DOSE KNS-1, SINCE THESE +C BOLUSES WERE PART OF THE STEADY STATE DOSE SET WHICH ALREADY HAD +C BOLUSES (EFFECTIVELY) APPLIED ABOVE WHERE "CONVERGENCE" OF THE +C STEADY STATE DOSE SET WAS OBTAINED. + + IF(ISKIPBOL .EQ. 0) THEN + DO I=1,NDRUG + X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS-1,I)*FA(I) + END DO + ENDIF + +C RESET ISKIPBOL = 0 HERE. IF IT IS NOW = 1, IT MEANS THAT +C THE ABOVE APPLICATION OF BOLUSES WAS SKIPPED SINCE THERE HAS JUST +C BEEN A STEADY STATE SET OF DOSES WHICH CONVERGED (AND WE DON'T +C WANT THE LAST BOLUS DOSE REAPPLIED). BUT, GOING FORWARD, ISKIPBOL +C SHOULD BE SET AGAIN TO 0 SO THE ABOVE APPLICATION OF BOLUSES WILL +C OCCUR WHENEVER THERE IS A NEW BOLUS TO BE APPLIED. + + ISKIPBOL = 0 + + +82 CONTINUE + +C CHECK STOPPING TIME. + + +40 IF(KNT .LE. M) GO TO 45 + +C ESTABLISH PRED(I,J), I=1,M; J=1,NOS. + + + DO J=1,NOS + DO I=1,M + PRED(I,J) = Y(I,J) + END DO + END DO + +C AS OF idm1x9.f, RESTORE THE VALUES FOR ND, SIG, AND RS, IN CASE +C THIS MODEL HAS TIME LAGS OR STEADY STATE DOSES - TO BE READY FOR THE +C NEXT CALL TO THIS ROUTINE. + + ND = NDO + DO I=1,ND + SIG(I) = SIGO(I) + DO J=1,NI + RS(I,J) = RSO(I,J) + END DO + END DO + +C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE MAKEVEC(NVAR,NOFIX,IRAN,X,VALFIX,PX) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION IRAN(32),X(30),VALFIX(20),PX(32) + +C THIS ROUTINE, CALLED BY MAIN, INPUTS NVAR, NOFIX, IRAN, X, AND +C VALFIX, AND RETURNS PX(I) = A COMBINATION OF THE VALUES IN X AND +C VALFIX IN THE PROPER ORDER (AS DETERMINED BY IRAN). + + NNNVAR=0 + NNNFIX=0 + + DO I=1,NVAR+NOFIX + + IF(IRAN(I) .EQ. 1) THEN + NNNVAR=NNNVAR+1 + PX(I) = X(NNNVAR) + ENDIF + + IF(IRAN(I) .EQ. 0) THEN + NNNFIX=NNNFIX+1 + PX(I) = VALFIX(NNNFIX) + ENDIF + + END DO + + RETURN + END + +C IDM1X15.FOR 7/7/14 + +C IDM1X15.FOR = idmx1x15.f, EXCEPT THE TWO WRITE STATEMENTS TO FILE +C 25 ARE REMOVED, SINCE FILE 25 IS NOT ACTIVE IN THIS PROGRAM. + +C AND, IN SUBROUTINE FUNC, COMMON/ERROR/ERRFIL IS ADDED; ERRFIL IS +C DECLARED CHARACTER*20; AND FORMAT 111 AND SIG(.) ARE WRITTEN TO +C ERRFIL JUST BEFORE THE PROGRAM STOPS IF THE PATIENT DATA FILE +C HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE +C RESET ROW. + +c----------------------------------------------------------------------- + +c idm1x15.f 3/6/14 + +c idm1x15 has the following changes from idm1x14: + +c 1. In Subroutine FUNC, the dimensions related to the no. of output +c equations have been changed from 6 to NUMEQT OR MAXNUMEQ (see +c comments in that routine). + +c 2. In Subroutines FUNC and PREDLAST3, the dimensions of 6 in XSTORE, +c XPRED, and COMP have been changed to 20, as they should have been +c all along (i.e., this represents the maximum no. of compartments +c allowed). + +c----------------------------------------------------------------------- + +c idm1x14.f 10/11/12 + +c idm1x14 has one correction from idm1x13: + +c THE R(.) ARE SET = RS(.,.) BEFORE GETIX IS CALLED IN THE TIME RESET +c SECTION OF SUBROUTINE FUNC. NOT DOING THIS WOULD MEAN THAT IF THE +C INITIAL CONDITIONS FOR THE X(.) ARE FUNCTIONS OF THE COVARIATES +C (ESTABLISHED IN GETIX FROM THE R(.) VALUES), THEY WOULD BE ASSIGNED +C VALUES BASED ON COVARIATES FROM A PREVIOUS DOSAGE LINE IN THE +C PATIENT'S DATA FILE, RATHER THAN THE LINE WHICH IS THE DOSE RESET +C LINE. + +c----------------------------------------------------------------------- + +c idm1x13.f 9/27/12 + +c idm1x13 has the following bug correction to idm1x12: + +C IN SUBROUTINE FUNC, BEFORE +C THE FIRST CALL TO GETFA, THE R(.) ARE SET = RS(.,.) IN CASE ANY OF +C THE FA(.) ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM +C THE R(.) VALUES IN GETFA. IN ADDITION, PRIOR TO THE 2 SECTIONS WHERE +C THE FA(.) ARE USED, GETFA IS CALLED SO THAT THE FA(.) ARE UPDATED TO +C CURRENT VALUES, BASED ON THE MOST RECENT COVARIATE VALUES IN THE +C PATIENT'S DATA FILE. IN PREVIOUS PROGRAMS, IT WAS SIMPLY ASSUMED +C THAT THE FA(.) WERE FUNCTIONS OF THE PARAMETERS, BUT NOT THE +C COVARIATES, AND SO THIS WASN'T NECESSARY. BUT THE CODE IN +C TSTMULTI.FOR IMPLIES THAT THE FA(.) COULD BE FUNCTIONS OF THE +C COVARIATES, AND SO THIS CHANGE IS NECESSARY. + +C NOTE THAT SETTING THE R(.) TO RS(.,.) BEFORE THE FIRST CALL TO +C GETFA ALSO MEANS THE R(.) WILL BE SET BEFORE GETIX AND GETTLAG ARE +C FIRST CALLED, WHICH AGAIN IS REQUIRED IN CASE THEY ESTABLISH VALUES +C AS FUNCTIONS OF THE COVARIATES IN THE PATIENT DATA FILE. + +c----------------------------------------------------------------------- + +c idm1x12.f 7/25/12 + +c idm1x12 has the following change to idm1x11: + +c In SUBROUTINE FUNC, the code to save ND0, SIGO, RSO, is moved to +c before the IF(N .EQ. 0) GO TO 75 statement. The reason is that +c before this routine returns, ND, SIG, and RS are reset back to these +c values, even if N = 0, and so they must be established at this time. + +c----------------------------------------------------------------------- + +c idm1x11.f 5/25/12 + +c idm1x11 has the following changes from idm1x10: + +C IT HAS CODE CHANGES IN SUBROUTINE PREDLAST3 TO HANDLE THE CASE WHERE +C PRED1 + PRED3 - 2*PRED2 = 0 --> PREDNEG SHOULD NOT BE CALCULATED. +C USUALLY THIS WILL HAPPEN WHEN THE MODEL/DOSAGE REGIMEN IS SO "EASY" +C TO PREDICT THAT THE 3 PREDICTED VALUES ARE VERY CLOSE TO EACH OTHER, +C AND BY "BAD LUCK" COULD BE IN A LINEAR PROGRESSION. I.E., IF +C PRED1 + DEL = PRED2, AND PRED2 + DEL = PRED3, THEN +C PRED1 + PRED3 - 2*PRED2 = 0. + +C IN THIS CASE, OF COURSE, PREDNEG SHOULD NOT BE CALCULATED SINCE THAT +C WILL RESULT IN A DIVIDE BY 0, OR A NaN IF THE PROGRAM DOES NOT STOP. + +C WHEN THIS HAPPENS (SEE CODE IN PREDLAST3), WHETHER OR NOT CONVERGENCE +C IS ACHIEVED WILL DEPEND SOLELY ON THE TOL1 CRITERION (I.E., THE TOL2 +C CRITERION CANNOT BE USED, AND IS UNNEEDED). + +C----------------------------------------------------------------------- + +c idm1x10.f 4/14/12 + +c idm1x10 has the following changes to idm1x9.f: + +c It is to be used with npageng17.f, which allows steady state doses +c to be boluses as well as IVs. As a result, an additional parameter, +c ISKIPBOL, is used so, in Subroutine FUNC, when convergence occurs in +c a steady state dose set, the last bolus from that set will not be +c reapplied below label 83. + +c----------------------------------------------------------------------- + +c idm1x9.f 3/2/12 + +c idm1x9 has the following bug fix to idm1x8.f. In Subroutine FUNC, the +c code to save ND, SIG, and RS before altering them if there are +c time lag parameters (in the call to GETTLAG) is now executed whether +c or not there are time lag parameters. The reason is that, with steady +c state doses, the first SIG(.) time in a steady state dose set is +c reset to be 0 after the steady state dose is identified. And this +c time must be reset back to be its original negative value at the end +c of the routine so that the next time the routine is called, the +c program will again know when a steady state dose is coming. + +c----------------------------------------------------------------------- + +c idm1x8.f 1/15/12 + +c Corrects bug in Subroutine FUNC - now time resets are identified +c by just the observation time = 0 (i.e., the dose time = 0 is +c no longer required). This is because it is possible for a dose +c time (especially if there are timelags) to be after the last +c observation time in a section of the patient file (before a time +c reset), and if this happens, the program will not be able to +c identify the observation time of 0 as a time reset. + +c----------------------------------------------------------------------- + +c idm1x7.f 11/21/11 + +c idm1x7 has the following changes from idm1x6: + +c 1. It can accommodate steady state dose regimens as created by +c new subroutine NEWWORK1.FOR in npageng16.f. And it has new +c Subroutine PREDLAST3 (both of these 2 new subroutines are based on +c stand-a-lone versions of the same name) which is called by +c Subroutine FUNC to predict the final (steady state) compartment +c amounts. If these predicted values are determined to have +c converged, the rest of the steady state dose set will be skipped +c to save time. Note that predictions start after the end of the +c 5th dose set (out of 100 in each steady state regimen), and +c continue until convergence is reached, or the entire steady state +c dose set has been integrated through. + +C SO THE MAIN CHANGES TO THE CODE ARE: + +C CHECK TO SEE IF A DOSE TIME IS NEGATIVE. IF NOT, PROCEED AS USUAL. IF +C SO, PROCEED AS IF THAT TIME WAS 0, BUT AFTER THE END OF THAT DOSE AND + + +C THE NEXT 4, CALL SUBROUTINE PREDLAST3 TO PREDICT THE STEADY STATE +C COMPARTMENT AMOUNTS AFTER THE 100 DOSES (NOTE THAT THE COMPARTMENT +C AMOUNTS WILL HAVE TO BE FOUND AT THE END OF EACH OF THE STEADY STATE +C DOSES OF COURSE AS THE LOGIC OF PREDLAST3 REQUIRES). IF CONVERGENCE +C IS ACHIEVED, ASSIGN THE COMPARTMENT AMOUNTS TO BE THE PREDICTED +C AMOUNTS AND SET KNS TO BE WHAT IT IS WHEN THESE STEADY STATE DOSE +C SETS HAVE FINISHED. ALSO, SET T = END OF THE STEADY STATE DOSE SET +C SINCE THAT'S WHAT IT WOULD HAVE BEEN HAD ALL THE DOSES BEEN +C INTEGRATED THROUGH. + +c 2. All arrays related to doses (SIG,SIGO,RS,RSO, and BS) in +c Subroutine FUNC have their 500's changed to 5000's. This is because +c each set of 100 steady state doses, with each of up to 7 drugs having +c its own stopping time, could require an extra 100 x 8 dose events, +c and there could be multiple steady state sets (they can occur at the +c start of the dose regimen, or at any time reset point). + +c 3. Near the top of Subroutine FUNC, R(1)=0.0D0 is replaced by setting +c R(2*I-1) = 0.D0, for I = 1,NDRUG. This should have been done when +c the program became a multi-drug program (see comment in FUNC). + +c 4. A time reset no longer requires all initial compartment amounts +c to be reset to 0. This is because a time reset no longer has to mean +c an "infinite" amount of time has occurred with no dosing; it can also +c now mean an "infinite" amount of time has occurred with unknown +c dosing. So Subroutine GETIX will be called to establish initial +c conditions for the new time period (these initial values can of +c course be 0's as was always assumed in previous programs). This is +c the situation where a patient, who previously had doses and +c observations which were recorded while he was in a lab, goes home and +c gets unknown doses over a long time period, and then returns to the +c lab to get a new set of doses and observations, starting with +c observations which establish his initial conditions for this new +c time period. + + +c----------------------------------------------------------------------- + +c idm1x6.f 12/20/10 + +c idm1x6 has the following change to idm1x5: + +c In Subroutine FUNC, it has code that calls Subroutine ANAL3, rather +c than USERANAL if N .EQ. -1. Also, the code to reset X(I),I=1,N to 0 +c where there is a time reset now includes extra code to set +c X(I),I=1,3 to 0 if N .EQ. -1. + +c Note that ANAL3, and the routines it calls are from the Little NPAG + +c program module, IDPC9A.FOR. + +c Note that this module is linked first with bigmlt11.f, and the +c template model file is TSTMULTH.FOR (in which in Subroutine SYMBOL, +c the user is told to code N=-1 if he wants to assume the standard +c 3-compartment linear model with analytic solutions, and in this +c case also establish the 5 parameters, {KE,KA,KCP,KPC,V} of this +c model). + +c----------------------------------------------------------------------- + +c idm1x5.f 4/03/10 + +c idm1x5 has a bug correction to idm1x4. In Subroutine FUNC, in the +c IF(TIM(KNT) .EQ. 0.D0 .AND. SIG(KNS) .EQ. 0.D0) block, the time, +c T, is also reset = 0 since the integration will again start from +c time 0. When this wasn't done (in idm1x4.f), the results were +c unpredictable (depending on how the DVODE integration routines +c treated a (T,TOUT) pair which decreased rather than increased. + +c----------------------------------------------------------------------- + +c idm1x4.f 11/23/09 + +c idm1x4 fixes a bug in the idm1x3 code. Label 75 is moved to in +c front of the CALL GETTLAG(TLAG) statement (see the reason in +c that part of the code). + +c----------------------------------------------------------------------- + +c idm1x3.f 9/18/09 + +c idm1x3 has the following changes from idm1x2: + +c 1. The TLAG and FA vectors, and the initial values for the X array +c will be set by calling new routines (GETTLAG, GETFA, and GETIX, +c respectively) that are part of the model file (the new template is +c TSTMULT.FOR). This means the user can now code explicit formulas +c for these values. As a result, all reference to NTLAG, IC, IFA, and +c IVOL have been removed. + +c 2. The shift subroutine will now be from the module, shift5.f, +c rather than shift4.f. + +c 3. In Subroutine USERANAL, ISTATE is no longer written out. This +c can slow the program a lot if the numerical integrator (DVODE) is +c struggling with the integrations. Instead, the total no. of calls to +c XERRWD (the routine which writes the details of the warnings) is +c written to the screen by the main "engine" module, currently +c bigmlt4.f. + +c Note that this module, along with idm2x3.f, id3x3.f, and shift5.f +c are part of the new "engine", whose main module is bigmlt4.f. + +c----------------------------------------------------------------------- + +c idm1x2.f 8/14/09 + + +c idm1x2 has the following changes from idm1x1: + +c 1. The code for setting initial compartment amounts from initial +c compartment concentrations is changed to reflect the fact that +c now IC(2) refers to the index of the covariates, not the +c column no. of RS (see comment in code). + +c 2. The code to establish the timelag parameters has changed to +c reflect that NTLAG(I) can now be negative --> in Subroutine +c SHIFT, the associated timelag parameter will now be the +c exponent of the indicated parameter (rather than the parameter +c itself). + +c 3. The code to establish the FA parameters has changed to +c reflect that IFA(I) can now be negative --> the associated FA +c parameter will now be the exponent of the indicated parameter +c (rather than the parameter itself). + + +c idm1x2.f (along with other new modules idm2x2.f and idm3x2.f) are +c still called by bigmlt2.f, but are part of the "engine" for the +c new NPBIG15B.FOR program. + +c----------------------------------------------------------------------- + +c idm1x1.f 5/27/09 + + +c idm1x1.f has the following changes from idfix5g.f: + +c 1. It allows the extra option of setting initial compartment +c amounts from their initial concentrations - see code in Subroutine +c FUNC. + +c 2. It is part of the new Big NPAG "engine", bigmlt2.f, which allows +c patient data files to have "reset" values of 0 in the dosage and +c sampling blocks. Whenever, in Subroutine FUNC, the program sees a +c SIG(.) = 0 and a TIM(.) = 0, it knows that a large enough time has +c passed since the last dose that all compartment amounts are to be +c reset = 0. Subsequent dose and observed value times are then values +c from this point. + +c 3. The first argument to Subroutine OUTPUT is changed from 0.0 to +c 0.D0 in two places. + +c This module, along with idm2x1.f and idm3x1.f are first used in the +c bigmlt2.f program. + +c----------------------------------------------------------------------- + +c idfix5g.f 5-28-02 + + +c idfix5g has the following changes from idfix5f.f: + +c It allows multiple drug inputs (rather than just one drug input). +c The changes required for this are: + +c 1. BS has dimension change from (500,3) to (500,7) +c 2. COMMON/CNST2 is changed to include NDRUG (no. of drugs) and +c NADD (no. of additional covariates), rather than NBI and NRI. +c 3. NTLAG is now a vector instead of a scalar. In particular, +C NTLAG(I) = 0 IF DRUG I'S BOLUS COL. HAS NO TIMELAG PARAMETER; +C K IF DRUG I'S BOLUS COL. HAS A TIMELAG WHOSE VALUE IS +C GIVEN BY PARAMETER NO K. +C 4. IFA, PASSED IN COMMON/FRABS FROM SUBROUTINE SYMBOL IS NOW A VECTOR +C INSTEAD OF A SCALAR. +C IFA(I) = 0 IF DRUG I WILL HAVE FA = 1.0. +C K IF DRUG I WILL HAVE AN FA WHOSE VALUE IS TO BE GIVEN +C BY PARAMETER K. +C 5. THE BOLUS COMPARTMENT NOS., NBCOMP(I), NOW COME VIA +C COMMON/BOLUSCOMP FROM SUBROUTINE SYMBOL, AND THE DIMENSION OF +C NBCOMP HAS BEEN CHANGED TO 7 (MAXIMUM OF 1 PER DRUG) FROM 20. +C 6. ALL OF THE CODE IN SUBROUTINE FUNC RELATED TO NRI AND NBI HAS BEEN +C CHANGED TO BE IN TERMS OF NI AND NDRUG. +C 7. THE CODE RELATED TO CALLING SUBROUTINE SHIFT, INCLUDING THE +C CALLING ARGUMENTS, HAS BEEN CHANGED TO REFLECT THE ABOVE CHANGES +C IN NTLAG (I.E., IT IS NOW A VECTOR RATHER THAN A SCALAR). A NEW +C MODULE, shift3.f (WHICH REPLACES shift2.f) WILL BE LINKED WITH +C THIS MODULE. + +C----------------------------------------------------------------------- + +c idfix5f.f 4-23-02 + +c idfix5f has the following changes to idfix5e: + +c 1. To enable FA to be a parameter value (either fixed or random), +c rather than always be hardcoded = 1.0, the following changes are +c implemented ... + +c The hardcoding of FA = 1.0 and the code for NBCOMP are removed +c from main. In addition, COMMON/BCOMP is removed from the entire +c module. Instead, in SUBROUTINE FUNC, a new COMMON/FRABS/IFA provides +c the value IFA which is the parameter index of the FA value (passed +c from SUBROUTINE SYMBOL) unless it = 0, in which case FA is +c set = 1.0. Also the NBCOMP compartment nos. are now set in +c SUBROUTINE FUNC. + +c 2. COMMONS /OBSER AND /SUM2 (and the arrays in them) are deleted from + +c main. They were not needed. Also, COMMON CNST2 is deleted from main +c since NBI is no longer needed here (since NBCOMP code is removed - +c see no. 1. above). + +c----------------------------------------------------------------------- + +c idfix5e.f 1-22-00 + +c idfix5e has the following changes to idfix5d: + +c It allows the initial conditions of the amounts in the compartments +c to be paramater values, rather than fixed at 0.0. These parameter +c values may be either fixed or random. + + +c To affect this enhancement, the primary change is the code in +c subroutine FUNC which sets the initial conditions based on the +c values in IC which are provided by COMMON/INITCOND from +c SUBROUTINE SYMBOL of the Fortran model file. + +c There are many other changes to simply the code (i.e., a lot of +c code was leftover code which was unused and/or confusing), namely: + +c - Commons ADAPT1, ADAPT2, LPARAM, PRED, TRANS, and PARAM are +c deleted. Variables ISW, IP, and C are deleted. +c - COMMON/PARAMD/P is now in MAIN, FUNC, and JACOB; MAIN and +c FUNCx of idcy_53e.f and idcy_63e.f; and DIFFEQ and OUTPUT of +c the Fortran model file. +c - P is redimensioned 32. It will hold only the parameters of the +c model (although some of those parameters may be initial conditions) +c and there are 20 allowable random paramaters and 12 allowable +c fixed paramaters now. +c - All the code to reverse the paramater order (using PD) and to do +c and undo square root transformations in MAIN and FUNC is removed +c (it was unneeded, and therefore confusing). In particular, all +c references to NPT, NUMYES, NUIC, NUP, NPNL, and NBOT are removed. +c - COMMON ANALYT/IDIFF is removed. IDIFF is unneeded since IDIFF = 0 +c is equivalent to N = 0, and so IDIFF code in FUNC is replaced by +c the equivalent code for N. NEQN is replaced by N. + +c - In SUBROUTINE SUMSQ, COMMON/PARAM is removed, along with PP and P. +c Setting PP(I) = P(I), I=1,NPNL made no sense since PP wasn't used + +c and NPNL was always = 0 anyway. P is removed as an argument to +c SUMSQ (it was unneeded). +c - In FUNC, the If statment at label 83 is changed to include N .EQ. 0 +c since if N = 0, setting compartment values is unnecessary. + + +c idfix5e is part of the big npem program, npbig4.f. + +c----------------------------------------------------------------------- + + SUBROUTINE IDPC(X,SUMSQJ) + +C INPUT ARE: + +C INFORMATION FROM A SUBJECT DATA FILE WHICH HAS BEEN READ IN +C PREVIOUSLY. THIS INFO IS PASSED TO THE OTHER ROUTINES IN THIS +C MODULE BY COMMONS /OBSER/, /CNST/, /CNST2/, AND /SUM2/. + + +C X(I) = ITH COORDINATE OF THE GRID POINT OF INTEREST (INCLUDING FIXED +C PARAMETER VALUES). +C STDEV(I,J) = STD DEV FOR THE ITH OBSERVATION OF THE JTH OUTPUT EQ. +C (INPUT IN BLANK COMMON TO SUBROUTINE FUNC). + +C OUTPUT IS: + +C SUMSQJ = SUM, FOR THIS SUBJECT, OVER I=1,M x NOS (ACTUALLY THE (I,J) +C CONTRIBUTION IS IGNORED IF YO(I,J) = -99 --> MISSING VALUE), OF +C ((YO(I,J)-H(I,J))/STDEV(I,J))**2, WHERE H(I,J) = PREDICTED VALUE OF THE +C JTH OUTPUT EQ AT THE ITH OBSERVATION TIME, ASSUMING THE IGTH GRID +C POINT, X. NOTE THAT M AND NOS ARE INPUT IN COMMONS SUM2 AND CNST2, +C RESPECTIVELY. + +C----------------------------------------------------------------------- + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION X(32),P(32) + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/PARAMD/ P + + +C*****INITIALIZE PROGRAM***** + + CALL SYMBOL + +C THE ABOVE CALL OBTAINS INFO FROM COMMONS. + +C FIND THE SUM OF SQUARES OF DIFFERENCES BETWEEN THE OBSERVED +C VALUES AND THE PREDICTED VALUES (NORMALIZED BY THE ASSAY +C VARIANCE OF EACH OBSERVATION) FOR THIS POINT. + +C PUT MODEL PARAMETER VALUES INTO P. + + DO I=1,NP + P(I)=X(I) + END DO + +C SUMLM RETURNS FROM SUBROUTINE SUMSQ AS THE SUM OF SQUARES +C FOR THIS SET OF (X1,X2,X3,X4,X5) VALUES. + + CALL SUMSQ(SUMLM) + + SUMSQJ=SUMLM + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE FUNC(M,F) + +C FUNCTION TO DETERMINE THE ENTRIES IN F, GIVEN P. + + IMPLICIT REAL*8(A-H,O-Z) + COMMON/BOLUSCOMP/NBCOMP + COMMON/OBSER/ TIM,SIG,RS,YO,BS + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/INPUT/ R,B + COMMON/PARAMD/ P + COMMON/CNST2/ NPL,NOS,NDRUG,NADD + COMMON/STATE/ X + COMMON STDEV + COMMON/ERROR/ERRFIL + PARAMETER(MAXNUMEQ=7) + +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. + + DIMENSION X(20),P(32),TIM(594),SIG(5000),SIGO(5000),R(37), + 1 RS(5000,34),RSO(5000,34),YT(MAXNUMEQ),YO(594,MAXNUMEQ),F(3564), + 2 BS(5000,7),Y(594,MAXNUMEQ),B(20),NBCOMP(7),STDEV(594,MAXNUMEQ), + 3 FA(7),TLAG(7),XSTORE(100,20),XPRED(20) + + CHARACTER ERRFIL*20 + +C NOTE THAT AS OF idm1x15.f, THE DIMENSIONS OF 6 IN XSTORE AND XPRED +C HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN ALL +C ALONG (I.E., THE SAME AS FOR X). + +C NOTE THAT THE 2ND DIMENSION OF STDEV AND YO IS MAXNUMEQ, WHICH +C IS SET IN THE NEW PARAMETER STATEMENT ABOVE. +C NOTE THAT THE DIMENSIONS RELATED TO THE NO. OF OUTPUT EQS. IN +C YO, YT, STDEV, AND Y ARE CHANGED TO MAXNUMEQ (FROM 6). NUMEQT COULD +C NOT BE USED BECAUSE THESE ARRAYS WERE NOT PASSED TO THIS ROUTINE AS +C DUMMY ARGUMENTS. + + +C NOTE THAT "7" IN THE ABOVE ARRAYS INDICATE THE NO. OF DRUGS ALLOWED. + +C NOTE THAT F HAS DIMENSION 3564 = 594*6 SINCE IT HAS NOS*M ENTRIES, +C THE MAX VALUE OF NOS = 6, AND THE MAX VALUE FOR M = 99*6 = 594. + +C R(7) CHANGED TO R(20) <-- No. of 'rate inputs' +C B(3) CHANGED TO B(20) <-- No. of different bolus inputs +C CHANGED X(3) TO X(20) <-- No. of compartments +C IC(10) CHANGED TO IC(20) <-- Initial conditions in compartments; +C should have been changed to 20 previously (like X,B). +C NBCOMP(10) CHANGED TO NBCOMP(20) <-- Same remarks as for IC. +C P(10) CHANGED TO P(32) <-- No. of parameters + +C*****ODE CONSTANTS AND INITIALIZATION***** + + KNS=1 + KNT=1 + +C NOTE THAT KNT IS THE RUNNING INDEX OF THE NEXT OBSERVATION TIME, +C AND KNS IS THE RUNNING INDEX OF THE NEXT DOSAGE TIME. + + T=0.0D0 + +C INITIALIZE ISKIPBOL = 0. SEE CODE BELOW. IT IS ONLY NEEDED FOR A +C STEADY STATE DOSE SET WHICH HAS BOLUS DOSES. + + ISKIPBOL = 0 + + + DO I = 1,NDRUG + R(2*I-1) = 0.D0 + END DO + +c AS OF idm1x7.f, instead of R(1) = 0, the code has been changed to +c set R(2*I-1) = 0, for I = 1,NDRUG. I.E., All IV rates for all NDRUG +c drugs are initialized to be 0 ... in case the 1st obs. time is 0, +c which means that OUTPUT is called before the R(I) are set below. + + +C CALL SUBROUTINE GETFA IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETFA IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF FA FOR EACH +C OF THE NDRUG DRUGS. + +C AS OF idm1x13.f, BEFORE CALLING GETFA, MUST SET +C THE R(.) IN CASE ANY OF THE FA(.) ARE FUNCTIONS OF THE +C COVARIATES WHICH ARE ESTABLISHED FROM THE R(.) VALUES IN +C GETFA. + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + CALL GETFA(FA) + + +C NOTE THAT NBCOMP(I),I=1,NDRUG WAS SET IN SUBROUTINE SYMBOL AND +C PASSED TO THIS ROUTINE VIA COMMON/BOLUSCOMP. + + +C As of idm1x12.f, the code to save ND0, SIGO, RSO, is moved to before +c the IF(N .EQ. 0) GO TO 75 statement. The reason is that before this +c routine returns, ND, SIG, and RS are reset back to these values, +c even if N = 0, and so they must be established at this time. + +C AS OF idm1x9.f, SAVE ND, SIG, AND RS WHETHER OR NOT NTL = 1, SINCE +C IF THERE ARE STEADY STATE DOSE SETS, THE FIRST SIG(.) VALUE IN EACH +C SET WILL BE CHANGED TO BE 0 BELOW. + + NDO = ND + DO I=1,ND + SIGO(I) = SIG(I) + DO J=1,NI + RSO(I,J) = RS(I,J) + END DO + END DO + + + +C IF N = 0, THE OUTPUT EQUATION(S) FOR Y ARE CODED EXPLICITLY INTO +C SUBROUTINE OUTPUT, AND NO D.E. SOLUTIONS (VIA USERANAL/DIFFEQ) ARE +C TO BE USED. IN THIS CASE, SKIP THE CODE REGARDING INITIAL CONDITIONS +C OF THE COMPARTMENTS, SINCE THEY ARE IRRELEVANT (I.E., THE COMPARTMENT +C AMOUNTS DON'T NEED TO BE INITIALIZED SINCE THEY WON'T BE UPDATED BY +C INTEGRATING D.E.'S). IN FACT, COULD PROBABLY SKIP TIMELAGS TOO, +C SINCE THEY CHANGE THE TIME THAT BOLUS DOSES ARE GIVEN, AND THIS +C THEORETICALLY ONLY AFFECTS COMPARTMENT AMOUNTS (WHICH ARE NOT USED +C IF N = 0), BUT JUST SKIP INITIAL CONDITIONS FOR NOW. + + IF(N .EQ. 0) GO TO 75 + + +C CALL SUBROUTINE GETIX IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETIX IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF X (THE INITIAL +C COMPARTMENT AMOUNT) FOR EACH OF THE N COMPARTMENTS. + + CALL GETIX(N,X) + + + +C CALL SUBROUTINE GETTLAG IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETTLAG IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF THE TIMELAG +C FOR EACH OF THE NDRUG DRUGS. + + + 75 CALL GETTLAG(TLAG) + +C IF ANY TLAG(.) VALUES RETURN AS .NE. 0, THEN, CALL SUBROUTINE SHIFT +C TO ADJUST THE DOSAGE REGIMEN APPROPRIATELY. + + NTL = 0 + DO ID = 1,NDRUG + IF(TLAG(ID) .NE. 0) NTL = 1 + END DO + + IF(NTL .EQ. 1) THEN + +C STORE INCOMING VALUES IN ND, SIG, AND RS (WHICH CONTAINS BS VALUES) +C SINCE THEY WILL BE CHANGED IN THE CALL TO SUBROUTINE SHIFT, WHICH +C "SHIFTS" THE DOSAGE REGIMEN MATRIX TO ACCOUNT FOR THE TIMELAG +C PARAMETER(S), TLAG(I). AT THE END OF THIS ROUTINE, THE VALUES IN ND, +C SIG, AND RS WILL BE RESET TO THEIR INCOMING VALUES - TO BE READY FOR +C THE NEXT CALL TO THIS ROUTINE WITH POSSIBLY DIFFERENT VALUES FOR +C TLAG(I). + + + CALL SHIFT(TLAG,ND,SIG,NDRUG,NADD,RS) + + +C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NTL .EQ. 1) CONDITION. + + IF(TIM(KNT).GE.SIG(KNS)) GO TO 12 + IF(TIM(KNT).NE.0.0D0) GO TO 45 + +C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) +C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. + + CALL OUTPUT(0.D0,YT) + DO 2000 I=1,NOS +2000 Y(KNT,I)=YT(I) + KNT=KNT+1 + GO TO 45 + +12 IF(TIM(KNT).GT.SIG(KNS)) GO TO 13 + IF(TIM(KNT).NE.0.0D0) GO TO 45 + +C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) +C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. + + CALL OUTPUT(0.D0,YT) + DO 2005 I=1,NOS +2005 Y(KNT,I)=YT(I) + KNT=KNT+1 + +13 IF(SIG(KNS) .GT. 0.0D0) GO TO 45 + +C CHECK TO SEE IF SIG(KNS) < 0. IF SO, IT MEANS THAT 100 STEADY STATE +C DOSES SHOULD NOW BE APPLIED WITH AN INTERDOSE INTERVAL EQUAL TO +C -SIG(KNS). + + ISTEADY = 0 + + IF(SIG(KNS) .LT. 0.D0) THEN + + + + + ISTEADY = 1 + NSET = 1 + +C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE +C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 +C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... +C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. +C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE +C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE +C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE +C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC +C OF PREDLAST3 REQUIRES). + + +C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT +C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS +C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF +C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE +C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. + +C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF +C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL +C INTEGRATED THROUGH, WHICHEVER COMES FIRST. + + DOSEINT = -SIG(KNS) + +C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START +C OF 100 DOSE SETS THAT BEGIN AT TIME 0. + + + SIG(KNS) = 0 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. + + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + IF(NDRUG .EQ. 0) GO TO 81 + +C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT +C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED +C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. + + CALL GETFA(FA) + + + IF(N .EQ. 0) GO TO 120 + + DO I=1,NDRUG + X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS,I)*FA(I) + END DO + +C NOTE THAT FA(I) IS THE FRACTION OF DRUG AVAILABLE FROM A BOLUS INPUT +C FOR DRUG I INTO ITS ABSORPTIVE COMPARTMENT. + + GO TO 81 + +120 DO I=1,NDRUG + B(I)=BS(KNS,I)*FA(I) + END DO + +81 KNS = KNS+1 + + +C*****INTEGRATION OF EQUATIONS***** + + +C DETERMINE IF, OBSER(ID=0), OR DOSE(ID=1), OR BOTH(ID=2). + +45 IF(KNS .GT. ND) GO TO 15 + + +C CODE CHANGE BELOW FOR idm1x8.f. + + IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) THEN + +C AS OF idm1x7.f, A TIME RESET NO LONGER REQUIRES ALL INITIAL +C COMPARTMENT AMOUNTS TO BE RESET TO 0. THIS IS BECAUSE A TIME RESET +C NO LONGER HAS TO MEAN THAT AN "INFINITE" AMOUNT OF TIME HAS OCCURRED +C WITH NO DOSING; IT CAN ALSO NOW MEAN THAT AN "INFINITE" AMOUNT OF +C TIME HAS OCCURRED WITH UNKNOWN DOSING (IN THIS CASE, SUBROUTINE +C GETIX WILL BE CALLED BELOW TO ESTABLISH INITIAL CONDITIONS FOR THIS +C TIME PERIOD). + +C ADVANCE KNS TO THE NEXT VALUE THAT HAS SIG(KNS) .LE. 0. I.E., ONCE +C TIMN(KNT) = 0, IT MEANS THAT WE ARE DONE WITH THE OUTPUT OBS. +C TIMES IN THE PREVIOUS SECTION --> THERE IS NO POINT IN CONTINUING +C TO INTEGRATE TILL THE END OF THE DOSES IN THE PREVIOUS SECTION +C (IF THERE ARE ANY). + + DO IKNS = KNS,ND + IF(SIG(IKNS) .LE. 0.D0) GO TO 110 + END DO + +C TO GET HERE MEANS THAT NO VALUE IN SIG(.) FROM KNS TO ND HAS A +C VALUE .LE. 0, AND THIS IS AN ERROR. IT MEANS THAT THE PATIENT DATA +C FILE HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING +C DOSE RESET ROW. TELL THE USER AND STOP. + + WRITE(*,111) ND,KNS,SIG(KNS) +111 FORMAT(//' IN SUBROUTINE FUNC, THE CURRENT SUBJECT HAS AN'/ + 1' OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE'/ + 2' RESET ROW. THE PROGRAM NOW STOPS. '// + 3' REVIEW YOUR PATIENT FILES AND CORRECT THE ERROR.'// + 4' NOTE THAT THE ',I4,' DOSE TIMES (POSSIBLY ALTERED BY TIMELAGS'/ + 5' ARE THE FOLLOWING (AND THERE IS NO TIME .LE. 0 AFTER TIME'/ + 6' NO. ',I4,' WHICH HAS CORRESPONDING TIME ',F15.4,'):') + + + DO I = 1,ND + WRITE(*,*) SIG(I) + END DO + + OPEN(47,FILE=ERRFIL) + WRITE(47,111) ND,KNS,SIG(KNS) + DO I = 1,ND + WRITE(47,*) SIG(I) + END DO + CLOSE(47) + + CALL PAUSE + STOP + + + 110 KNS = IKNS + + +C THERE ARE TWO POSSIBILITES AT THIS POINT, EITHER SIG(KNS) = 0 +C OR SIG(KNS) < 0. + +C IF SIG(KNS) = 0, THIS REPRESENTS A TIME RESET (T WILL BE SET = 0 +C BELOW) WITH A SINGLE DOSE LINE TO START. IN THIS CASE, CALL GETIX +C AGAIN (JUST AS WAS DONE NEAR THE TOP OF THIS ROUTINE) TO OBTAIN +C INITIAL COMPARTMENT AMOUNTS. NOTE THAT BY DEFAULT, IN GETIX, ALL +C COMPARTMENT AMOUNTS ARE SET = 0 (WHICH WOULD BE THE CASE IF IN THE +C LONG TIME PERIOD BETWEEN THE LAST SET OF DOSES AND THIS NEW +C BEGINNING, NO DOSES HAVE BEEN GIVEN). BUT THE USER MAY ALSO HAVE +C CODED INTO GETIX EQUATIONS THAT SET ONE OR MORE OF THE X(I) TO +C FUNCTIONS OF COVARIATE AND PARAMETER VALUES (WHICH WOULD BE THE +C SITUATION IF AN UNKNOWN DOSING REGIMEN HAS TAKEN PLACE BUT IT +C DOESN'T MATTER WHAT IT WAS BECAUSE THE PATIENT COMES TO A LAB AND +C SIMPLY HAS HIS COMPARTMENT VALUES ESTABLISHED BEFORE CONTINUING +C WITH THE OTHER VALUES IN HIS PATIENT FILE). + +C IF SIG(KNS) < 0, THIS REPRESENTS A TIME RESET WITH A STEADY STATE +C SET OF 100 DOSES ABOUT TO BEGIN. IN THIS CASE, WE ASSUME THAT THE +C PATIENT IS ABOUT TO GET 100 SETS OF DOSES SO THAT HIS COMPARTMENT +C AMOUNTS WILL ACHIEVE STEADY STATE VALUES. THESE STEADY STATE VALUES +C WILL BE ESTIMATED IN THE BLOCK OF CODE BELOW THAT STARTS WITH +C IF(ISTEADY .EQ. 1). IN THIS CASE, WE WILL STILL CALL GETIX TO +C MAKE SURE THAT ANY RESIDUAL COMPARTMENT AMOUNTS FROM A PREVIOUS +C SET OF DOSES IS ZEROED OUT (OR SET = VALUES AS DETERMINED BY +C SUBROUTINE GETIX). + +C AS OF idm1x14.f, BEFORE CALLING GETIX, MUST SET +C THE R(.) IN CASE ANY OF THE INITIAL CONDITIONS FOR THE X(.) +C ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM THE +C R(.) VALUES IN GETFA. + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + + + CALL GETIX(N,X) + +C MUST ALSO RESET T = 0 SINCE THE INTEGRATION WILL AGAIN START FROM +C TIME 0. + + T = 0.D0 + +C IF SIG(KNS) .LT. 0, THIS IS NOT ONLY A TIME RESET, IT IS THE +C BEGINNING OF A STEADY STATE DOSE SET. IN THIS CASE, APPLY 100 +C STEADY STATE DOSES WITH AN INTERDOSE INTERVAL EQUAL TO -SIG(KNS). + + ISTEADY = 0 + + IF(SIG(KNS) .LT. 0.D0) THEN + + ISTEADY = 1 + NSET = 1 + +C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE +C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 +C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... +C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. +C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE +C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE + +C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE +C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC +C OF PREDLAST3 REQUIRES). + + +C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT +C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS +C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF +C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE +C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. + +C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF +C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL +C INTEGRATED THROUGH, WHICHEVER COMES FIRST. + + DOSEINT = -SIG(KNS) + +C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START +C OF 100 DOSE SETS THAT BEGIN AT TIME 0. + + SIG(KNS) = 0 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) CONDITION. + + + + IF(TIM(KNT) .NE. SIG(KNS)) GO TO 20 + ID=2 + TOUT=TIM(KNT) + KNT=KNT+1 + KNS=KNS+1 + + IF(N .EQ. 0) GO TO 31 + GO TO 30 + +20 IF(TIM(KNT) .GT. SIG(KNS) .AND. SIG(KNS) .GT. 0) GO TO 25 + + +15 ID=0 + TOUT=TIM(KNT) + KNT=KNT+1 + IF(N .EQ. 0) GO TO 31 + GO TO 30 + +25 ID=1 + TOUT=SIG(KNS) + KNS=KNS+1 + IF(N .EQ. 0) GO TO 31 + +30 CONTINUE +32 IF(N .NE. -1) CALL USERANAL(X,T,TOUT) + IF(N .EQ. -1) CALL ANAL3(X,T,TOUT) + + +C IF ISTEADY = 1, THIS IS INSIDE A STEADY STATE DOSE SET. CHECK TO SEE +C IF TOUT IS A MULTIPLE OF DOSEINT. IF SO, RECORD THE COMPARTMENT +C AMOUNTS. THEN, AFTER COMPARTMENT AMOUNTS HAVE BEEN STORED FOR AT +C LEAST THE 1ST 5 MULTIPLES OF DOSEINT, STOP AND CALL SUBROUTINE +C PREDLAST3 WHICH PREDICTS THE FINAL (STEADY STATE) COMPARTMENT AMOUNTS +C AFTER THE LAST (100TH) DOSE SET. + +C IF PREDLAST3 HAS PREDICTED VALUES WHICH "CONVERGE", ASSIGN THE +C PREDICTED VALUES TO X, INCREASE KNS TO BE THE INDEX OF THE FIRST DOSE +C EVENT WHICH OCCURS AFTER THE STEADY STATE DOSE SET ENDS AND CONTINUE. + +C IF PREDLAST3 VALUES DON'T CONVERGE, CONTINUE THE PROCESS WITH +C COMPARTMENT AMOUNTS FOR MULTIPLES 2 - 6 OF DOSEINT, TEST FOR +C "CONVERGENCE", ETC. THIS PROCESS CONTINUES UNTIL "CONVERGENCE" IS +C ACHIEVED FOR A SET OF 5 COMPARTMENT AMOUNTS (OR SETS OF AMOUNTS IF +C NDRUG IS > 1), OR UNTIL ALL 100 DOSE SETS IN THE STEADY STATE REGIMEN +C HAVE FINISHED. + + IF(ISTEADY .EQ. 1) THEN + + +C THE NEXT DOSE SET END TIME IS DOSEINT*NSET. IF TOUT = DOSEINT*NSET, +C STORE THE COMPARTMENT AMOUNTS. IF NSET .GE. 5, CALL PREDLAST3 AND +C PROCEED AS INDICATED ABOVE. + + CALL THESAME(TOUT,DOSEINT*NSET,ISAME) + + IF(ISAME .EQ. 1) THEN + + NN = N + IF(N .EQ. -1) NN = 3 + + DO J = 1,NN + XSTORE(NSET,J) = X(J) + END DO + + + IF(NSET .GE. 5) THEN + + CALL PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) + + + IF(ICONV .EQ. 1) THEN + +C SINCE THE PREDICTED VALUES ARE CONSIDERED ACCURATE (I.E., +C "CONVERGENCE WAS ACHIEVED IN PREDLAST), RESET ISTEADY TO 0, +C WHICH MEANS THAT THE STEADY STATE DOSES ARE FINISHED; ASSIGN THE +C COMPARTMENT AMOUNTS TO BE THE PREDICTED VALUES; AND SET KNS TO THE +C FIRST DOSE EVENT AFTER THE END OF THE STEADY STATE DOSE SET. ALSO, +C SET T = THE ENDING TIME OF THE STEADY STATE DOSE SET = 100*DOSEINT, +C SINCE THAT IS WHAT IT WOULD HAVE BEEN HAD ALL 100 DOSE SETS BEEN +C RUN. + + ISTEADY = 0 + + DO J = 1,NN + X(J) = XPRED(J) + END DO + + T = 100.D0*DOSEINT + + +C ADVANCE KNS TO BE THE FIRST DOSE PAST THE 100 DOSE SETS IN THIS +C STEADY STATE SET. NOTE THAT THIS SET ENDS BEFORE 100*DOSEINT, SO +C FIND THE FIRST SIG(.) THAT IS .GE. 100*DOSEINT, OR THAT IS = 0 +C (WHICH SIGNIFIES A TIME RESET) OR THAT IS < 0 (WHICH SIGNIFIES +C ANOTHER STEADY STATE SET). + + DO I = KNS,ND + IF(SIG(I) .GE. 100.D0*DOSEINT .OR. SIG(I) .LE. 0.D0) THEN + KNSNEW = I + GO TO 100 + ENDIF + END DO + +C TO GET HERE MEANS THAT THERE ARE NO DOSE TIMES PAST THE END OF THIS +C STEADY STATE DOSE SET. IN THIS CASE, SET KNS TO ND+1. + + KNS = ND+1 + GO TO 200 + + 100 KNS = KNSNEW + 200 CONTINUE + + +C SET ISKIPBOL = 1 WHENEVER CONVERGENCE OCCURS IN +C THE STEADY STATE DOSES SINCE IN THIS CASE, WE DON'T WANT TO +C REAPPLY THE LAST BOLUS FROM THE STEADY STATE SET BELOW LABEL 83. + + ISKIPBOL = 1 + + ENDIF + + +C THE ABOVE ENDIF IS FOR THE IF(ICONV .EQ. 1) CONDITION. + +C IF ICONV = 0, ISTEADY IS STILL = 1, +C WHICH MEANS THAT THE ATTEMPT TO PREDICT THE FINAL (STEADY STATE) +C COMPARTMENT AMOUNTS CONTINUES. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NSET .GE. 5) CONDITION. + +C SINCE ISAME = 1, THE END OF THE SET NO. NSET HAS OCCURRED --> +C INCREASE NSET BY 1. + + + NSET = NSET + 1 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISTEADY .EQ. 1) CONDITION. + + + +31 CONTINUE + +C RECORD OBSERVATION AND SUPPLY NEW DOSE + + IF(ID .EQ. 1) GO TO 35 + KNTM1=KNT-1 + +C NOTE THAT THE TIME AT WHICH THE OUTPUT IS DESIRED IS TIM(KNTM1); THIS +C IS CLEAR SINCE THE RETURNING VALUE(S) IN YT ARE PUT INTO ROW NO. +C KNTM1 OF Y. + + CALL OUTPUT(TIM(KNTM1),YT) + + DO 2010 I=1,NOS +2010 Y(KNTM1,I)=YT(I) + +55 IF(ID.EQ.0) GO TO 40 + + 35 CONTINUE + + IF(NI .EQ. 0) GO TO 83 + + DO I=1,NI + R(I)=RS(KNS-1,I) + END DO + +C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT +C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED +C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. + + CALL GETFA(FA) + + +83 IF(NDRUG .EQ. 0 .OR. N .EQ. 0) GO TO 82 + +C ADDING N .EQ. 0 TO ABOVE IF STATEMENT SHOWS CLEARLY THAT IF +C N = 0 (IN WHICH CASE ANALYTIC SOLUTIONS ARE CODED DIRECTLY INTO +C SUBROUTINE OUTPUT, WHICH MAKES THE COMPARTMENT AMOUNTS IRRELEVANT) +C SETTING VALUES FOR THE COMPARTMENTS, X, IS UNNECESSARY. + + +C IF ISKIPBOL = 1, DO NOT APPLY BOLUSES FROM DOSE KNS-1, SINCE THESE +C BOLUSES WERE PART OF THE STEADY STATE DOSE SET WHICH ALREADY HAD +C BOLUSES (EFFECTIVELY) APPLIED ABOVE WHERE "CONVERGENCE" OF THE +C STEADY STATE DOSE SET WAS OBTAINED. + + IF(ISKIPBOL .EQ. 0) THEN + DO I=1,NDRUG + X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS-1,I)*FA(I) + END DO + ENDIF + +C RESET ISKIPBOL = 0 HERE. IF IT IS NOW = 1, IT MEANS THAT +C THE ABOVE APPLICATION OF BOLUSES WAS SKIPPED SINCE THERE HAS JUST +C BEEN A STEADY STATE SET OF DOSES WHICH CONVERGED (AND WE DON'T +C WANT THE LAST BOLUS DOSE REAPPLIED). BUT, GOING FORWARD, ISKIPBOL +C SHOULD BE SET AGAIN TO 0 SO THE ABOVE APPLICATION OF BOLUSES WILL +C OCCUR WHENEVER THERE IS A NEW BOLUS TO BE APPLIED. + + ISKIPBOL = 0 + + +82 CONTINUE + +C CHECK STOPPING TIME. + + +40 IF(KNT .LE. M) GO TO 45 + +C*****DETERMINE F(I)***** + +C NOTE THAT IF YO(I,J) = -99 --> THIS OBSERVED LEVEL IS MISSING. +C IN THIS CASE, SET THE CORRESPONDING VALUE OF F = 0. + + DO J=1,NOS + DO I=1,M + IF(YO(I,J) .EQ. -99) F((J-1)*M+I) = 0.D0 + IF(YO(I,J) .NE. -99) F((J-1)*M+I) =(Y(I,J)-YO(I,J))/STDEV(I,J) + END DO + END DO + + +C AS OF idm1x9.f, RESTORE THE VALUES FOR ND, SIG, AND RS, IN CASE +C THIS MODEL HAS TIME LAGS OR STEADY STATE DOSES - TO BE READY FOR THE +C NEXT CALL TO THIS ROUTINE. + + ND = NDO + DO I=1,ND + SIG(I) = SIGO(I) + DO J=1,NI + RS(I,J) = RSO(I,J) + END DO + END DO + +C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE SUMSQ(SSQ) + +C SUBROUTINE TO EVALUATE THE SUM OF SQUARES OF THE RESIDUAL VECTOR. + + IMPLICIT REAL*8(A-H,O-Z) + COMMON/SUM2/ M,NPNL + COMMON/CNST2/ NPL,NOS,NDRUG,NADD + DIMENSION F(3564) + +C NOTE THAT F HAS DIMENSION 3564 = 594*6 SINCE IT HAS NOS*M ENTRIES, +C THE MAX VALUE OF NOS = 6, AND THE MAX VALUE FOR M = 99*6 = 594. + + + CALL FUNC(M,F) + SSQ=0.0D0 + NUMRES=M*NOS + DO 10 I=1,NUMRES +10 SSQ=SSQ+F(I)*F(I) + RETURN + + END +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE USERANAL(X,TIN,TOUT) + +C PURPOSE: +C GIVEN X(TIN) THE PROGRAM CALCULATES X(TOUT), WHERE X IS THE +C STATE VECTOR FOR THE MODEL UNDER CONSIDERATION (AS DEFINED +C BY THE D.E'S IN SUBROUTINE DIFFEQ). THESE D.E'S ARE SOLVED +C USING THE LINPACK ROUTINE, VODE.FOR (AND ASSOCIATED ROUTINES). + +C THIS ROUTINE CALLS SUBROUTINE DVODE (VODE.FOR) ONCE FOR EACH +C POINT AT WHICH ANSWERS ARE DESIRED. NOTE THAT DVODE WILL CALL +C SUBROUTINE DIFFEQ (SUPPLIED BY THE USER -- IT GIVES THE +C DIFF. EQS. OF THE MODEL, XP(I)) AND, IF THE USER DESIRES, +C SUBROUTINE JACOB (SUPPLIED BY THE USER -- IT GIVES THE +C JACOBIAN OF PARTIAL DERIVATIVES, dXP(I)/dX(J)). SUBROUTINES +C DIFFEQ AND JACOB ARE IN THIS MODULE. + +C ARGUMENTS ON INPUT: +C X - AN ARRAY OF DIMENSION 20. IN THE STANDARD 3-COMPARTMENT +C MODEL, X(1), X(2), X(3) SHOULD +C BE SET TO THE AMOUNT OF DRUG IN THE ABSORBTION, +C CENTRAL, AND PERIPHERAL COMPARTMENTS, RESPECTIVELY, +C AT TIME T=TIN. +C TIN - CURRENT VALUE OF TIME. +C TOUT - TIME AT WHICH SOLUTION IS DESIRED. + +C VALUES FROM COMMON/TOUSER (FROM MXEM2__/MAIN) WHICH WERE INPUT +C REAL-TIME BY THE USER (SEE DETAILS BELOW). +C NDIM = NO. OF STATES IN MODEL (.LE. 3 FOR NOW). +C MF = METHOD FLAG. +C RTOL = SCALAR RELATIVE TOLERANCE PARAMETER. +C ATOL(I), I=1,NDIM = ABSOLUTE TOLERANCE PARAMETERS. + +C ARGUMENTS ON OUTPUT: +C X - THE COMPARTMENT AMOUNTS AT T=TOUT. +C TIN - SET AT TOUT + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION X(20),ATOL(20),RWORK(300),IWORK(40) + + EXTERNAL DIFFEQ,JACOB + COMMON/TOUSER/NDIM,MF,RTOL,ATOL + +C THE LOGIC OF THIS CODE IS TAKEN FROM PROGRAM DESOLV3.FOR (4/28/96). + +C FOLLOWING VALUES ARE SUPPLIED TO SUBROUTINE DVODE: + +C DIFFEQ = NAME OF SUBROUTINE COMPLETED BY USER WHICH GIVES THE D.E.'S +C OF THE MODEL. IT MUST BE DECLARED EXTERNAL. +C TIN = The initial value of the independent variable. + +C TOUT = First point where output is desired (.ne. TIN). +C ITOL = 2 SINCE ATOL IS AN ARRAY. +C RTOL = Relative tolerance parameter (scalar). +C ATOL = Absolute tolerance parameter. +C The estimated local error in X(i) will be controlled so as +C to be roughly less (in magnitude) than +C EWT(i) = RTOL*abs(X(i)) + ATOL(i) SINCE ITOL = 2. +C Thus the local error test passes if, in each component, +C either the absolute error is less than ATOL (or ATOL(i)), +C or the relative error is less than RTOL. +C Use RTOL = 0.0 for pure absolute error control, and +C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error +C control. Caution.. Actual (global) errors may exceed these +C local tolerances, so choose them conservatively. +C ITASK = 1 for normal computation of output values of X at t = TOUT. +C ISTATE = Integer flag (input and output). Set ISTATE = 1. +C IOPT = 0 to indicate no optional input used. +C RWORK = Real work array of length at least.. +C 20 + 16*NDIM for MF = 10, +C 22 + 9*NDIM + 2*NDIM**2 for MF = 21 or 22, +C 22 + 11*NDIM + (3*ML + 2*MU)*NDIM for MF = 24 or 25. +C ... I'LL USE AN ARRAY OF 300 (PLENTY FOR NDIM .LE. 8). +C LRW = Declared length of RWORK (in user's DIMENSION statement). +C IWORK = Integer work array of length at least.. +C 30 for MF = 10, +C 30 + NDIM for MF = 21, 22, 24, or 25. +C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower +C and upper half-bandwidths ML,MU. +C ... I'LL USE AN ARRAY OF 40 (PLENTY FOR NDIM .LE. 8). +C LIW = Declared length of IWORK (in user's DIMENSION). +C JACOB = Name of subroutine COMPLETED BY USER for Jacobian matrix +C (MF = 21 or 24). If used, this name must be declared +C external. If not used, pass a dummy name. +C MF = Method flag. Standard values are.. +C 10 for nonstiff (Adams) method, no Jacobian used. +C 21 for stiff (BDF) method, user-supplied full Jacobian. +C 22 for stiff method, internally generated full Jacobian. + +C 24 for stiff method, user-supplied banded Jacobian. +C 25 for stiff method, internally generated banded Jacobian. +C RPAR,IPAR = user-defined real and integer SCALARS OR arrays passed to +C DIFFEQ AND JACOB. + +C Note that the main program must declare arrays X, RWORK, IWORK, +C and possibly ATOL, RPAR, and IPAR. + + +C THE FOLLOWING VALUES RETURN FROM CALLS TO SUBROUTINE DVODE. + +C X = Array of computed values of X vector (AT TIME TOUT). +C T = Corresponding value of independent variable (normally TOUT). +C ISTATE = 2 if DVODE was successful, negative otherwise. +C -1 means excess work done on this call. (Perhaps wrong MF.) +C -2 means excess accuracy requested. (Tolerances too small.) +C -3 means illegal input detected. (See printed message.) +C -4 means repeated error test failures. (Check all input.) +C -5 means repeated convergence failures. (Perhaps bad +C Jacobian supplied or wrong choice of MF or tolerances.) +C -6 means error weight became zero during problem. (Solution +C component i vanished, and ATOL or ATOL(i) = 0.) + + ITOL=2 + ITASK=1 + ISTATE=1 + IOPT=0 + LRW=300 + LIW=40 + + CALL DVODE(DIFFEQ,NDIM,X,TIN,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, + 1 IOPT,RWORK,LRW,IWORK,LIW,JACOB,MF,RPAR,IPAR) + +c IF (ISTATE .LT. 0) THEN +c WRITE(*,16) ISTATE +c 16 FORMAT(///' On return from DVODE, ISTATE =',I3) +c ENDIF + + + TIN=TOUT + + + + RETURN + END +C + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE JACOB(NDIM, T, X, ML, MU, PD, NRPD, RPAR, IPAR) + + IMPLICIT REAL*8(A-H,O-Z) + COMMON/PARAMD/ P + COMMON/INPUT/ R,B + DIMENSION X(NDIM), PD(NRPD,NDIM), P(32),R(37),B(20) + +C THIS ROUTINE IS CALLED BY LINPACK ROUTINE DVODE (WHICH IS CALLED +C BY ROUTINE USERANAL). THE USER CODES THE JACOBIAN MATRIX CALCULATIONS +C OF THE MODEL (I.E., THE PARTIAL DERIVATIVES OF XP(I) W.R.T. X(I), +C WHERE XP(I) WERE CODED INTO ROUTINE DIFFEQ). + + +C SINCE THIS ROUTINE CAN'T BE MADE BY THE 'BOXES' PROGRAM AT THIS TIME, +C IT WILL NOT BE USED. IT IS JUST A DUMMY ROUTINE, NEEDED BECAUSE +C DVODE EXPECTS TO 'SEE' IT. + +C INPUT ARE: + +C NDIM = NO. OF STATES (DIMENSION OF PROBLEM). + +C T = CURRENT TIME. +C X(I) = VALUE OF STATE I AT T, I=1,NDIM. +C [ML,MU] = HALF BANDWIDTH PARAMETERS ... UNNEEDED IF MF = 21 OR 22 +C --> FULL JACOBIAN IS PROVIDED BY USER BELOW (SEE +C DESOLV3.FOR CODE FOR DETAILS). +C NOTE THAT SINCE MF = 21 OR 22 IN THIS CASE, NRPD = NDIM. +C R AND B VIA COMMON/INPUT. + + +C OUTPUT ARE: + + +C PD(I,J) = PARTIAL DERIVATIVE OF XP(I) W.R.T. X(J), WHERE XP(I) +C ARE CALCULATED IN ROUTINE DIFFEQ ABOVE. + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION XSTORE(100,20),XPRED(20),COMP(5,20) + +C NOTE THAT AS OF idm1x15.f, THE DIMENSIONS OF 6 IN XSTORE, XPRED, +C AND COMP HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN +C ALL ALONG (SEE SUBROUTINE FUNC). + + +C THIS SUBROUTINE IS CALLED BY SUBROUTINE FUNC WITH NSET SETS OF NN +C COMPARTMENT VALUES IN XSTORE. USE THE LAST 5 SETS OF VALUES TO +C PREDICT THE FINAL (STEADY STATE) COMPARTMENT AMOUNTS AFTER THE LAST +C (100TH) DOSE SET. + +C IF THESE VALUES "CONVERGE", SET ICONV = 1, AND WRITE THE PREDICTED +C VALUES INTO XPRED. IF THEY DON'T CONVERGE, SET ICONV = 0. + +C TOL1 AND TOL2 ARE, FOR NOW, HARDCODED TO BE .0005. + + TOL1 = .0005D0 + TOL2 = .0005D0 + + +C THE LAST 5 SETS OF VALUES ARE IN XSTORE(NSET-4:NSET,.). PUT THESE +C VALUES INTO COMP(.,.). + + II = 0 + + DO I = NSET-4,NSET + II = II+1 + DO J = 1,NN + COMP(II,J) = XSTORE(I,J) + END DO + END DO + + +C FOR EACH COMPARTMENT AMOUNT, SEE IF THE FINAL STEADY STATE COMP. +C AMOUNT CAN BE PREDICTED ACCURATELY. + + DO IN = 1,NN + + A1 = COMP(1,IN) + A2 = COMP(2,IN) + A3 = COMP(3,IN) + DEL1 = A2 - A1 + DEL2 = A3 - A2 + +C TEST FOR DEL1 = 0. IF SO, SEE ISAMETOT BELOW. + + CALL THESAME(DEL1,0.D0,ISAME1) + + IF(ISAME1 .EQ. 0) THEN + + F = DEL2/DEL1 + +C THE UNDERLYING ASSUMPTION IS THAT THE RATIO F = DEL2/DEL1 +C IS CONTANT BETWEEN CONSECUTIVE OUTPUT DIFFERENCES. IF SO, THEN +C THE STEADY STATE VALUE WILL BE A1 + DEL1/(1 - F) (SEE SS.EXP +C IN \ALAN3\STEADYSTATE). CALCULATE THIS VALUE AND CALL IT PRED1. + +C BUT, IF DEL2 = DEL1, THEN F = 1. IN THIS CASE, CAN'T DO THE FOLLOWING +C CALCULATION FOR PRED1, AND WE WOULDN'T WANT TO DO IT SINCE +C DEL2 = DEL1 --> A2 - A1 = A3 - A2 --> A1, A2, AND A3 ARE IN AN +C ARITHMETIC PROGRESSION --> THERE OBVIOUSLY CAN BE NO CONVERGENCE +C SINCE, AFTER 100 DOSES, THE VALUE WOULD JUST A1 + 99*DEL1 ... +C UNLESS DEL1 = 0, IN WHICH CASE THE VALUE WOULD CONVERGE TO A1. +C IN THIS CASE SET ISAMEF1 = 1, AND SKIP CALC. OF PRED1. AND THEN +C SEE THE LOGIC RELATED TO ISAMEF1 BELOW. + + + + CALL THESAME(F,1.0,ISAMEF1) + IF(ISAMEF1 .EQ. 0) PRED1 = A1 + DEL1/(1.D0 - F) + + ENDIF + + +C SIMILARLY, CALCULATE PRED2 (BASED ON (A2,A3,A4)) AND PRED3 (BASED +C ON (A3,A4,A5). + + A1 = COMP(2,IN) + + A2 = COMP(3,IN) + A3 = COMP(4,IN) + DEL1 = A2 - A1 + DEL2 = A3 - A2 + +C TEST FOR DEL1 = 0. IF SO, SEE ISAMETOT BELOW. + + CALL THESAME(DEL1,0.D0,ISAME2) + + IF(ISAME2 .EQ. 0) THEN + F = DEL2/DEL1 + + + CALL THESAME(F,1.0,ISAMEF2) + IF(ISAMEF2 .EQ. 0) PRED2 = A1 + DEL1/(1.D0 - F) + + ENDIF + + A1 = COMP(3,IN) + A2 = COMP(4,IN) + A3 = COMP(5,IN) + DEL1 = A2 - A1 + DEL2 = A3 - A2 + +C TEST FOR DEL1 = 0. IF SO, SEE ISAMETOT BELOW. + + CALL THESAME(DEL1,0.D0,ISAME3) + + IF(ISAME3 .EQ. 0) THEN + F = DEL2/DEL1 + + + CALL THESAME(F,1.0,ISAMEF3) + IF(ISAMEF3 .EQ. 0) PRED3 = A1 + DEL1/(1.D0 - F) + ENDIF + + +C ASSUMING A NEGATIVE EXPONENTIAL PATTERN FIT (SEE SS.EXP IN +C \ALAN3\STEADYSTATE OR HOME NOTES, PG.2 ON 9/11/11 FOR DETAILS) ON +C (PRED1,PRED2,PRED3), CALCULATE PREDNEG. + +C BUT ONLY DO THIS CALCULATION, AND THE SUBSEQUENT +C CONVERGENCE DETERMINATION IF ISAME1 = ISAME2 = ISAME3 = 0, AND +C ISAMEF1 = ISAMEF2 = ISAMEF3 = 0. OTHERWISE, AT LEAST ONE OF THE +C PREDICTED VALUES ABOVE WAS NOT CALCULATED. + + ISAMETOT = ISAME1 + ISAME2 + ISAME3 + ISAMEFTOT = ISAMEF1 + ISAMEF2 + ISAMEF3 + + + IF(ISAMETOT .EQ. 0 .AND. ISAMEFTOT .EQ. 0) THEN + +C EDITED CODE BELOW FOR idm1x11.f. + +C IF PRED1 + PRED3 - 2*PRED2 = 0, PREDNEG (SEE BELOW) CANNOT BE +C CALCULATED. IN THIS CASE, PRED2 - PRED1 = PRED3 - PRED2 --> +C THE SEQUENCE (PRED1, PRED2, PRED3) IS LINEAR, WHICH CANNOT BE +C MODELED WITH AN EXPONENTIAL FIT (SEE COMMENTS ABOVE). SO, IF THIS +C HAPPENS, CONVERGENCE WILL BE SATISFIED IF THESE 3 VALUES ARE +C VIRTUALLY THE SAME - I.E., ONLY THE REQUIREMENT INVOLVING TOL1 +C WILL BE NEEDED FOR CONVERGENCE (RECALL THE ONLY REASON FOR THE +C EXTRA NEGATIVE EXPONENTIAL FIT, AND THE CALCULATION OF PREDNEG IS FOR +C THOSE CASES WHERE PRED1, PRED2, AND PRED3 ARE NOT ALL VIRTUALLY THE +C SAME VALUE). + + DEN = PRED1+PRED3-2.D0*PRED2 + CALL THESAME(DEN,0.D0,ISAMEDEN) + + IF(ISAMEDEN .EQ. 0) PREDNEG = (PRED1*PRED3 - PRED2*PRED2)/DEN + +C NOW CHECK FOR CONVERGENCE, WHICH HAS BEEN OBTAINED IF +C |PRED3/PRED2 - 1| < TOL1 AND |PREDNEG/PRED3 - 1| < TOL2. + + ICONV = 1 + IF(DABS(PRED3/PRED2 - 1.D0) .GE. TOL1) ICONV = 0 + IF(ISAMEDEN .EQ. 0 .AND. DABS(PREDNEG/PRED3 - 1.D0) .GE. TOL2) + 1 ICONV = 0 + +C IF ICONV = 1 FOR THIS COMPARTMENT, IN, STORE THE PREDICTED AMOUNT, +C AND CONTINUE TO THE NEXT COMPARTMENT. NOTE BELOW THAT +C NON-CONVERGENCE IN ANY COMPARTMENT ENDS THE PROCESS SINCE TO +C CONVERGE, ALL COMPARTMENT PREDICTIONS MUST CONVERGE. + + IF(ICONV .EQ. 1 .AND. ISAMEDEN .EQ. 1) XPRED(IN) = PRED3 + IF(ICONV .EQ. 1 .AND. ISAMEDEN .EQ. 0) XPRED(IN) = PREDNEG + +C EDITED CODE ABOVE FOR idm1x11.f. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISAMETOT .EQ. 0 .AND. ISAMEFTOT .EQ.0) +C CONDITION. + + +C IF ISAMETOT .GT. 0, THERE ARE TWO POSSIBILITIES (AND NOTE THAT IT +C DOSEN'T MATTER WHAT ISAMEFTOT IS IN THIS CASE): + +C ISAMETOT = 3, IN WHICH CASE COMP(1:4,IN) ARE ALL THE SAME. +C ISAMETOT = 1 OR 2, IN WHICH CASE SOME OF THE COMP(1:4,IN) VALUES +C ARE THE SAME, AND SOME ARE NOT. + +C IN THE FORMER CASE, VERIFY THAT COMP(5,IN) IS THE SAME VALUE AS +C THE COMP(1:4,IN). IF SO, SET THE PREDICTED VALUE = THIS VALUE +C (I.E., THE PREDICTED VALUE FOR A CONSTANT FUNCTION IS THE +C CONSTANT VALUE), AND SET ICONV = 1. OTHERWISE, SET ICONV = 0 +C SINCE THERE IS NO WAY TO FIT 4 VALUES WHICH ARE THE SAME AND ONE +C WHICH IS NOT USING A NEGATIVE EXPONENTIAL FUNCTION. + +C IN THE LATTER CASE, SINCE SOME OF THE COMP(1:4,IN) VALUES ARE THE +C SAME, AND SOME ARE NOT, SET ICONV = 0 FOR THE SAME REASON AS +C STATED IN THE PREVIOUS PARAGRAPH. + + + IF(ISAMETOT .EQ. 3) THEN + + CALL THESAME(COMP(5,IN),COMP(1,IN),ISAME) + + IF(ISAME .EQ. 1) THEN + ICONV = 1 + XPRED(IN) = COMP(1,IN) + ENDIF + + IF(ISAME .EQ. 0) ICONV = 0 + + ENDIF + + IF(ISAMETOT .EQ. 1 .OR. ISAMETOT .EQ. 2) ICONV = 0 + + +C IF ICONV = 0, CONVERGENCE WAS NOT ACHIEVED. + + IF(ICONV .EQ. 0) RETURN + + + END DO + +C THE ABOVE END DO IS FOR THE DO IN = 1,NN LOOP. + +C TO GET TO THIS POINT, ALL COMPARTMENT AMOUNTS HAVE CONVERGED, AND +C THEIR PREDICTED AMOUNTS HAVE BEEN STORED INTO XPRED(IN),IN=1,NN. + + + RETURN + END + +c IDM3X151.FOR 7/7/14 + +C IDM3X151 HAS THE FOLLOWING CHANGE FROM IDM3X15.F + +C 1. ALL DIMENSIONS OF 71281 ARE CHANGED TO 72000. THIS IS TO ENSURE +C COMPATIBILITY WITH THE BESTDOS119.FOR PROGRAM. + +C 2. THE TWO WRITE STATEMENTS TO FILE 25 ARE REMOVED, SINCE FILE 25 IS +C NOT ACTIVE IN THIS PROGRAM. + +C 3. IN SUBROUTINE FUNC3, COMMON/ERROR/ERRFIL IS ADDED; ERRFIL IS +C DECLARED CHARACTER*20; AND FORMAT 111 AND SIG(.) ARE WRITTEN TO +C ERRFIL JUST BEFORE THE PROGRAM STOPS IF THE PATIENT DATA FILE +C HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE +C RESET ROW. + +C----------------------------------------------------------------------- + +c idm3x15.f 3/6/14 + +c idm3x15 has the following changes from idm3x14: + +c 1. In Subroutine FUNC3, the dimensions related to the no. of output +c equations have been changed from 6 to NUMEQT OR MAXNUMEQ (see +c comments in that routine). + +c 2. In Subroutine FUNC3, the dimensions of 6 in XSTORE and XPRED have +c been changed to 20, as they should have been all along (i.e., this +c represents the maximum no. of compartments allowed). + +c. 3. YPRED has been renamed to be YYPRED (to be consistent with +c the calling argument in the calling module, npageng25.f). Also, +c this will avoid confusion with the YPRED used in the module +c idm2x14.f. + +c 4. The argument list to IDCALCYY has the additional argument, +c NUMEQT, so that YYPRED can now be variably dimensioned. For the +c same reason, NUMEQT has been added to the argument list of +c Subroutines EVAL3 and FUNC3. + +c----------------------------------------------------------------------- + +c idm3x14.f 10/11/12 + +c idm3x14 has one correction from idm3x13: + +c THE R(.) ARE SET = RS(.,.) BEFORE GETIX IS CALLED IN THE TIME RESET +c SECTION OF SUBROUTINE FUNC3. NOT DOING THIS WOULD MEAN THAT IF THE +C INITIAL CONDITIONS FOR THE X(.) ARE FUNCTIONS OF THE COVARIATES +C (ESTABLISHED IN GETIX FROM THE R(.) VALUES), THEY WOULD BE ASSIGNED +C VALUES BASED ON COVARIATES FROM A PREVIOUS DOSAGE LINE IN THE +C PATIENT'S DATA FILE, RATHER THAN THE LINE WHICH IS THE DOSE RESET +C LINE. + +c----------------------------------------------------------------------- + +c idm3x13.f 9/27/12 + +c idm3x13 has the following bug correction to idm3x12: + +C IN SUBROUTINE FUNC3, BEFORE +C THE FIRST CALL TO GETFA, THE R(.) ARE SET = RS(.,.) IN CASE ANY OF +C THE FA(.) ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM +C THE R(.) VALUES IN GETFA. IN ADDITION, PRIOR TO THE 2 SECTIONS WHERE +C THE FA(.) ARE USED, GETFA IS CALLED SO THAT THE FA(.) ARE UPDATED TO +C CURRENT VALUES, BASED ON THE MOST RECENT COVARIATE VALUES IN THE +C PATIENT'S DATA FILE. IN PREVIOUS PROGRAMS, IT WAS SIMPLY ASSUMED +C THAT THE FA(.) WERE FUNCTIONS OF THE PARAMETERS, BUT NOT THE + +C COVARIATES, AND SO THIS WASN'T NECESSARY. BUT THE CODE IN +C TSTMULTI.FOR IMPLIES THAT THE FA(.) COULD BE FUNCTIONS OF THE +C COVARIATES, AND SO THIS CHANGE IS NECESSARY. + +C NOTE THAT SETTING THE R(.) TO RS(.,.) BEFORE THE FIRST CALL TO +C GETFA ALSO MEANS THE R(.) WILL BE SET BEFORE GETIX AND GETTLAG ARE +C FIRST CALLED, WHICH AGAIN IS REQUIRED IN CASE THEY ESTABLISH VALUES +C AS FUNCTIONS OF THE COVARIATES IN THE PATIENT DATA FILE. + +c----------------------------------------------------------------------- + +c idm3x12.f 7/25/12 + +c idm3x12 has the following change to idm1x11: + +c In SUBROUTINE FUNC3, the code to save ND0, SIGO, RSO, is moved to +c before the IF(N .EQ. 0) GO TO 75 statement. The reason is that +c before this routine returns, ND, SIG, and RS are reset back to these +c values, even if N = 0, and so they must be established at this time. + +c----------------------------------------------------------------------- + +c idm3x11.f 4/14/12 + +c idm3x11 has the following changes to idm2x10.f: + +c It is to be used with npageng17.f, which allows steady state doses +c to be boluses as well as IVs. As a result, an additional parameter, +c ISKIPBOL, is used so, in Subroutine FUNC, when convergence occurs in +c a steady state dose set, the last bolus from that set will not be +c reapplied below label 83. + +c----------------------------------------------------------------------- + +c idm3x10.f 4/10/12 + +c idm3x10 has one small 'bug' fix to idm3x9: + +c In Subroutine FUNC3, at label 40, and just below it in the do loop, +c NUMT+1 is replaced by NUMT. Also, all comment references to NUMT+1 +c are replaced by NUMT. The reason is that the no. of times at which +c predicted values are required is NUMT, not NUMT+1. This can, in +c rare situations, mean that TPRED(NUMT+1) = 0 can cause the program +c to stop with an error message (see code around format 111). + +c----------------------------------------------------------------------- + +c idm3x9.f 3/2/12 + +c idm3x9 has the following bug fix to idm3x8.f. In Subroutine FUNC3, +c the code to save ND, SIG, and RS before altering them if there are +c time lag parameters (in the call to GETTLAG) is now executed whether +c or not there are time lag parameters. The reason is that, with steady +c state doses, the first SIG(.) time in a steady state dose set is +c reset to be 0 after the steady state dose is identified. And this +c time must be reset back to be its original negative value at the end +c of the routine so that the next time the routine is called, the +c program will again know when a steady state dose is coming. + +c----------------------------------------------------------------------- + +c idm3x8.f 1/15/12 + +c Corrects bug in Subroutine FUNC3 - now time resets are identified +c by just the observation time = 0 (i.e., the dose time = 0 is +c no longer required). This is because it is possible for a dose +c time (especially if there are timelags) to be after the last +c observation time in a section of the patient file (before a time +c reset), and if this happens, the program will not be able to +c identify the observation time of 0 as a time reset. + +c----------------------------------------------------------------------- + +c idm3x7.f 11/11/11 + +c idm3x7 has the same changes to idm3x6 that idm1x7 has from idm1x6 +c (see all the comments in idm1x7.f for explanations). In particular: + +c 1. It can accommodate steady state dose regimens. + +c 2. All arrays related to doses (SIG,SIGO,RS,RSO, and BS) in +c Subroutine FUNC have their 500's changed to 5000's. + +c 3. Near the top of Subroutine FUNC, R(1)=0.0D0 is replaced by setting +c R(2*I-1) = 0.D0, for I = 1,NDRUG. This should have been done when +c the program became a multi-drug program (see comment in FUNC). + +c 4. A time reset no longer requires all initial compartment amounts +c to be reset to 0. This is because a time reset no longer has to mean +c an "infinite" amount of time has occurred with no dosing; it can also +c now mean an "infinite" amount of time has occurred with unknown +c dosing. So Subroutine GETIX will be called to establish initial +c conditions for the new time period (these initial values can of +c course be 0's as was always assumed in previous programs). This is +c the situation where a patient, who previously had doses and +c observations which were recorded while he was in a lab, goes home and +c gets unknown doses over a long time period, and then returns to the +c lab to get a new set of doses and observations, starting with +c observations which establish his initial conditions for this new +c time period. + +c----------------------------------------------------------------------- + +c idm3x6.f 12/20/10 + +c idm3x6 has the following change to idm3x5: + +c In Subroutine FUNC3, it has code that calls Subroutine ANAL3, rather +c than USERANAL if N .EQ. -1. Also, the code to reset X(I),I=1,N to 0 +c where there is a time reset now includes extra code to set +c X(I),I=1,3 to 0 if N .EQ. -1. + +c Note that ANAL3, and the routines it calls are from the Little NPAG +c program module, IDPC9A.FOR. + +c Note that this module is linked first with bigmlt11.f, and the +c template model file is TSTMULTH.FOR (in which in Subroutine SYMBOL, +c the user is told to code N=-1 if he wants to assume the standard +c 3-compartment linear model with analytic solutions, and in this +c case also establish the 5 parameters, {KE,KA,KCP,KPC,V} of this +c model). + +c----------------------------------------------------------------------- + +c idm3x5.f 4/03/10 + +c idm3x5 has a bug correction to idm3x4. In Subroutine FUNC3, in the +c IF(TPRED(KNT) .EQ. 0.D0 .AND. SIG(KNS) .EQ. 0.D0) block, the time, +c T, is also reset = 0 since the integration will again start from +c time 0. When this wasn't done (in idm3x4.f), the results were +c unpredictable (depending on how the DVODE integration routines +c treated a (T,TOUT) pair which decreased rather than increased. + +c----------------------------------------------------------------------- + +c idm3x4.f 11/23/09 + +c idm3x4 fixes a bug in the idm3x3 code. Label 75 is moved to in +c front of the CALL GETTLAG(TLAG) statement (see the reason in +c that part of the code). + +c----------------------------------------------------------------------- + +c idm3x3.f 9/18/09 + +c idm3x3 has the following changes from idm3x2: + +c 1. The TLAG and FA vectors, and the initial values for the X array +c will be set by calling new routines (GETTLAG, GETFA, and GETIX, +c respectively) that are part of the model file (the new template is +c TSTMULT.FOR). This means the user can now code explicit formulas +c for these values. As a result, all reference to NTLAG, IC, IFA, and +c IVOL have been removed. + +c 2. The shift subroutine will now be from the module, shift5.f, +c rather than shift4.f. + +c Note that this module, along with idm1x3.f, id2x3.f, and shift5.f +c are part of the new "engine", whose main module is bigmlt4.f. + +c----------------------------------------------------------------------- + +c idm3x2.f 8/14/09 + +c idm3x2 has the following changes from idm3x1: + +c 1. The code for setting initial compartment amounts from initial +c compartment concentrations is changed to reflect the fact that +c now IC(2) refers to the index of the covariates, not the +c column no. of RS (see comment in code). + +c 2. The code to establish the timelag parameters has changed to +c reflect that NTLAG(I) can now be negative --> in Subroutine +c SHIFT, the associated timelag parameter will now be the +c exponent of the indicated parameter (rather than the parameter +c itself). + +c 3. The code to establish the FA parameters has changed to +c reflect that IFA(I) can now be negative --> the associated FA +c parameter will now be the exponent of the indicated parameter +c (rather than the parameter itself). + + +c idm3x2.f (along with other new modules idm1x2.f and idm2x2.f) are +c still called by bigmlt2.f, but are part of the "engine" for the +c new NPBIG15B.FOR program. + +c----------------------------------------------------------------------- + + +c idm3x1.f 5/27/09 + +c idm3x1.f has the following changes from idcy_63f.f: + +c 1. It allows the extra option of setting initial compartment +c amounts from their initial concentrations - see code in Subroutine +c FUNC3. + +c 2. It is part of the new Big NPAG "engine", bigmlt2.f, which allows +c patient data files to have "reset" values of 0 in the dosage and +c sampling blocks. Whenever, in Subroutine FUNC2, the program sees a +c SIG(.) = 0 and a TIM(.) = 0, it knows that a large enough time has +c passed since the last dose that all compartment amounts are to be +c reset = 0. Subsequent dose and observed value times are then values +c from this point. + +c 3. The first argument to Subroutine OUTPUT is changed from 0.0 to +c 0.D0 in two places. + + +c This module, along with idm1x1.f and idm2x1.f are first used in the +c bigmlt2.f program. + +c----------------------------------------------------------------------- + + + +c idcy_63g.f 5-28-02 + +c idcy_63g has the following changes from idcy_63f: + +c It allows multiple drug inputs (rather than just one drug input). +c The changes required for this are: + +c 1. BS has dimension change from (500,3) to (500,7) +c 2. COMMON/CNST2 is changed to include NDRUG (no. of drugs) and +c NADD (no. of additional covariates), rather than NBI and NRI. +c 3. NTLAG is now a vector instead of a scalar. In particular, +C NTLAG(I) = 0 IF DRUG I'S BOLUS COL. HAS NO TIMELAG PARAMETER; +C K IF DRUG I'S BOLUS COL. HAS A TIMELAG WHOSE VALUE IS +C GIVEN BY PARAMETER NO K. +C 4. IFA, PASSED IN COMMON/FRABS FROM SUBROUTINE SYMBOL IS NOW A VECTOR +C INSTEAD OF A SCALAR. +C IFA(I) = 0 IF DRUG I WILL HAVE FA = 1.0. +C K IF DRUG I WILL HAVE AN FA WHOSE VALUE IS TO BE GIVEN +C BY PARAMETER K. +C 5. THE BOLUS COMPARTMENT NOS., NBCOMP(I), NOW COME VIA +C COMMON/BOLUSCOMP FROM SUBROUTINE SYMBOL, AND THE DIMENSION OF +C NBCOMP HAS BEEN CHANGED TO 7 (MAXIMUM OF 1 PER DRUG) FROM 20. +C 6. ALL OF THE CODE IN SUBROUTINE FUNC3 RELATED TO NRI AND NBI HAS +C BEEN CHANGED TO BE IN TERMS OF NI AND NDRUG. +C 7. THE CODE RELATED TO CALLING SUBROUTINE SHIFT, INCLUDING THE +C CALLING ARGUMENTS, HAS BEEN CHANGED TO REFLECT THE ABOVE CHANGES +C IN NTLAG (I.E., IT IS NOW A VECTOR RATHER THAN A SCALAR). A NEW +C MODULE, shift3.f (WHICH REPLACES shift2.f) WILL BE LINKED WITH +C THIS MODULE. + +C----------------------------------------------------------------------- + +c idcy_63f.f 4-23-02 + + +c idcy_63f has the following changes to idcy_63e: + +c 1. To enable FA to be a parameter value (either fixed or random), +c rather than always be hardcoded = 1.0, the following changes are +c implemented ... + +c The hardcoding of FA = 1.0 and the code for NBCOMP are removed +c from main. In addition, COMMON/BCOMP is removed from the entire +c module. Instead, in SUBROUTINE FUNC3, a new COMMON/FRABS/IFA provides +c the value IFA which is the parameter index of the FA value (passed +c from SUBROUTINE SYMBOL) unless it = 0, in which case FA is +c set = 1.0. Also the NBCOMP compartment nos. are now set in +c SUBROUTINE FUNC3. + +c 2. COMMONS /OBSER AND /SUM2 (and the arrays in them) are deleted from +c main. They were not needed. Also, COMMON CNST2 is deleted from main +c since NBI is no longer needed here (since NBCOMP code is removed - +c see no. 1. above). + +c----------------------------------------------------------------------- + +c idcy_63e.f 1-22-00 + +c idcy_63e has the following changes to idcy_63d: + +c It allows the initial conditions of the amounts in the compartments +c to be paramater values, rather than fixed at 0.0. These parameter +c values may be either fixed or random. + +c To affect this enhancement, the primary change is the code in +c subroutine FUNC3 which sets the initial conditions based on the +c values in IC which are provided by COMMON/INITCOND from +c SUBROUTINE SYMBOL of the Fortran model file. + +c There are many other changes to simply the code (i.e., a lot of +c code was leftover code which was unused and/or confusing), namely: + +c - Commons ADAPT1, ADAPT2, LPARAM, PRED, TRANS, and PARAM are +c deleted. Variables ISW, IP, and C are deleted. +c - COMMON/PARAMD/P is now in MAIN, FUNC, and JACOB of idfix5e.f; +c MAIN and FUNCx of idcy_53e.f and idcy_63e.f; and DIFFEQ and OUTPUT +c of the Fortran model file. +c - P is redimensioned 32. It will hold only the parameters of the +c model (although some of those parameters may be initial conditions) +c and there are 20 allowable random paramaters and 12 allowable +c fixed paramaters now. +c - All the code to reverse the paramater order (using PD) and to do +c and undo square root transformations in MAIN and FUNC3 is removed +c (it was unneeded, and therefore confusing). In particular, all +c references to NPT, NUMYES, NUIC, NUP, NPNL, and NBOT are removed. +c - COMMON ANALYT/IDIFF is removed. IDIFF is unneeded since IDIFF = 0 +c is equivalent to N = 0, and so IDIFF code in FUNC3 is replaced by +c the equivalent code for N. NEQN is replaced by N. +c - In SUBROUTINE EVAL3, COMMON/PARAM is removed, along with PP and P. +c Setting PP(I) = P(I), I=1,NPNL made no sense since PP wasn't used +c and NPNL was always = 0 anyway. +c - In FUNC3, the If statment at label 83 is changed to include +c N .EQ. 0 since if N = 0, setting compartment values is unnecessary. + +c idcy_63e is part of the big npem program, npbig4.f. + + + SUBROUTINE IDCALCYY(NPP,NDIM,ESTML,TPRED,NUMT,YYPRED,NUMEQT) + +C INPUT ARE: + +C NPP = NO. OF PARAMETERS (RANDOM AND FIXED) IN THE PARAMATER +C VECTOR, ESTML. +C NDIM = NO. OF STATES FOR THE O.D.E. +C ESTML = VECTOR OF PARAMETER ESTIMATES. +C TPRED = VECTOR OF TIMES AT WHICH PREDICTED CONCENTRATIONS WILL +C BE FOUND. +C NUMT = OF TIMES IN TPRED. + + +C INFORMATION FROM A SUBJECT DATA FILE WHOSE INFO IS PASSED TO THE +C ROUTINES IN THIS MODULE VIA COMMONS /OBSER/, /CNST/, /CNST2/, AND +C /SUM2/. + + +C OUTPUT IS: + + +C YYPRED(I,J), I=1,NUMT; J=1,NOS = THE PREDICTED VALUE AT TIME +C TPRED(I) OF THE JTH OUTPUT EQUATION, GIVEN THE INPUT VECTOR +C ESTML. M AND NOS ARE INPUT TO THIS MODULE VIA COMMONS SUM2 AND +C CNST2, RESPECTIVELY. + +c----------------------------------------------------------------------- + +c See other comments at the top of idcy_63d.f code. + +C----------------------------------------------------------------------- + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION ESTML(32),YYPRED(72000,NUMEQT),TPRED(72000),P(32) + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/PARAMD/ P + +C*****INITIALIZE PROGRAM***** + + CALL SYMBOL + +C THE ABOVE CALL OBTAINS INFO FROM COMMONS. + +C NOTE THAT THIS PROGRAM NOW GETS N = NDIM AND NPP = NVAR+NOFIX +C AS CALLING ARGUMENTS. + + N = NDIM + NP = NPP + +C CALCULATE THE OUTPUT CONCENTRATION VECTOR, Y, FOR THE PARAMETER +C VECTOR, ESTML. + +C PUT MODEL PARAMETER VALUES INTO P. + + DO I=1,NP + P(I) = ESTML(I) + END DO + + +C CALL SUBROUTINE EVAL3 TO GET Y, EVALUATED +C AT ESTML(I) AS DEFINED ABOVE. + + CALL EVAL3(NUMT,YYPRED,TPRED,NUMEQT) + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE FUNC3(NUMT,YYPRED,TPRED,NUMEQT) + + +C THIS SUBROUTINE, CALLED BY EVAL3, FINDS YYPRED(I) = OUTPUT CONC. AT +C THE NUMT TIMES IN TPRED, GIVEN PARAMETER VALUES IN P. +C NOTE THAT YYPRED IS FOUND AT THE NUMT TIMES IN TPRED BELOW. + + IMPLICIT REAL*8(A-H,O-Z) + COMMON/BOLUSCOMP/NBCOMP + COMMON/OBSER/ TIM,SIG,RS,YO,BS + COMMON/CNST/ N,ND,NI,NUP,NUIC,NP + COMMON/INPUT/ R,B + COMMON/PARAMD/ P + COMMON/CNST2/ NPL,NOS,NDRUG,NADD + COMMON/STATE/ X + COMMON/ERROR/ERRFIL + PARAMETER(MAXNUMEQ=7) + +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. + + + DIMENSION X(20),P(32),TIM(594),SIG(5000),SIGO(5000),R(37), + 1 RS(5000,34),RSO(5000,34),YT(MAXNUMEQ),YO(594,MAXNUMEQ), + 2 YYPRED(72000,NUMEQT),BS(5000,7),Y(72000,MAXNUMEQ),B(20), + 3 NBCOMP(7),TPRED(72000),TLAG(7),FA(7),XSTORE(100,20),XPRED(20) + + CHARACTER ERRFIL*20 + +C NOTE THAT AS OF idm3x15.f, THE DIMENSIONS OF 6 IN XSTORE AND XPRED +C HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN ALL +C ALONG (I.E., THE SAME AS FOR X). + +C NOTE THAT THE DIMENSIONS RELATED TO THE NO. OF OUTPUT EQS. IN +C YO, YT AND Y ARE CHANGED TO MAXNUMEQ (FROM 6). NUMEQT COULD NOT +C BE USED BECAUSE THESE ARRAYS WERE NOT PASSED TO THIS ROUTINE AS +C DUMMY ARGUMENTS. + + +C THE 2ND DIMENSION OF YYPRED IS CHANGED TO NUMEQT, SINCE IT IS PASSED +C IN THE ARGUMENT LIST, AND CAN THEREFORE BE VARIABLY DIMENSIONED. + + +C NOTE THAT "7" IN THE ABOVE ARRAYS INDICATE THE NO. OF DRUGS ALLOWED. + +C*****ODE CONSTANTS AND INITIALIZATION***** + + KNS=1 + KNT=1 + +C NOTE THAT KNT IS THE RUNNING INDEX OF THE NEXT OBSERVATION TIME, +C AND KNS IS THE RUNNING INDEX OF THE NEXT DOSAGE TIME. + + T=0.0D0 + +C INITIALIZE ISKIPBOL = 0. SEE CODE BELOW. IT IS ONLY NEEDED FOR A +C STEADY STATE DOSE SET WHICH HAS BOLUS DOSES. + + ISKIPBOL = 0 + + + DO I = 1,NDRUG + R(2*I-1) = 0.D0 + END DO + +c AS OF idm3x7.f, instead of R(1) = 0, the code has been changed to +c set R(2*I-1) = 0, for I = 1,NDRUG. I.E., All IV rates for all NDRUG +c drugs are initialized to be 0 ... in case the 1st obs. time is 0, +c which means that OUTPUT is called before the R(I) are set below. + +C CALL SUBROUTINE GETFA IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETFA IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF FA FOR EACH +C OF THE NDRUG DRUGS. + +C AS OF idm3x13.f, BEFORE CALLING GETFA, MUST SET +C THE R(.) IN CASE ANY OF THE FA(.) ARE FUNCTIONS OF THE +C COVARIATES WHICH ARE ESTABLISHED FROM THE R(.) VALUES IN +C GETFA. + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + + CALL GETFA(FA) + + +C NOTE THAT NBCOMP(I),I=1,NDRUG WAS SET IN SUBROUTINE SYMBOL AND +C PASSED TO THIS ROUTINE VIA COMMON/BOLUSCOMP. + + +C As of idm3x12.f, the code to save ND0, SIGO, RSO, is moved to before +c the IF(N .EQ. 0) GO TO 75 statement. The reason is that before this +c routine returns, ND, SIG, and RS are reset back to these values, +c even if N = 0, and so they must be established at this time. + +C AS OF idm3x9.f, SAVE ND, SIG, AND RS WHETHER OR NOT NTL = 1, SINCE +C IF THERE ARE STEADY STATE DOSE SETS, THE FIRST SIG(.) VALUE IN EACH +C SET WILL BE CHANGED TO BE 0 BELOW. + + NDO = ND + DO I=1,ND + SIGO(I) = SIG(I) + DO J=1,NI + RSO(I,J) = RS(I,J) + END DO + END DO + + + +C IF N = 0, THE OUTPUT EQUATION(S) FOR Y ARE CODED EXPLICITLY INTO +C SUBROUTINE OUTPUT, AND NO D.E. SOLUTIONS (VIA USERANAL/DIFFEQ) ARE +C TO BE USED. IN THIS CASE, SKIP THE CODE REGARDING INITIAL CONDITIONS +C OF THE COMPARTMENTS, SINCE THEY ARE IRRELEVANT (I.E., THE COMPARTMENT +C AMOUNTS DON'T NEED TO BE INITIALIZED SINCE THEY WON'T BE UPDATED BY +C INTEGRATING D.E.'S). IN FACT, COULD PROBABLY SKIP TIMELAGS TOO, +C SINCE THEY CHANGE THE TIME THAT BOLUS DOSES ARE GIVEN, AND THIS +C THEORETICALLY ONLY AFFECTS COMPARTMENT AMOUNTS (WHICH ARE NOT USED +C IF N = 0), BUT JUST SKIP INITIAL CONDITIONS FOR NOW. + + IF(N .EQ. 0) GO TO 75 + + +C CALL SUBROUTINE GETIX IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETIX IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF X (THE INITIAL +C COMPARTMENT AMOUNT) FOR EACH OF THE N COMPARTMENTS. + + CALL GETIX(N,X) + + + +C CALL SUBROUTINE GETTLAG IN npemdriv.f (THE FIRST TEMPLATE FILE TO +C INCLUDE GETTLAG IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF THE TIMELAG +C FOR EACH OF THE NDRUG DRUGS. + + 75 CALL GETTLAG(TLAG) + +C IF ANY TLAG(.) VALUES RETURN AS .NE. 0, THEN, CALL SUBROUTINE SHIFT +C TO ADJUST THE DOSAGE REGIMEN APPROPRIATELY. + + NTL = 0 + DO ID = 1,NDRUG + IF(TLAG(ID) .NE. 0) NTL = 1 + END DO + + IF(NTL .EQ. 1) THEN + +C STORE INCOMING VALUES IN ND, SIG, AND RS (WHICH CONTAINS BS VALUES) +C SINCE THEY WILL BE CHANGED IN THE CALL TO SUBROUTINE SHIFT, WHICH +C "SHIFTS" THE DOSAGE REGIMEN MATRIX TO ACCOUNT FOR THE TIMELAG +C PARAMETER(S), TLAG(I). AT THE END OF THIS ROUTINE, THE VALUES IN ND, +C SIG, AND RS WILL BE RESET TO THEIR INCOMING VALUES - TO BE READY FOR +C THE NEXT CALL TO THIS ROUTINE WITH POSSIBLY DIFFERENT VALUES FOR +C TLAG(I). + + + CALL SHIFT(TLAG,ND,SIG,NDRUG,NADD,RS) + + +C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NTL .EQ. 1) CONDITION. + + + + + IF(TPRED(KNT).GE.SIG(KNS)) GO TO 12 + IF(TPRED(KNT).NE.0.0D0) GO TO 45 + +C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TPRED(KNT) +C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. + + CALL OUTPUT(0.D0,YT) + DO 2000 I=1,NOS +2000 Y(KNT,I)=YT(I) + KNT=KNT+1 + GO TO 45 + +12 IF(TPRED(KNT) .GT. SIG(KNS)) GO TO 13 + IF(TPRED(KNT) .NE. 0.0D0) GO TO 45 + +C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TPRED(KNT) +C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. + + CALL OUTPUT(0.D0,YT) + DO 2005 I=1,NOS +2005 Y(KNT,I)=YT(I) + KNT=KNT+1 + +13 IF(SIG(KNS) .GT. 0.0D0) GO TO 45 + +C CHECK TO SEE IF SIG(KNS) < 0. IF SO, IT MEANS THAT 100 STEADY STATE +C DOSES SHOULD NOW BE APPLIED WITH AN INTERDOSE INTERVAL EQUAL TO +C -SIG(KNS). + + ISTEADY = 0 + + IF(SIG(KNS) .LT. 0.D0) THEN + + ISTEADY = 1 + NSET = 1 + +C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE +C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 +C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... +C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. +C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE +C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE +C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE +C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC +C OF PREDLAST3 REQUIRES). + +C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT +C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS +C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF +C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE +C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. + +C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF +C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL +C INTEGRATED THROUGH, WHICHEVER COMES FIRST. + + DOSEINT = -SIG(KNS) + + + +C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START +C OF 100 DOSE SETS THAT BEGIN AT TIME 0. + + + SIG(KNS) = 0 + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. + + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + IF(NDRUG .EQ. 0) GO TO 81 + +C AS OF idm3x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT +C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED +C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. + + CALL GETFA(FA) + + + IF(N .EQ. 0) GO TO 120 + DO I=1,NDRUG + X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS,I)*FA(I) + END DO + +C NOTE THAT FA(I) IS THE FRACTION OF DRUG AVAILABLE FROM A BOLUS INPUT +C FOR DRUG I INTO ITS ABSORPTIVE COMPARTMENT. + + GO TO 81 + +120 DO I=1,NDRUG + B(I)=BS(KNS,I)*FA(I) + END DO + +81 KNS=KNS+1 + +C*****INTEGRATION OF EQUATIONS***** + + +C DETERMINE IF, OBSER(ID=0), OR DOSE(ID=1), OR BOTH(ID=2). + +45 IF(KNS.GT.ND) GO TO 15 + + + +C CODE CHANGE BELOW FOR idm3x8.f. + + IF(TPRED(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) THEN + + + +C AS OF idm3x7.f, A TIME RESET NO LONGER REQUIRES ALL INITIAL +C COMPARTMENT AMOUNTS TO BE RESET TO 0. THIS IS BECAUSE A TIME RESET +C NO LONGER HAS TO MEAN THAT AN "INFINITE" AMOUNT OF TIME HAS OCCURRED +C WITH NO DOSING; IT CAN ALSO NOW MEAN THAT AN "INFINITE" AMOUNT OF +C TIME HAS OCCURRED WITH UNKNOWN DOSING (IN THIS CASE, SUBROUTINE +C GETIX WILL BE CALLED BELOW TO ESTABLISH INITIAL CONDITIONS FOR THIS +C TIME PERIOD). + +C ADVANCE KNS TO THE NEXT VALUE THAT HAS SIG(KNS) .LE. 0. I.E., ONCE +C TIMN(KNT) = 0, IT MEANS THAT WE ARE DONE WITH THE OUTPUT OBS. +C TIMES IN THE PREVIOUS SECTION --> THERE IS NO POINT IN CONTINUING +C TO INTEGRATE TILL THE END OF THE DOSES IN THE PREVIOUS SECTION +C (IF THERE ARE ANY). + + DO IKNS = KNS,ND + IF(SIG(IKNS) .LE. 0.D0) GO TO 110 + END DO + +C TO GET HERE MEANS THAT NO VALUE IN SIG(.) FROM KNS TO ND HAS A +C VALUE .LE. 0, AND THIS IS AN ERROR. IT MEANS THAT THE PATIENT DATA +C FILE HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING +C DOSE RESET ROW. TELL THE USER AND STOP. + + WRITE(*,111) ND,KNS,SIG(KNS) +111 FORMAT(//' IN SUBROUTINE FUNC3, THE CURRENT SUBJECT HAS AN'/ + 1' OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE'/ + 2' RESET ROW. THE PROGRAM NOW STOPS. '// + 3' REVIEW YOUR PATIENT FILES AND CORRECT THE ERROR.'// + 4' NOTE THAT THE ',I4,' DOSE TIMES (POSSIBLY ALTERED BY TIMELAGS'/ + 5' ARE THE FOLLOWING (AND THERE IS NO TIME .LE. 0 AFTER TIME'/ + 6' NO. ',I4,' WHICH HAS CORRESPONDING TIME ',F15.4,'):') + + + DO I = 1,ND + WRITE(*,*) SIG(I) + END DO + + OPEN(47,FILE=ERRFIL) + WRITE(47,111) ND,KNS,SIG(KNS) + DO I = 1,ND + WRITE(47,*) SIG(I) + END DO + CLOSE(47) + + + CALL PAUSE + STOP + + + 110 KNS = IKNS + + + +C THERE ARE TWO POSSIBILITES AT THIS POINT, EITHER SIG(KNS) = 0 +C OR SIG(KNS) < 0. + +C IF SIG(KNS) = 0, THIS REPRESENTS A TIME RESET (T WILL BE SET = 0 +C BELOW) WITH A SINGLE DOSE LINE TO START. IN THIS CASE, CALL GETIX +C AGAIN (JUST AS WAS DONE NEAR THE TOP OF THIS ROUTINE) TO OBTAIN +C INITIAL COMPARTMENT AMOUNTS. NOTE THAT BY DEFAULT, IN GETIX, ALL +C COMPARTMENT AMOUNTS ARE SET = 0 (WHICH WOULD BE THE CASE IF IN THE +C LONG TIME PERIOD BETWEEN THE LAST SET OF DOSES AND THIS NEW +C BEGINNING, NO DOSES HAVE BEEN GIVEN). BUT THE USER MAY ALSO HAVE +C CODED INTO GETIX EQUATIONS THAT SET ONE OR MORE OF THE X(I) TO +C FUNCTIONS OF COVARIATE AND PARAMETER VALUES (WHICH WOULD BE THE +C SITUATION IF AN UNKNOWN DOSING REGIMEN HAS TAKEN PLACE BUT IT +C DOESN'T MATTER WHAT IT WAS BECAUSE THE PATIENT COMES TO A LAB AND +C SIMPLY HAS HIS COMPARTMENT VALUES ESTABLISHED BEFORE CONTINUING +C WITH THE OTHER VALUES IN HIS PATIENT FILE). + +C IF SIG(KNS) < 0, THIS REPRESENTS A TIME RESET WITH A STEADY STATE +C SET OF 100 DOSES ABOUT TO BEGIN. IN THIS CASE, WE ASSUME THAT THE +C PATIENT IS ABOUT TO GET 100 SETS OF DOSES SO THAT HIS COMPARTMENT +C AMOUNTS WILL ACHIEVE STEADY STATE VALUES. THESE STEADY STATE VALUES +C WILL BE ESTIMATED IN THE BLOCK OF CODE BELOW THAT STARTS WITH +C IF(ISTEADY .EQ. 1). IN THIS CASE, WE WILL STILL CALL GETIX TO +C MAKE SURE THAT ANY RESIDUAL COMPARTMENT AMOUNTS FROM A PREVIOUS +C SET OF DOSES IS ZEROED OUT (OR SET = VALUES AS DETERMINED BY +C SUBROUTINE GETIX). + +C AS OF idm3x14.f, BEFORE CALLING GETIX, MUST SET +C THE R(.) IN CASE ANY OF THE INITIAL CONDITIONS FOR THE X(.) +C ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM THE +C R(.) VALUES IN GETFA. + + DO I=1,NI + R(I)=RS(KNS,I) + END DO + + + CALL GETIX(N,X) + + + +C MUST ALSO RESET T = 0 SINCE THE INTEGRATION WILL AGAIN START FROM +C TIME 0. + + T = 0.D0 + + +C IF SIG(KNS) .LT. 0, THIS IS NOT ONLY A TIME RESET, IT IS THE +C BEGINNING OF A STEADY STATE DOSE SET. IN THIS CASE, APPLY 100 +C STEADY STATE DOSES WITH AN INTERDOSE INTERVAL EQUAL TO -SIG(KNS). + + ISTEADY = 0 + + IF(SIG(KNS) .LT. 0.D0) THEN + + ISTEADY = 1 + NSET = 1 + +C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE +C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 +C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... +C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. +C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE +C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE +C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE +C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC +C OF PREDLAST3 REQUIRES). + +C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT +C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS +C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF +C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE +C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. + +C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF +C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL +C INTEGRATED THROUGH, WHICHEVER COMES FIRST. + + DOSEINT = -SIG(KNS) + +C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START +C OF 100 DOSE SETS THAT BEGIN AT TIME 0. + + + + SIG(KNS) = 0 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(TPRED(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) CONDITION. + + + IF(TPRED(KNT) .NE. SIG(KNS)) GO TO 20 + ID=2 + TOUT=TPRED(KNT) + + KNT=KNT+1 + KNS=KNS+1 + + IF(N .EQ. 0) GO TO 31 + GO TO 30 + +20 IF(TPRED(KNT) .GT. SIG(KNS) .AND. SIG(KNS) .GT. 0) GO TO 25 + +15 ID=0 + TOUT=TPRED(KNT) + + KNT=KNT+1 + + IF(N .EQ. 0) GO TO 31 + GO TO 30 + +25 ID=1 + TOUT=SIG(KNS) + + KNS=KNS+1 + IF(N .EQ. 0) GO TO 31 + + +30 CONTINUE + + +32 IF(N .NE. -1) CALL USERANAL(X,T,TOUT) + IF(N .EQ. -1) CALL ANAL3(X,T,TOUT) + + + +C IF ISTEADY = 1, THIS IS INSIDE A STEADY STATE DOSE SET. CHECK TO SEE +C IF TOUT IS A MULTIPLE OF DOSEINT. IF SO, RECORD THE COMPARTMENT +C AMOUNTS. THEN, AFTER COMPARTMENT AMOUNTS HAVE BEEN STORED FOR AT +C LEAST THE 1ST 5 MULTIPLES OF DOSEINT, STOP AND CALL SUBROUTINE +C PREDLAST3 WHICH PREDICTS THE FINAL (STEADY STATE) COMPARTMENT AMOUNTS +C AFTER THE LAST (100TH) DOSE SET. + +C IF PREDLAST3 HAS PREDICTED VALUES WHICH "CONVERGE", ASSIGN THE +C PREDICTED VALUES TO X, INCREASE KNS TO BE THE INDEX OF THE FIRST DOSE +C EVENT WHICH OCCURS AFTER THE STEADY STATE DOSE SET ENDS AND CONTINUE. + +C IF PREDLAST3 VALUES DON'T CONVERGE, CONTINUE THE PROCESS WITH +C COMPARTMENT AMOUNTS FOR MULTIPLES 2 - 6 OF DOSEINT, TEST FOR +C "CONVERGENCE", ETC. THIS PROCESS CONTINUES UNTIL "CONVERGENCE" IS +C ACHIEVED FOR A SET OF 5 COMPARTMENT AMOUNTS (OR SETS OF AMOUNTS IF +C NDRUG IS > 1), OR UNTIL ALL 100 DOSE SETS IN THE STEADY STATE REGIMEN +C HAVE FINISHED. + + IF(ISTEADY .EQ. 1) THEN + + +C THE NEXT DOSE SET END TIME IS DOSEINT*NSET. IF TOUT = DOSEINT*NSET, +C STORE THE COMPARTMENT AMOUNTS. IF NSET .GE. 5, CALL PREDLAST3 AND +C PROCEED AS INDICATED ABOVE. + + CALL THESAME(TOUT,DOSEINT*NSET,ISAME) + + IF(ISAME .EQ. 1) THEN + + NN = N + IF(N .EQ. -1) NN = 3 + + DO J = 1,NN + XSTORE(NSET,J) = X(J) + END DO + + IF(NSET .GE. 5) THEN + + CALL PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) + +C + + IF(ICONV .EQ. 1) THEN + +C SINCE THE PREDICTED VALUES ARE CONSIDERED ACCURATE (I.E., +C "CONVERGENCE WAS ACHIEVED IN PREDLAST), RESET ISTEADY TO 0, +C WHICH MEANS THAT THE STEADY STATE DOSES ARE FINISHED; ASSIGN THE +C COMPARTMENT AMOUNTS TO BE THE PREDICTED VALUES; AND SET KNS TO THE +C FIRST DOSE EVENT AFTER THE END OF THE STEADY STATE DOSE SET. ALSO, +C SET T = THE ENDING TIME OF THE STEADY STATE DOSE SET = 100*DOSEINT, +C SINCE THAT IS WHAT IT WOULD HAVE BEEN HAD ALL 100 DOSE SETS BEEN +C RUN. + + + ISTEADY = 0 + + DO J = 1,NN + X(J) = XPRED(J) + END DO + + + T = 100.D0*DOSEINT + +C ADVANCE KNS TO BE THE FIRST DOSE PAST THE 100 DOSE SETS IN THIS +C STEADY STATE SET. NOTE THAT THIS SET ENDS BEFORE 100*DOSEINT, SO +C FIND THE FIRST SIG(.) THAT IS .GE. 100*DOSEINT, OR THAT IS = 0 +C (WHICH SIGNIFIES A TIME RESET) OR THAT IS < 0 (WHICH SIGNIFIES +C ANOTHER STEADY STATE SET). + + DO I = KNS,ND + IF(SIG(I) .GE. 100.D0*DOSEINT .OR. SIG(I) .LE. 0.D0) THEN + KNSNEW = I + GO TO 100 + ENDIF + END DO + + +C TO GET HERE MEANS THAT THERE ARE NO DOSE TIMES PAST THE END OF THIS +C STEADY STATE DOSE SET. IN THIS CASE, SET KNS TO ND+1 + + KNS = ND+1 + GO TO 200 + + 100 KNS = KNSNEW + 200 CONTINUE + + + +C SET ISKIPBOL = 1 WHENEVER CONVERGENCE OCCURS IN +C THE STEADY STATE DOSES SINCE IN THIS CASE, WE DON'T WANT TO +C REAPPLY THE LAST BOLUS FROM THE STEADY STATE SET BELOW LABEL 83. + + ISKIPBOL = 1 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICONV .EQ. 1) CONDITION. + +C IF ICONV = 0, ISTEADY IS STILL = 1, +C WHICH MEANS THAT THE ATTEMPT TO PREDICT THE FINAL (STEADY STATE) +C COMPARTMENT AMOUNTS CONTINUES. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NSET .GE. 5) CONDITION. + +C SINCE ISAME = 1, THE END OF THE SET NO. NSET HAS OCCURRED --> +C INCREASE NSET BY 1. + + NSET = NSET + 1 + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ISTEADY .EQ. 1) CONDITION. + + + +31 CONTINUE + + +C RECORD OBSERVATION AND SUPPLY NEW DOSE + + IF(ID.EQ.1) GO TO 35 + KNTM1=KNT-1 + +C NOTE THAT THE TIME AT WHICH THE OUTPUT IS DESIRED IS TPRED(KNTM1); +C THIS IS CLEAR SINCE THE RETURNING VALUE(S) IN YT ARE PUT INTO ROW NO. +C KNTM1 OF Y. + + CALL OUTPUT(TPRED(KNTM1),YT) + + DO 2010 I=1,NOS +2010 Y(KNTM1,I)=YT(I) + + + +55 IF(ID.EQ.0) GO TO 40 + + 35 CONTINUE + + IF(NI .EQ. 0) GO TO 83 + + DO I=1,NI + R(I)=RS(KNS-1,I) + END DO + +C AS OF idm3x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT +C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED +C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. + + CALL GETFA(FA) + + +83 IF(NDRUG .EQ. 0 .OR. N .EQ. 0) GO TO 82 + +C ADDING N .EQ. 0 TO ABOVE IF STATEMENT SHOWS CLEARLY THAT IF +C N = 0 (IN WHICH CASE ANALYTIC SOLUTIONS ARE CODED DIRECTLY INTO +C SUBROUTINE OUTPUT, WHICH MAKES THE COMPARTMENT AMOUNTS IRRELEVANT) +C SETTING VALUES FOR THE COMPARTMENTS, X, IS UNNECESSARY. + + +C IF ISKIPBOL = 1, DO NOT APPLY BOLUSES FROM DOSE KNS-1, SINCE THESE +C BOLUSES WERE PART OF THE STEADY STATE DOSE SET WHICH ALREADY HAD +C BOLUSES (EFFECTIVELY) APPLIED ABOVE WHERE "CONVERGENCE" OF THE +C STEADY STATE DOSE SET WAS OBTAINED. + + IF(ISKIPBOL .EQ. 0) THEN + DO I=1,NDRUG + X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS-1,I)*FA(I) + END DO + ENDIF + + + +C RESET ISKIPBOL = 0 HERE. IF IT IS NOW = 1, IT MEANS THAT +C THE ABOVE APPLICATION OF BOLUSES WAS SKIPPED SINCE THERE HAS JUST +C BEEN A STEADY STATE SET OF DOSES WHICH CONVERGED (AND WE DON'T +C WANT THE LAST BOLUS DOSE REAPPLIED). BUT, GOING FORWARD, ISKIPBOL +C SHOULD BE SET AGAIN TO 0 SO THE ABOVE APPLICATION OF BOLUSES WILL +C OCCUR WHENEVER THERE IS A NEW BOLUS TO BE APPLIED. + + ISKIPBOL = 0 + + +82 CONTINUE + +C CHECK STOPPING TIME. + +40 IF(KNT .LE. NUMT) GO TO 45 + +C*****DETERMINE YYPRED(I)***** + + DO J=1,NOS + DO I=1,NUMT + YYPRED(I,J)=Y(I,J) + END DO + END DO + + +C AS OF idm3x9.f, RESTORE THE VALUES FOR ND, SIG, AND RS, IN CASE +C THIS MODEL HAS TIME LAGS OR STEADY STATE DOSES - TO BE READY FOR THE +C NEXT CALL TO THIS ROUTINE. + + + ND = NDO + DO I=1,ND + SIG(I) = SIGO(I) + DO J=1,NI + RS(I,J) = RSO(I,J) + END DO + END DO + +C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE EVAL3(NUMT,YYPRED,TPRED,NUMEQT) + +C THIS SUBROUTINE, CALLED BY IDCALCYY/MAIN, FINDS THE OUTPUT CONC. +C ARRAY, YYPRED, EVALUATED AT PARAMETER VALUES IN VECTOR P, PASSED +C DIRECTLY TO SUBROUTINE FUNC3 VIA COMMON/PARAMD ... AT THE NUMT +C TIMES IN TPRED. + + IMPLICIT REAL*8(A-H,O-Z) + COMMON /SUM2/ M,NPNL + COMMON/CNST2/ NPL,NOS,NDRUG,NADD + DIMENSION YYPRED(72000,NUMEQT),TPRED(72000) + + CALL FUNC3(NUMT,YYPRED,TPRED,NUMEQT) + + RETURN + END + + +C NPAGFULLA.FOR 6/30/14 + +C NPAGFULLA HAS THE FOLLOWING CHANGES TO NPAGFULL: + +C 1. JUST AFTER THE REWIND(27) STATEMENT, SUBROUTINE NEWWORK1 IS +C CALLED TO READ THE PATIENT DATA FROM FILE 27, AND CONVERT IT TO +C PATIENT DATA ON FILE 37, WITH EACH STEADY STATE DOSE INDICATOR +C RESULTING IN AN EXTRA 100 DOSE SETS (WITH THE NEGATIVE DOSE TIME +C LEFT IN - SEE COMMENTS BELOW). NOTE THAT THIS SUBROUTINE NEWWORK1 +C IS THE SAME AS IN THE CURRENT NPAG "ENGINE" MODULE, npageng25.f, +C EXCEPT IT READS FILE 27 AND WRITES TO FILE 37, RATHER THAN READING +C FROM FILE 23 AND WRITING TO FILE 27; ARRAY TIMOBREL IS NOT +C ESTABLISHED IN NEWWORK1, AND NOT PASSED AS AN ARGUMENT (IT IS NOT +C NEEDED IN THIS PROGRAM); MAXSUB IS ALSO NOT PASSED AS AN +C ARGUMENT (IT IS NOT NEEDED); NSUB IS NOT PASSED AS AN ARGUMENT (IT +C IS NOT NEEDED); AND COMMON/DOSEOBS AND THE ARRAYS IN IT ARE DELETED +C (THEY ARE NOT NEEDED). + +C NOTE THAT THIS NEWWORK1 ROUTINE IS INCLUDED IN THIS MODULE, AS IS +C SUBROUTINE ORDERDELTA. + +C 2. SUBROUTINE FILREAD IS CHANGED TO READ FILE 37, RATHER THAN +C FILE 27. NOTE THAT FILE 37 IS CLOSED JUST BEFORE THE RETURN STATEMENT +C IN THE MAIN OF THIS MODULE. + +C 3. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN +C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx +C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING +C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT +C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT +C USING COMMON/ERR/ERRFIL. + +C 4. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, +C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET +C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED +C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT +C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS +C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL +C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 +C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO +C MAXNUMEQ. + +C 5. COMMON/OBSER IN MAIN IS REMOVED. IT WASN'T NEEDED. SIMILARLY +C ALL THE ARRAYS IN THIS COMMON ARE NO LONGER DIMENSIONED. + + + +C----------------------------------------------------------------------- + +C NPAGFULL.FOR 3/26/13 + +C NPAGFULL IS BASED ON THE npageng22.f PROGRAM. IT RUNS AN NPAG +C ANALYSIS IN ORDER TO OBTAIN THE FULL POSTERIOR DENSITY OF A SUBJECT +C GIVEN AN APRIORI DENSITY. ALL OTHER CODE IN npageng22.f IS +C REMOVED (E.G., ALL EXTRA CALCULATIONS, ALL WRITING TO FILES, ETC.). + +C NOTE THAT ALL INFO NEEDED BY THIS ROUTINE IS INCLUDED IN THE +C CALLING ARGUMENTS; IN PARTICULAR, npag102.inp IS NOT READ. + +C THIS COMPARES TO NPAGBAY, WHICH CALCULATED THE 0-CYCLE BAYESIAN +C POSTERIOR OF THE SUBJECT. + +C NOTE ALSO THAT ALL DIMENSIONS OF 500 RELATED TO DOSE EVENTS HAVE BEEN +C CHANGE TO 5000. + +C----------------------------------------------------------------------- + +c npageng22.f 11/8/12 + +c npageng22 has the following change from npageng21: + +c 1. It comments out the PAUSE statement following Format 164 in +c Subroutine emint. Reason: the program will not complete properly if +c it is run under Pmetrics (which cannot supply a keyboard response +c during a run). + +c 2. Formats 1657 and 7124 are changed to show that the output file +c is made by npageng22 rather than npageng21. + +c----------------------------------------------------------------------- + +c See npageng22.f code for all the comments from npageng21.f back +c to m2_5calf.f. + + +C----------------------------------------------------------------------- + +C*********************************************************************** + + SUBROUTINE NPAGFULL(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK, + 1 CORDEN,NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM0, + 2 NGRID,NACTVE,PYJGX,DENSTOR,CORDLAST,MAXCYC) + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + DIMENSION WORK(MAXGRD),WORKK(MAXGRD),PYJGX(MAXSUB,MAXGRD), + 1 DENSTOR(MAXGRD,4),CORDEN(MAXGRD,MAXDIM+1), + 2 CORDLAST(MAXGRD,MAXDIM+1), YO(594,MAXNUMEQ),SIG(594,MAXNUMEQ), + 3 AB(30,2),X(30),VALFIX(20),IRAN(32),PX(32),ATOL(20), + 4 C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ),C3(MAXNUMEQ),ATOLL(20) + +C NOTE THAT ALL DIMENSIONS = 150 HAVE BEEN CHANGED TO 594, SINCE THIS +C NO. REPRESENTS THE TOTAL NO. OF OBSERVATIONS (AND THE MAX. NO IS +C MAXNUMEQ OUTPUT EQUATIONS x 99 OBSERVATIONS/EQ). THIS COULD BE CHANGED +C TO NUMEQT*MAXOBS, BUT IT WOULD BE MORE TROUBLE THAN IT'S WORTH TO +C MAKE THESE DIMENSIONS VARIABLE. + + CHARACTER ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + COMMON SIG + COMMON/TOUSER/NDIMM,MFF,RTOLL,ATOLL + COMMON/NXER/NXE +C NXE FROM ABOVE COMMON IS NO. OF TIMES XERRWD IS CALLED. + +C THE BLANK COMMON ABOVE IS SUPPLIED TO SUBROUTINE IDPC. +C COMMON/TOUSER IS SUPPLIED TO SUBROUTINE USERANAL IN idfixed.f. +C COMMON/OBSER/ IS SUPPLIED FROM SUBROUTINE FILREAD. +C NO! AS OF NPAGFULLA.FOR, COMMON/OBSER IS REMOVED FROM MAIN. IT IS +C UNNEEDED. SIMILARLY, TIMOB, DOSTIM, RS, Y00, AND BS ARE NO LONGER +C DIMENSIONED IN MAIN. + + + +C*********************************************************************** + +C----------------------------------------------------------------------- + + 2 FORMAT(A20) + 222 FORMAT(A3) + 2222 FORMAT(A5) + +C----------------------------------------------------------------------- + + NSUB = 1 + + NDIMM = NDIM + MFF = MF + RTOLL = RTOL + DO I = 1,NDIM + ATOLL(I) = ATOL(I) + END DO + +C THE ABOVE VALUES HAD TO BE ESTABLISHED SINCE THE SAME VARIABLES +C CANNOT BE IN COMMON STATEMENTS IF THEY ARE DUMMY CALLING ARGUMENTS. + + + + +C NOTE THAT THIS SUBROUTINE WAS CALLED BY BESTDOSxxx.FOR/MAIN, WHICH +C HAS ALREADY WRITTEN TO SCRATCH FILE 27 THE DATA FROM THE SINGLE +C SUBJECT WHOSE POSTERIOR DENSTIY IS TO BE CALCULATED, BASED ON THE +C PRIOR DENSITY INPUT PASSED TO THIS ROUTINE IN CORDEN. + + +c As of npageng14.f, tol is hardcoded to be 1.D-4. Previously, it +c was allowed to be any positive number .GE. 1.D-4. + + tol = 1.D-4 + + +C ESTABLISH ASSAY VALUES FROM ierrmod AND gamlam0. + + + gamma = 1.d0 + flat = 1.d0 + if(ierrmod .eq. 2) gamma = gamlam0 + if(ierrmod .eq. 3) gamma = gamlam0 + if(ierrmod .eq. 4) flat = gamlam0 + + igamma = 0 + gamdel=0.1 + if(ierrmod.eq.1) gamdel=0.d0 + + +C CHANGE NGRID TO BE MAXGRD, IF IT IS > MAXGRD. + +C???DEBUG 3/23. NGRID IS NOT A DIMENSION --> IT IS NEEDED TO BE +C WHATEVER IT IS FROM THE NPAGDENFILE INPUT INTO THE BESTDOS MAIN +C MODULE. SO DON'T LIMIT IT TO BE .LE. MAXGRD. + +C if(ngrid .gt. MAXGRD) then + +C write(6,*) + +C write(6,*) 'requested NGRID = ',NGRID +C write(6,*) 'maximum allowable is MAXGRD = ',MAXGRD +C write(6,*) 'resetting NGRID = ',MAXGRD +C write(6,*) 'to fit in available storage' +C write(6,*) + +C ngrid = MAXGRD + +C endif + + + +C CALCULATE VOLSPA, THE 'VOLUME' OF THE INTEGRATION SPACE (NEEDED IN +C CALLS TO NOTINT). + + VOLSPA=1.D0 + DO 170 I=1,NVAR + 170 VOLSPA = VOLSPA*(AB(I,2)-AB(I,1)) + + +C NOTE IN THIS PROGRAM, THE USER WILL ALWAYS INPUT A PRIOR DENSITY +C WITH VALUES IN CORDEN, SO THE ICYCLE = 0 CODE HAS BEEN REMOVED. + + +C AS OF npageng19.f, PRESET NACTLAST TO BE NACTVE. THIS WAY, IN THE +C UNLIKELY EVENT THAT THE FIRST CYCLE OF A RUN HAS A HESSIAN ERROR +C (WHICH MEANS THAT WHEN CONTROL COMES BACK TO MAIN FROM SUBROUTINE +C emint, IT IS TRANSFERRED TO LABEL 900 AND THEREFORE SKIPS THE +C cbegin statistics SECTION WHERE NACTLAST = NACTVE IS SET), THERE +C WON'T BE A PROBLEM WHEN NACTVE IS SET = NACTLAST JUST BELOW LABEL +C 900. IN PREVIOUS PROGRAMS, IN THE ABOVE SITUATION, BELOW LABEL 900, +C NACTVE = NACTLAST WOULD RESULT IN NACTVE BEING SET = 0 SINCE +C NACTLAST WAS UNITIALIZED. + + + NACTLAST = NACTVE + + + prefobj=-1.d30 + prebig=-1.d30 + + +C SET ICYCLE = 0. THE PROGRAM WILL RUN UP TO MAXCYC CYCLES. + + ICYCLE = 0 + +C CORDEN HOLDS, IN ITS FIRST NACTVE ROWS, THE STARTING JOINT DENSITY +C AND COORDINATE VALUES. FOR K=1,NACTVE, CORDEN(K,J) = JTH COORDINATE +C OF THE KTH ACTIVE POINT, J=1,NVAR; AND CORDEN(K,NVAR+1) IS THE +C ASSOCIATED DENSITY FOR THE KTH ACTIVE POINT. + +C IF ICYCLE .GT. 0, CORDEN WAS READ IN. +C IF ICYCLE = 0, NACTVE=NGRID, AND CORDEN WAS FILLED AT LABEL 30 ABOVE. +C IN THIS CASE, THE DENSITY IS UNIFORM, SO ALL +C CORDEN(K,NVAR+1) VALUES = 1/VOLSPA, K=1,NACTVE. + + +C IPRED=11 + ICYCLE +C JCOL=0 + ITEST=0 + +C IPRED IS THE CYCLE NO. WHERE THE NEXT 2-CYCLE PREDICTION +C ALGORITHM STARTS (IT IS NO LONGER USED). JCOL = COLUMN NO. OF DENSTOR +C IN WHICH IS STORED THE DENSITY OF ONE OF THE 2-CYCLES USED IN THE +C PREDICTION (IT IS NO LONGER USED). IT IS SET = 0 ABOVE, SINCE NO +C STORAGE IS REQUIRED UNTIL CYCLE NO. 11 + + +C (SEE BELOW). ITEST=0 --> THE NEXT CYCLE IS NOT (INITIALIZED) TO BE +C A TEST CYCLE (SEE CODE BELOW WHEN ITEST=1,2, OR 3). + +C NEW FOR m2_13cal.f: NSTORE SET = 0. NSTORE IS THE NO. OF GRID +C POINTS, WHOSE P(YJ|X) VALUES HAVE BEEN STORED IN PYJGX IN LOOP 800. +C THIS NO. CAN BE CHANGED BY THE 'CONDENSING' CODE BELOW, SINCE +C INACTIVE POINTS ARE THROWN OUT. + + NSTORE=0 +cadapt initialize grid resoution to 20% + resolve=0.20 + + + 1001 ICYCLE=ICYCLE+1 + + +cgam3 +10001 continue + +c above is new entry point for gammaplus/minus eps tries + itest = 0 + + +cadapt reset number of stored points to that before expansion +c nstore=nstoresv + + +C 1239 FORMAT(///' CYCLE NO.',I5,/) + +C ICYCLE IS THE NUMBER OF THE NEXT CYCLE TO BE RUN. +C +C THIS IS WHERE EACH NEW CYCLE STARTS (FOR EACH CYCLE, THE DENSITY OF +C X IS UPDATED FROM THE PREVIOUS DENSITY ESTIMATE, USING THE +C OBSERVED SUBJECT DATA FROM THE INPUT DATA FILES WHICH ARE PASSED TO +C SUBROUTINE IDPC BELOW. +C + + +C START THE SUBJECT LOOP. + + + +C REWIND SCRATCH FILE 27 WHICH HAS ALL THE SUBJECT DATA FILES +C CONCATENATED ON IT, IN ORDER. ACTUALLY THERE IS ONLY NSUB = 1 +C SUBJECT IN THIS RUN. + + + + REWIND(27) + +C PUT THE SUBJECT'S DATA ONTO FILE 37 BY CALLING SUBROUTINE NEWWORK1 +C (SIMILAR ROUTINE TO THE ONE IN npageng25.f, EXCEPT IT READS FILE 27 +C AND WRITES TO FILE 37, RATHER THAN READING FROM FILE 23 AND WRITING +C TO FILE 27). NOTE THAT IT HAS NO ARGUMENTS; NONE ARE NEEDED IN THIS +C PROGRAM. + +C NOTE THAT IF THE SUBJECT FILE HAS NO STEADY STATE DOSE INDICATORS, IT +C WILL NOT BE CHANGED; IF IT DOES, IT WILL BE ALTERED TO INCLUDE AN +C EXTRA 100 DOSES SETS FOR EACH STEADY STATE DOSE INDICATOR. NOTE THAT +C SUBROUTINE NEWWORK1 WILL LEAVE IN THE NEGATIVE DOSE TIME (WHICH IS +C THE STEADY STATE DOSE INDICATOR) BECAUSE THE ID ROUTINES NEED TO SEE +C THIS INDICATOR TO KNOW THAT A STEADY STATE DOSE SET IS COMING. + + OPEN(37) + + + CALL NEWWORK1 + REWIND(37) + + + +C NOBTOT WILL BE THE RUNNING TOTAL OF ALL NON-MISSING OBSERVED VALUES +C OVER ALL THE NSUB SUBJECTS. THIS IS NEEDED TO CALCULATE BIC BELOW. + + NOBTOT = 0 + + + DO 1000 JSUB=1,NSUB + + + +C CALL SUBROUTINE FILREAD TO READ, FOR THIS SUBJECT, FROM SCRATCH FILE +C 37, THE NO. OF OBSERVATION TIMES (NOBSER) AS WELL AS THE +C OBSERVED VALUES THEMSELVES: YO(I,J) = THE 'NOISY' OBSERVED VALUES +C FOR THIS SUBJECT; I=1,NOBSER, J=1,NUMEQT. THESE OBSERVED VALUES ARE +C USED ONLY TO CALCULATE THE ASSAY STANDARD DEVIATIONS (USING THE +C VECTORS, C0,C1,C2,C3, WHICH ARE ALSO READ IN). THE REST OF THE INFO +C IN THE SUBJECT DATA FILE IS PASSED IN COMMONS TO THE IDPC MODULE +C SUBROUTINES. + + CALL FILREAD(NOBSER,YO,C0,C1,C2,C3) + +C FIND THE ASSAY STANDARD DEVIATIONS FOR THIS SUBJECT. FOR EACH +C OF THE NOBSER*NUMEQT OBSERVED VALUES (EXCEPT THAT YO(I,J) = -99 --> +C OUTPUT EQ. J HAS NO OBSERVED LEVEL FOR OBSERVATION TIME I), +C Y, SIG = C0 + C1*Y + C2*Y**2 + C3*Y**3. +C NOTE THAT, THEORETICALLY, SIG SHOULD BE A CUBIC FNT. OF +C THE 'TRUE' OBSERVED VALUES, NOT THE 'NOISY' OBSERVED VALUES (BUT THE +C 'TRUE' VALUES ARE UNKNOWN). + +C ALSO, CALCULATE SIGFAC, THE PRODUCT OF THE NON-MISSING STD. DEV.'S +C (A NON-MISSING S.D. IS ONE FOR WHICH THE CORRESPONDING YO(I,J) IS +C .NE. -99, THE MISSING VALUE CODE). +C INITIALIZE SIGFAC=1, AND THEN UPDATE IT FOR EACH NON-MISSING +C OBSERVATION. + +C MISVAL WILL BE THE RUNNING TOTAL OF MISSING VALUES AMONG ALL THE +C NUMEQT x NOBSER POTENTIAL OBSERVED LEVELS. + + MISVAL = 0 + + SIGFAC=1.D0 + + DO 140 I=1,NOBSER + DO 140 J=1,NUMEQT + + Y = YO(I,J) + +C IF Y = -99, IT MEANS THAT OUTPUT EQ. J HAD NO VALUE AT OBSERVATION +C TIME I. IN THIS CASE, IGNORE THIS Y AND INCREASE MISVAL BY 1. + + + IF(Y .EQ. -99) THEN + MISVAL = MISVAL+1 + GO TO 140 + ENDIF + +C NOTE: FOR EACH SUBJECT, MUST ENSURE THAT ALL THE STD DEV'S ARE NON- +C ZERO. OTHERWISE, THE PROGRAM WILL BLOW UP! THIS IS BECAUSE +C P(YJ|X) INVOLVES SQUARED DIFFERNCES BETWEEN OBSERVED Y'S AND +C EXPECTED Y'S (FOR EACH X GRID POINT)...EACH DIFFERENCE +C NORMALIZED (I.E., DIVIDED) BY THE VARIANCE OF THE RESPECTED +C OBSERSATION. + +C SEE M2_17CAL.F CODE FOR COMMENTS ON HOW A STD. DEV. COULD = 0. + +C ALSO TEST TO MAKE SURE NO STD. DEV. < 0, SINCE SIGFAC BEING NEGATIVE +C WOULD RESULT IN A NEGATIVE PROBABILITY (SEE PYJGX CALCULATION BELOW). + + SIG(I,J) = C0(J)+C1(J)*Y+C2(J)*Y*Y+C3(J)*Y**3 +cgam4 + if(ierrmod.eq.2) sig(i,j) = sig(i,j)*gamma + if(ierrmod.eq.3) sig(i,j)=dsqrt(sig(i,j)**2 + gamma**2) + if(ierrmod.eq.4) sig(i,j) = gamma*flat + + IF(SIG(I,J) .EQ. 0) THEN + + + + WRITE(*,2345) JSUB +2345 FORMAT(//' A S.D. IS 0 FOR JSUB = ',I5,'. RERUN THE '/ + 1' PROGRAM WITH C0 NOT = 0 FOR THIS SUBJECT, OR WITH THIS'/ + 2' SUBJECT ELIMINATED.'// + 3' THIS IS IN SUBROUTINE NPAGFULL.'/) + CLOSE(37) + + OPEN(47,FILE=ERRFIL) + WRITE(47,2345) JSUB + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + IF(SIG(I,J) .LT. 0) THEN + + + + WRITE(*,2346) JSUB +2346 FORMAT(//' A S.D. < 0 FOR JSUB = ',I5,'. RERUN THE '/ + 1' PROGRAM WITH A BETTER CHOICE FOR THE ASSAY ERROR POLYNOMIAL'/ + 2' COEFFICIENTS.'// + 3' THIS IS IN SUBROUTINE NPAGFULL.'/) + CLOSE(37) + + OPEN(47,FILE=ERRFIL) + WRITE(47,2346) JSUB + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + SIGFAC=SIGFAC*SIG(I,J) + + 140 CONTINUE + +C NOTE THAT SIGFAC WAS CALCULATED IN LOOP 140 ABOVE, AND THAT OFAC IS +C NOW THE RESULT OF (NOBSER*NUMEQT - MISVAL) VALUES. + + OFAC=2.506628274631**(NOBSER*NUMEQT - MISVAL) + NOBTOT = NOBTOT + NOBSER*NUMEQT - MISVAL + + +C NOTE THAT 2.5066... = SQRT(2*PI). + +C FOR EACH SUBJECT, AND EACH GRID POINT, CALL IDPC, A SUBROUTINIZED +C VERSION OF THE ADAPT PROGRAM ID3 TO CALCULATE THE SUM OF SQUARES OF +C DIFFERENCES BETWEEN THE OBSERVED VALUES AND PREDICTED (BY THE MODEL) +C VALUES (NORMALIZED BY THE ASSAY VARIANCE OF EACH OBSERVATION) ... + + 8888 FORMAT(' ',' CYCLE ',I5,', SUBJECT ',I5,' ... % COMPLETED = ', + 1F8.2) + XNEXT = 1.D0 + +C SEVERAL CHANGES FOR m2_13cal.f ARE IN LOOP 800. + + DO 800 IG=1,NACTVE + + +C PRINT TO THE SCREEN THE UPDATE ON WHAT % OF GRID POINTS HAVE BEEN +C CALCULATED IF NACTVE > NSTORE (I.E., IF NACTVE .LE. NSTORE --> +C ALL P(YJ|X)'s ARE ALREADY STORED INTO PYJGX AND SO THIS 8OO LOOP +C WILL GO VERY FAST. + + IF(NACTVE .GT. NSTORE) THEN + +C PRINT GRID PT. AND % COMPLETED TO SCREEN. + XPER=IG*100.D0/NACTVE + + IF(XPER .GE. XNEXT) THEN + + IF(ICYCLE.eq.1) THEN + WRITE(*,8888) ICYCLE,JSUB,XPER + IF(NXE .GT. 0) WRITE(*,1254) NXE + 1254 FORMAT(' TOTAL NO. OF NUM. INTEG. WARNINGS IS ',I20) + ENDIF + + XNEXT=XNEXT+1.D0 + + ENDIF + + ENDIF + + IF(IG .LE. NSTORE) GO TO 700 + + +C ESTABLISH THE IGTH GRID POINT. IT IS STORED IN ROW IG OF +C CORDEN. + + DO J=1,NVAR + X(J)=CORDEN(IG,J) + END DO + +C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO +C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL +C MAKEVEC TO DO THIS. + + + CALL MAKEVEC(NVAR,NOFIX,IRAN,X,VALFIX,PX) + + CALL IDPC(PX,W) + +C W RETURNS AS THE SUM OF: +C ((YO(I,J)-H(I,J))/SIG(I,J))**2, WHERE H(I,J) = PREDICTED VALUE OF THE +C JTH OUTPUT EQ AT THE ITH OBSERVATION TIME, ASSUMING THE IGTH GRID +C POINT, X, ... OVER THE NOBSER x NUMEQT QUANTITIES ABOVE WHICH DON'T +C HAVE YO(I,J) = -99 (WHICH MEANS THAT OUTPUT EQ. J HAS NO OBSERVED +C LEVEL FOR TIME I). + +C CALCULATE P(YJ|X) FOR X-GRID POINT NO. IG. + +C THIS NEXT TEST IS FOR THE PC. AS AN EXAMPLE, THE COMPAC COMPUTER +C CANNOT HANDLE ARGUMENTS TO DEXP WHICH ARE SMALLER THAN -11354. SINCE +C THE ARGUMENT TO DEXP BELOW IS -.5*W, SET PYJGX = 0 IF W IS .GT. +C 22708. + +C SEE CODE AFTER CALCULATION OF P(YJ) TO SEE WHAT HAPPENS IF ALL THE +C P(YJ|X) ARE SET = 0. + +C NOTE THAT WORKK WILL ALWAYS BE SET = P(YJ|X=IG GRID PT), WHICH IS +C NEEDED IN THE CALCULATION OF DXI (NOTE DXI NOT USED AS OF +C bignpaglap1.f) SINCE PYJGX WILL NOT BE COMPLETE IF NACTVE > MAXGRD. + + IF(IG .LE. MAXGRD) PYJGX(JSUB,IG)=0.D0 + WORKK(IG) = 0.D0 + + IF(W .LE. 22708.D0) THEN + IF(IG .LE. MAXGRD) PYJGX(JSUB,IG) = DEXP(-.5D0*W)/SIGFAC/OFAC + WORKK(IG) = DEXP(-.5D0*W)/SIGFAC/OFAC + ENDIF + +C CALCULATE P(X,YJ) FOR X-GRID POINT NO. IG. PUT IT INTO WORK(IG). + + IF(IG .GT. MAXGRD) THEN + WORK(IG) = WORKK(IG)*CORDEN(IG,NVAR+1) + GO TO 800 + ENDIF + + 700 WORK(IG)=PYJGX(JSUB,IG)*CORDEN(IG,NVAR+1) + + WORKK(IG) = PYJGX(JSUB,IG) + + 800 CONTINUE + + +C CALCULATE P(YJ), A SCALAR WHICH IS THE INTEGRAL OF P(X,YJ) OVER + +C X-SPACE. + +C CALL NOTINT, AN INTEGRATION ROUTINE. THE +C FOLLOWING IS SUPPLIED TO THIS ROUTINE: +C VOLSPA = VOLUMNE OF THE INTEGRATION SPACE. +C NGRID = NO. OF ORIGINAL GRID POINTS. +C NACTVE = NO. OF ACTIVE GRID POINTS. +C WORK(I), I=1,NACTVE = VALUE OF THE FUNCTION TO BE INTEGRATED, AT +C THE ITH GRID POINT. +C MAXGRD = THE DIMENSION OF WORK. + + CALL NOTINT(VOLSPA,NGRID,NACTVE,WORK,MAXGRD,PYJ) + + +C IF PYJ RETURNS AS 0, IT IS BECAUSE P(X,YJ)=WORK IS 0 IN ALL ITS +C NACTVE ENTRIES. THIS OCCURS WHEN EACH OF NACTVE VALUES OF W (WHICH +C RETURNS FROM THE CALLS TO IDPC) IS LARGER THAN 1416 (SINCE P(YJ|X) +C INVOLVES e RAISED TO THE POWER -.5*W, AND e RAISED TO A POWER +C SMALLER THAN -708 IS SET TO 0 BY, FOR EXAMPLE, THE COMPAC COMPUTER). +C + +C IN CASE THIS HAPPENS, PRINT A MESSAGE TO THE USER AND STOP. +C + IF (PYJ .EQ. 0.D0) THEN + + + + WRITE(*,26) + 26 FORMAT(//' FOR THIS SUBJECT, THE PROB. OF THE OBSERVED'/ + 1' CONCENTRATIONS (FOR THE INDICATED DOSAGE REGIMEN), GIVEN EACH '/ + 2' AND EVERY GRID POINT IN THE ESTABLISHED GRID, IS 0. THE '/ + 3' PROGRAM STOPS. THE USER SHOULD CONSIDER INCREASING THE'/ + 4' NO. OF GRID POINTS ALLOWED (HARDCODED INTO MAIN), AND/OR '/ + 5' NARROWING THE GRID BOUNDARIES OF THE VARIABLES, AND/OR '/ + 6' INCREASING THE SIZES OF (C0,C1,C2,C3), THE ASSAY NOISE '/ + 7' COEFFICIENTS. ALL OF THESE CHANGES WILL HAVE THE EFFECT OF'/ + 8' MAKING SOME OF THE ABOVE CONDITIONAL PROBABILITES LARGER.'// + 9' THIS IS IN SUBROUTINE NPAGFUL.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,26) + CLOSE(47) + + + + CALL PAUSE + STOP + + + + ENDIF + + 1000 CONTINUE + + +c begin optimization +cgam5 +cgam5 - from here (immediately after 1000 CONTINUE to +cgam5 - immediately before c end optimization was lifted +cgam5 - from gamadapt1.f, replacing old material beteen these limits + igamma = igamma + 1 + if(ierrmod.eq.1) igamma=1 +csdsc - added April 2, 2000 +c con first iteration, call hte interior point method + + if(mod(igamma,3).eq.1) then + + gammab = gamma + gammap = gamma * (1.d0+gamdel) + gammam = gamma / (1.d0+gamdel) + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,1, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + + nactve = keep + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. + +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + + + fobjbase = fobj + + + nactve0 = nactve +c new on Jan 2, 2002 - save otpimal solution in denstor(1,4) +c so that stat program can work on best of base, up, and down +c solutions + do i=1,nactve + denstor(i,4)=corden(i,nvar+1) + enddo + nstore = 0 + fobjbest = fobjbase + + if(ierrmod.eq.1) go to 14001 + gamma = gammap + go to 10001 + + endif +cgamma above endif is for mod(igamma,3).eq.1 case + + if(mod(igamma,3).eq.2) then + + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + fobjplus = fobj + +c new Jan 2, 2002 - save solution if fobjplus is better than fobjbase + if(fobjplus.gt.fobjbest) then + fobjbest = fobjplus + do i=1,nactve + + denstor(i,4) = corden(i,nvar+1) + enddo + endif + gamma = gammam + + go to 10001 + + endif + + if(mod(igamma,3).eq.0) then + + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. + +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + + fobjminu = fobj + + if(fobjminu.gt.fobjbest) then + fobjbest = fobjminu + do i=1,nactve + denstor(i,4) = corden(i,nvar+1) + enddo + endif + + endif + +cgamma - above statement changed from "nstore = nactve" to force +c reevaluation of all points. + +c now temporairily reset to gamma + gamma = gammab + fobj = fobjbase + if(fobjplus.gt.fobjbase) then + gamma = gammap + + fobj = fobjplus + gamdel = 4.*gamdel + endif + + if(fobjminu.gt.fobjbase) then + gamma = gammam + fobj = fobjminu + gamdel = 4.*gamdel + endif + gamdel = gamdel*0.5 + if(gamdel.lt.0.01) gamdel=0.01 +14001 continue +cgam5 above label is entry point for ierrmod = 1 (no gamma) case + +c corden(*,nvar+1) sums to 1 when it comes out of emint +c Now reset forden(i,nvar+1) to best of three solutions +c and normalize to funny BIGNPEM factor + fact=ngrid/volspa + do i=1,nactve + corden(i,nvar+1)=fact*denstor(i,4) + enddo + + +cend optimization + + +cbegin statistics + + +c now we compute all hte statistical stuff using this distribution +c and the full nactve (before condensation) points. +c Later, in the condensation performed just before the grid refienment +c and subsequent expansion, we will condense by just using the +c 'keep' flags in DENSTOR(i,1) that emint left there. The density will +c not be updated to refelct this cahnge (there is no need) +c until the next call to emint + + +c As of npageng18.f, save CORDEN to CORDLAST AND NACTVE TO NACTLAST. +c The reason is that if, somewhere during the next cycle's calculations +c (during one of the calls to Subroutine emint), a Hessian Matrix is +c singular, then IHESS will be set = -1, and the program will stop. +c And in this case, the program must be able to write out all of the +c information from this cycle (the last completed cycle). And that +c means that the CORDEN from this cycle (which will be stored into +c CORDLAST), and NACTVE (store into NACTLAST) should be used in the +c call to Subroutine SUBRES in loop 7000. Otherwise, the CORDEN and +c NACTVE used in that call would have already partly updated in the +c next cycle before the Hessian error occurred. + + DO I = 1,NACTVE + DO J = 1,NVAR+1 + CORDLAST(I,J) = CORDEN(I,J) + END DO + END DO + + NACTLAST = NACTVE + + + IF(MAXCYC .EQ. 0) GO TO 900 + +C Starting with bigmlt1.f, this is a jump point. + + +cend statistics +cbegin control +c we are now done wtih statistics - this is the best place to +c check for whether we can exit - if so , last printed statistic +c will agree with current density corden, and corden is still +c correct (e.g. after condensation-expansion, it is no longer +c correct until we call emint again) +cint.9 control section to check for exit criteria, resolution +c refinement, and end of major cycles + +cint9.a first, we exit if we have reached maxcyc on cycle counter + +C SET IMAXCYC = 0; IF IT CHANGES TO 1, IT MEANS THAT MAXCYC CYCLES +C HAVE BEEN RUN, AND THE PROGRAM WILL STOP. + + IMAXCYC = 0 + + if(icycle .ge. maxcyc) then + + + +C SET IMAXCYC = 1 --> MAXCYC WAS REACHED. + + IMAXCYC = 1 + +C COMMENT OUT THE GO TO 900 STATEMENT BELOW SINCE EVEN IF ICYCLE +C = MAXCYC, THE PROGRAM STILL NEEDS TO TEST TO SEE IF CONVERGENCE +C WAS ACHIEVED IN THE FINAL CYCLE. +C go to 900 + + endif + +c The above endif is for the if(icycle .ge. maxcyc) condition. + + +cint9.b second, we check improvement from last cycle + + ximprove=fobj-prefobj + prefobj = fobj + +cint9.c if ximprove is too low, refine the resolve criterion + + if(dabs(ximprove) .le. tol .and. resolve .gt. 0.0001) then + resolve=resolve*0.5 + endif + +cint9.d check to see if resolve bottoms out - if so, start a new +c major cycle by resetting it to its highest allowable value, or +c exit if the improvment from the last major cycle is too small ... + +C AND EXIT IF IMAXCYC = 1 (SEE ABOVE; THIS MEANS THAT THE MAX. NO. +C OF CYCLES HAS ALREADY BEEN RUN AND THE ONLY REASON THIS PART OF THE +C CODE IS BEING RUN IS TO SEE IF CONVERGENCE WAS ACHIEVED IN THE FINAL +C CYCLE. + + if(resolve.le.0.0001) then + + +c saveres = resolve + resolve=0.2 + checkbig = fobj - prebig + prebig =fobj + +C NOTE THAT THE +C CONVERGENCE CRITERION IS THAT DABS(CHECKBIG) .LE. .01. + + +C WRITE(*,1023) ICYCLE +C1023 FORMAT(/' FOR CYCLE NO, ',I6,' THE CONVERGENCE CRITERION AND ME +C 1DIANS ARE: ') + +C WRITE(*,1024) DABS(checkbig) + +C1024 FORMAT(1X,G14.4,' <-- CONVERGENCE OCCURS WHEN THIS NO. < .01') + + + if(dabs(checkbig) .le. 0.01) then + +C CONVERGENCE HAS BEEN ACHIEVED. + + go to 900 + + endif + + endif + +c above endif is for the if(resolve .le. .0001) condition. + + +C IF IMAXCYC = 1, THE MAX. NO. OF CYCLES HAVE ALREADY BEEN RUN --> +C GO TO 900. THE ONLY REASON THIS PART OF THE CODE WAS BEING RUN IS TO +C SEE IF CONVERGENCE WAS ACHIEVED IN THIS FINAL CYCLE, AND THAT WAS +C JUST TESTED ABOVE. + + IF(IMAXCYC .EQ. 1) GO TO 900 + + +cend control +cbegin expansion + + nactveold=nactve + + do ipoint=1,nactveold +c first, divide current probability into 2*nvar+1 pieces + pcur=corden(ipoint,nvar+1)/(2*nvar+1) +c update original point + corden(ipoint,nvar+1)=pcur + do ivar=1,nvar + del=(ab(ivar,2)-ab(ivar,1))*resolve +c create first new trial point at -eps in coordinate ivar + do i=1,nvar + corden(nactve+1,i)=corden(ipoint,i) + enddo + corden(nactve+1,ivar)=corden(nactve+1,ivar)-del + corden(nactve+1,nvar+1)=pcur + ntry=nactve+1 +c icheck that new point is at least minimally distant from old points + + call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) +c only keep trial lower point if it lies above lower bound and satisfies +c minimal distance requirement + if(corden(nactve+1,ivar).ge.ab(ivar,1)) then + if(iclose.eq.0) nactve=nactve+1 + endif +c now create second trail point at +eps in coordinate ivar + do i=1,nvar + corden(nactve+1,i)=corden(ipoint,i) + enddo + corden(nactve+1,ivar)=corden(nactve+1,ivar)+del + corden(nactve+1,nvar+1)=pcur +c only keep upper point if it lies below upper bound and +c satisfies distance requirement + ntry=nactve+1 + call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) + if(corden(nactve+1,ivar).le.ab(ivar,2)) then + if(iclose.eq.0) nactve=nactve+1 + endif + enddo +c above enddo for loop over ivar=1,nvar + + enddo +c above enddo for loop over ipoint=1,nactveold + + +cend expansion +c go to begin new cycle + + prefobj=fobj + + + + GO TO 1001 + + 900 continue + +C AS OF npageng18.f, CONTROL CAN BE TRANSFERRED TO LABEL 900 DIRECTLY +C AFTER RETURNING FROM A CALL TO SUBROUTINE emint. THIS HAPPENS WHEN +C IHESS = -1, WHICH MEANS THAT THE HESSIAN MATRIX IN THE INTERIOR +C POINT EM ALGORITHM WAS SINGULAR. RATHER THAN SIMPLY STOPPING AS IT +C DID PREVIOUSLY, NOW THE PROGRAM WILL CREATE THE OUTPUT FILES BEFORE +C STOPPING ... BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C FIRST, WRITE THE REASON FOR STOPPING AS ICONVERGE = 3 BELOW. THEN +C RESET CORDEN BACK TO CORDLAST (SEE ABOVE), WHICH WAS THE CORDEN +C AT THE END OF THE PREVIOUS CYCLE. +C FOR NPAGFULL, OF COURSE, NO WRITING OCCURS TO OUTPUT FILES. + + +C WRITE WHY THE PROGRAM STOPPED. + + IF(IHESS .EQ. -1) THEN + + NACTVE = NACTLAST + + DO I = 1,NACTVE + DO J = 1,NVAR+1 + CORDEN(I,J) = CORDLAST(I,J) + END DO + END DO + + GO TO 910 + + ENDIF + + +C Starting with bigmlt1.f, this is an entry point to continue +c calculations + + + 910 CONTINUE + +cbegin endgame +c we can only arrive here from the control section, which menas +c that we ahve completed optimizaiton but not done the subsequent +c expansion. This means that the density is correct, and we can safely +c just write it out and exit. + + WRITE(*,1294) ICYCLE,MAXCYC + 1294 FORMAT(/' NPAG RAN ',I6,' OUT OF A MAXIMUM POSSIBLE ',I6/ + 1' CYCLES TO OBTAIN THE POSTERIOR DENSITY.') + +C FOR NPAGFULL, THE DENSITY IS CORRECT AT THIS POINT. SO RETURN TO +C THE BESTDOSxxx PROGRAM. + +C AS OF NPAGFULLA.FOR, CLOSE FILE 37. + + CLOSE(37) + + + + RETURN + END + + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE FILREAD(NOBSER,YO,C0,C1,C2,C3) + +C FILRED IS CALLED BY MAIN TO READ THE PORTION OF +C SCRATCH FILE 37 WHICH APPLIES TO THE SUBJECT UNDER CONSIDERATION. THE +C 'POINTER' FOR FILE 37 IS IN THE PROPER POSITION TO BEGIN READING THE +C INFO FOR THE DESIRED SUBJECT. + + PARAMETER(MAXNUMEQ=7) + + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION TIM(594),SIG(5000),RS(5000,34),YO(594,MAXNUMEQ), + 1 BS(5000,7),C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ), + 2 C3(MAXNUMEQ),YOO(594,MAXNUMEQ) + +C AS OF npageng13.f, THE FORMAT FOR THE WORKING COPY FILES IS: + + +C COL 1 = TIME +C COL 2 = IV FOR DRUG 1; COL 3 = PO FOR DRUG 1; +C COL 4 = IV FOR DRUG 2; COL 5 = PO FOR DRUG 2; +C ... EACH SUCCEEDING DRUG HAS AN IV FOLLOWED BY A PO COLUMN. +C NEXT NADD COLUMNS = ONE FOR EACH ADDITIONAL COVARIATE (ADDITIONAL +C REFERS TO ANY EXTRA COVARIATES BEYOUND THE 4 PERMANENT ONES IN +C COMMON DESCR (SEE BELOW). + + CHARACTER SEX*1,READLINE*300,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + + + + COMMON /OBSER/ TIM,SIG,RS,YOO,BS + COMMON /CNST/ N,ND,NI,NUP,NUIC,NP + COMMON /CNST2/ NPL,NUMEQT,NDRUG,NADD + COMMON /SUM2/ M,NPNL + COMMON/DESCR/AGE,HEIGHT,ISEX,IETHFLG + + +C INPUT IS: SCRATCH FILE 37, WHICH IS POSITIONED AT THE BEGINNING OF +C THE INFO FOR THE SUBJECT DESIRED. + +C OUTPUT ARE: + +C NOBSER = THE NO. OF OBSERVATIONS FOR THIS SUBJECT. +C YO(I,J),I=1,M; J=1,NUMEQT = NO. OF OUTPUT EQS; I=1,M, WHERE M = NO. +C OF OBSERVATION TIMES. +C [C0(J),C1(J),C2(J),C3(J)] = ASSAY NOISE COEFFICIENTS FOR OUTPUT EQ. +C J; J=1,NUMEQT. +C THE 4 DESCRIPTOR VALUES FOR THIS SUBJECT (AGE, SEX, HEIGHT, +C ETHNICITY FLAG) VIA COMMON/DESCR TO SUBROUTINES DIFFEQ/OUTPUT. +C VARIABLES/ARRAYS IN ABOVE COMMON STATEMENTS. + + +C AGE, SEX, HEIGHT, AND ETHNICITY FLAG ARE ON LINES 8-11. + + DO I=1,7 + READ(37,*) + END DO + + + READ(37,*) AGE + READ(37,2) SEX + 2 FORMAT(A1) + ISEX=1 + IF(SEX .EQ. 'F') ISEX=2 + READ(37,*) HEIGHT + READ(37,*) IETHFLG + +C READ THE NO. OF DRUGS FROM THE LINE WITH 'NO. OF DRUGS' AS ENTRIES +C 12:23. THEN READ NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE +C EVENTS, ETC. + + 1 FORMAT(A300) + 10 READ(37,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 + BACKSPACE(37) + + 3 FORMAT(T2,I5) + READ(37,3) NDRUG + + + IF(NDRUG .GT. 7) THEN + WRITE(*,124) + 124 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 7'/ + 1' DRUGS. THE PROGRAM IS NOW STOPPING. '/) + STOP + ENDIF + + READ(37,3) NADD + +C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND +C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE). + + NI = 2*NDRUG + NADD + + IF(NI .GT. 34) THEN + WRITE(*,123) + 123 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY COLUMNS IN '/ + 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ + + 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ + 3' NOW STOPPING. '/) + STOP + ENDIF + + READ(37,3) ND + + IF(ND .GT. 5000) THEN + WRITE(*,125) + 125 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 5000'/ + 1' DOSE EVENTS. THE PROGRAM IS NOW STOPPING. '/) + STOP + + ENDIF + + READ(37,*) + READ(37,*) + + IF(ND.EQ.0) GO TO 40 + + DO I = 1,ND + READ(37,*) SIG(I),(RS(I,J),J=1,NI) + + END DO + +C ASSIGN THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING +C COLUMN IN ARRAY BS. + + DO I=1,ND + DO J=1,NDRUG + BS(I,J)=RS(I,2*J) + END DO + END DO + +C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' +C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC. + + 40 READ(37,1) READLINE + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 + BACKSPACE(37) + + READ(37,3) NUMEQT + READ(37,3) M + + MAXOBDIM = 150 + IF(M .GT. MAXOBDIM) THEN + + WRITE(*,126) MAXOBDIM + 126 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ + 1' MANY OBSERVED VALUE TIMES. THIS NO. CANNOT EXCEED ',I5,'.'/ + 2' THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,126) MAXOBDIM + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + IF(NUMEQT .GT. MAXNUMEQ) THEN + + WRITE(*,127) MAXNUMEQ + 127 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ + 1' MANY OUTPUT EQUATION COLUMNS. THIS NO. CANNOT EXCEED ',I2,'.'/ + 2' THE PROGRAM IS NOW STOPPING. '/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,127) MAXNUMEQ + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + DO I=1,M + READ(37,*) TIM(I),(YO(I,J),J=1,NUMEQT) + END DO + +C PUT YO VALUES INTO YOO BECAUSE A DUMMY ARGUMENT CANNOT BE IN A +C COMMON STATEMENT. + + DO I=1,M + DO J=1,NUMEQT + YOO(I,J) = YO(I,J) + END DO + END DO + + NOBSER=M + +C AT THIS POINT, MUST SKIP THE COVARIATE INFO IN THE FILE, AND PROCEED +C TO READ THE ASSAY NOISE COEFFICIENTS BELOW THAT. + +C READ THE NUMEQT SETS OF ASSAY COEFFICIENTS JUST BELOW THE LINE +C WHICH HAS "ASSAY COEFFICIENTS FOLLOW" IN ENTRIES 1:25. + + 50 READ(37,1) READLINE + IF(READLINE(1:25) .NE. 'ASSAY COEFFICIENTS FOLLOW') GO TO 50 + + DO IEQ = 1,NUMEQT + READ(37,*) C0(IEQ),C1(IEQ),C2(IEQ),C3(IEQ) + END DO + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE CALGRD. 3/19. + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE INFAUR + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE GOFAUR + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE NOTINT(VOLSPA,NGRID,NACTVE,FUNC,MAXGRD,ESTINT) + IMPLICIT REAL*8(A-H,O-Z) + + DIMENSION FUNC(MAXGRD) +C +C THIS SUBROUTINE, CALLED BY MAIN, IS A MULTI-DIMENSIONAL INTEGRATOR. + +C +C INPUT ARE: + +C +C VOLSPA = 'VOLUME' OF THE INTEGRATION SPACE. +C NGRID = NO. OF GRID POINTS OVER WHICH THE INTEGRATION IS DONE. +C NACTVE = NO. OF CURRENTLY ACTIVE GRID POINTS. +C FUNC(I), I=1,NACTVE = VALUE OF THE FUNCTION TO BE INTEGRATED AT + +C THE ITH GRID POINT. +C MAXGRD = DIMENSION OF FUNC -- SEE EXPLATION IN MAIN. +C + +C OUTPUT IS: +C +C ESTINT = THE ESTIMATE OF THE NVAR-DIM INTEGRAL OF THE FUNCTION WHOSE +C VALUES ARE GIVEN IN FUNC. +C + SUM=0.D0 + DO 100 IG=1,NACTVE + 100 SUM=SUM+FUNC(IG) + ESTINT=VOLSPA*SUM/NGRID + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE STAZ +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE EQUIV + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE MAKEVEC (IT'S IN ANOTHER MODULE). +C + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE SUBRES + + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +C VODTOT.FOR 5-2-96 + +C VODTOT.FOR CONTAINS MODULES VODE.FOR AND VODEXT.FOR. + +C---------------------------------------------------------------------- + +*DECK DVODE + SUBROUTINE DVODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, + 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, + 2 RPAR, IPAR) + EXTERNAL F, JAC + DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK, RPAR + INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, + 1 MF, IPAR + DIMENSION Y(*), ATOL(*), RWORK(LRW), IWORK(LIW) + +c----------------------------------------------------------------------- + +c - SPECIAL CHANGE FOR bigmlt10.f + +c When Andreas' Intel compiler compiles the program, it objects to +c RPAR and IPAR being dimensioned (as (*)) in Subroutine DVODE (and +c routines called by DVODE) when they are not dimensioned in +c Subroutine USERANAL (in idm1x5.f). The comments in DVODE state that +c if these values are not being used, they do not need to be +c dimensioned in routines that call DVODE. Nevertheless, to remove the +c Intel objection, RPAR(*) and IPAR(*) are removed from the 5 routines + +c in this module which declare them arrays. + +c Similarly, RTOL supposedly does not need to be dimensioned in + +c USERANAL since it is a scalar, but the Intel compiler objects to +c having it dimensioned (*) in DVODE, etc. when it is a scalar in +c USERANAL. So, all RTOL(*) occurrences are removed in this module, +c and all references to RTOL(1), RTOL(I), etc. are changed to RTOL. + +C----------------------------------------------------------------------- +C DVODE.. Variable-coefficient Ordinary Differential Equation solver, +C with fixed-leading coefficient implementation. +C This version is in double precision. +C +C DVODE solves the initial value problem for stiff or nonstiff +C systems of first order ODEs, +C dy/dt = f(t,y) , or, in component form, +C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). +C DVODE is a package based on the EPISODE and EPISODEB packages, and +C on the ODEPACK user interface standard, with minor modifications. +C----------------------------------------------------------------------- +C Revision History (YYMMDD) +C 890615 Date Written +C 890922 Added interrupt/restart ability, minor changes throughout. +C 910228 Minor revisions in line format, prologue, etc. +C 920227 Modifications by D. Pang: +C (1) Applied subgennam to get generic intrinsic names. +C (2) Changed intrinsic names to generic in comments. +C (3) Added *DECK lines before each routine. +C 920721 Names of routines and labeled Common blocks changed, so as +C to be unique in combined single/double precision code (ACH). + +C 920722 Minor revisions to prologue (ACH). +C 920831 Conversion to double precision done (ACH). +C----------------------------------------------------------------------- +C References.. +C +C 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable +C Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989), +C pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988. +C 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the +C Numerical Solution of Ordinary Differential Equations," +C ACM Trans. Math. Software, 1 (1975), pp. 71-96. +C 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package +C for the Integration of Systems of Ordinary Differential +C Equations," LLNL Report UCID-30112, Rev. 1, April 1977. +C 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental +C Package for the Integration of Systems of Ordinary Differential +C Equations with Banded Jacobians," LLNL Report UCID-30132, April +C 1976. + +C 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE +C Solvers," in Scientific Computing, R. S. Stepleman et al., eds., +C North-Holland, Amsterdam, 1983, pp. 55-64. +C 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation + +C of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM +C Trans. Math. Software, 6 (1980), pp. 295-318. +C----------------------------------------------------------------------- + +C Authors.. +C +C Peter N. Brown and Alan C. Hindmarsh +C Computing and Mathematics Research Division, L-316 +C Lawrence Livermore National Laboratory +C Livermore, CA 94550 +C and +C George D. Byrne +C Exxon Research and Engineering Co. +C Clinton Township +C Route 22 East +C Annandale, NJ 08801 +C----------------------------------------------------------------------- +C Summary of usage. +C +C Communication between the user and the DVODE package, for normal +C situations, is summarized here. This summary describes only a subset +C of the full set of options available. See the full description for +C details, including optional communication, nonstandard options, +C and instructions for special situations. See also the example +C problem (with program and output) following this summary. +C +C A. First provide a subroutine of the form.. +C +C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) +C DOUBLE PRECISION T, Y, YDOT, RPAR +C DIMENSION Y(NEQ), YDOT(NEQ) +C +C which supplies the vector function f by loading YDOT(i) with f(i). +C +C B. Next determine (or guess) whether or not the problem is stiff. +C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue +C whose real part is negative and large in magnitude, compared to the +C reciprocal of the t span of interest. If the problem is nonstiff, +C use a method flag MF = 10. If it is stiff, there are four standard +C choices for MF (21, 22, 24, 25), and DVODE requires the Jacobian +C matrix in some form. In these cases (MF .gt. 0), DVODE will use a +C saved copy of the Jacobian matrix. If this is undesirable because of +C storage limitations, set MF to the corresponding negative value +C (-21, -22, -24, -25). (See full description of MF below.) +C The Jacobian matrix is regarded either as full (MF = 21 or 22), +C or banded (MF = 24 or 25). In the banded case, DVODE requires two +C half-bandwidth parameters ML and MU. These are, respectively, the +C widths of the lower and upper parts of the band, excluding the main +C diagonal. Thus the band consists of the locations (i,j) with +C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. +C +C C. If the problem is stiff, you are encouraged to supply the Jacobian +C directly (MF = 21 or 24), but if this is not feasible, DVODE will +C compute it internally by difference quotients (MF = 22 or 25). +C If you are supplying the Jacobian, provide a subroutine of the form.. +C +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) +C DOUBLE PRECISION T, Y, PD, RPAR +C DIMENSION Y(NEQ), PD(NROWPD,NEQ) +C +C which supplies df/dy by loading PD as follows.. +C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), +C the partial derivative of f(i) with respect to y(j). (Ignore the +C ML and MU arguments in this case.) +C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with +C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of +C PD from the top down. +C In either case, only nonzero elements need be loaded. +C +C D. Write a main program which calls subroutine DVODE once for +C each point at which answers are desired. This should also provide +C for possible use of logical unit 6 for output of error messages +C by DVODE. On the first call to DVODE, supply arguments as follows.. + +C F = Name of subroutine for right-hand side vector f. +C This name must be declared external in calling program. +C NEQ = Number of first order ODE-s. +C Y = Array of initial values, of length NEQ. +C T = The initial value of the independent variable. + +C TOUT = First point where output is desired (.ne. T). +C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. +C RTOL = Relative tolerance parameter (scalar). + +C ATOL = Absolute tolerance parameter (scalar or array). +C The estimated local error in Y(i) will be controlled so as +C to be roughly less (in magnitude) than +C EWT(i) = RTOL*abs(Y(i)) + ATOL if ITOL = 1, or +C EWT(i) = RTOL*abs(Y(i)) + ATOL(i) if ITOL = 2. +C Thus the local error test passes if, in each component, +C either the absolute error is less than ATOL (or ATOL(i)), +C or the relative error is less than RTOL. +C Use RTOL = 0.0 for pure absolute error control, and +C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error +C control. Caution.. Actual (global) errors may exceed these +C local tolerances, so choose them conservatively. +C ITASK = 1 for normal computation of output values of Y at t = TOUT. +C ISTATE = Integer flag (input and output). Set ISTATE = 1. +C IOPT = 0 to indicate no optional input used. +C RWORK = Real work array of length at least.. +C 20 + 16*NEQ for MF = 10, +C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, +C 22 + 11*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. +C LRW = Declared length of RWORK (in user's DIMENSION statement). +C IWORK = Integer work array of length at least.. +C 30 for MF = 10, +C 30 + NEQ for MF = 21, 22, 24, or 25. +C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower +C and upper half-bandwidths ML,MU. +C LIW = Declared length of IWORK (in user's DIMENSION). +C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). +C If used, this name must be declared external in calling +C program. If not used, pass a dummy name. + +C MF = Method flag. Standard values are.. +C 10 for nonstiff (Adams) method, no Jacobian used. +C 21 for stiff (BDF) method, user-supplied full Jacobian. + +C 22 for stiff method, internally generated full Jacobian. +C 24 for stiff method, user-supplied banded Jacobian. +C 25 for stiff method, internally generated banded Jacobian. +C RPAR,IPAR = user-defined real and integer arrays passed to F and JAC. +C Note that the main program must declare arrays Y, RWORK, IWORK, +C and possibly ATOL, RPAR, and IPAR. +C +C E. The output from the first call (or any call) is.. +C Y = Array of computed values of y(t) vector. +C T = Corresponding value of independent variable (normally TOUT). +C ISTATE = 2 if DVODE was successful, negative otherwise. +C -1 means excess work done on this call. (Perhaps wrong MF.) +C -2 means excess accuracy requested. (Tolerances too small.) +C -3 means illegal input detected. (See printed message.) +C -4 means repeated error test failures. (Check all input.) +C -5 means repeated convergence failures. (Perhaps bad +C Jacobian supplied or wrong choice of MF or tolerances.) +C -6 means error weight became zero during problem. (Solution +C component i vanished, and ATOL or ATOL(i) = 0.) +C +C F. To continue the integration after a successful return, simply +C reset TOUT and call DVODE again. No other parameters need be reset. + +C +C----------------------------------------------------------------------- +C EXAMPLE PROBLEM +C +C The following is a simple example problem, with the coding +C needed for its solution by DVODE. The problem is from chemical +C kinetics, and consists of the following three rate equations.. +C dy1/dt = -.04*y1 + 1.e4*y2*y3 +C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 +C dy3/dt = 3.e7*y2**2 + +C on the interval from t = 0.0 to t = 4.e10, with initial conditions +C y1 = 1.0, y2 = y3 = 0. The problem is stiff. + +C + +C The following coding solves this problem with DVODE, using MF = 21 +C and printing results at t = .4, 4., ..., 4.e10. It uses +C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because +C y2 has much smaller values. +C At the end of the run, statistical quantities of interest are +C printed. (See optional output in the full description below.) +C To generate Fortran source code, replace C in column 1 with a blank +C in the coding below. +C +C EXTERNAL FEX, JEX +C DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y +C DIMENSION Y(3), ATOL(3), RWORK(67), IWORK(33) +C NEQ = 3 +C Y(1) = 1.0D0 +C Y(2) = 0.0D0 +C Y(3) = 0.0D0 +C T = 0.0D0 +C TOUT = 0.4D0 +C ITOL = 2 + +C RTOL = 1.D-4 +C ATOL(1) = 1.D-8 + +C ATOL(2) = 1.D-14 +C ATOL(3) = 1.D-6 + +C ITASK = 1 +C ISTATE = 1 + +C IOPT = 0 +C LRW = 67 +C LIW = 33 +C MF = 21 +C DO 40 IOUT = 1,12 +C CALL DVODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, +C 1 IOPT,RWORK,LRW,IWORK,LIW,JEX,MF,RPAR,IPAR) + +C WRITE(6,20)T,Y(1),Y(2),Y(3) +C 20 FORMAT(' At t =',D12.4,' y =',3D14.6) +C IF (ISTATE .LT. 0) GO TO 80 +C 40 TOUT = TOUT*10. +C WRITE(6,60) IWORK(11),IWORK(12),IWORK(13),IWORK(19), +C 1 IWORK(20),IWORK(21),IWORK(22) +C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4, +C 1 ' No. J-s =',I4,' No. LU-s =',I4/ +C 2 ' No. nonlinear iterations =',I4/ +C 3 ' No. nonlinear convergence failures =',I4/ + +C 4 ' No. error test failures =',I4/) +C STOP +C 80 WRITE(6,90)ISTATE +C 90 FORMAT(///' Error halt.. ISTATE =',I3) +C STOP +C END +C +C SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) +C DOUBLE PRECISION RPAR, T, Y, YDOT +C DIMENSION Y(NEQ), YDOT(NEQ) +C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) +C YDOT(3) = 3.D7*Y(2)*Y(2) +C YDOT(2) = -YDOT(1) - YDOT(3) +C RETURN +C END +C +C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) +C DOUBLE PRECISION PD, RPAR, T, Y +C DIMENSION Y(NEQ), PD(NRPD,NEQ) +C PD(1,1) = -.04D0 + +C PD(1,2) = 1.D4*Y(3) +C PD(1,3) = 1.D4*Y(2) +C PD(2,1) = .04D0 +C PD(2,3) = -PD(1,3) +C PD(3,2) = 6.D7*Y(2) +C PD(2,2) = -PD(1,2) - PD(3,2) +C RETURN +C END +C +C The following output was obtained from the above program on a +C Cray-1 computer with the CFT compiler. +C +C At t = 4.0000e-01 y = 9.851680e-01 3.386314e-05 1.479817e-02 +C At t = 4.0000e+00 y = 9.055255e-01 2.240539e-05 9.445214e-02 +C At t = 4.0000e+01 y = 7.158108e-01 9.184883e-06 2.841800e-01 +C At t = 4.0000e+02 y = 4.505032e-01 3.222940e-06 5.494936e-01 +C At t = 4.0000e+03 y = 1.832053e-01 8.942690e-07 8.167938e-01 +C At t = 4.0000e+04 y = 3.898560e-02 1.621875e-07 9.610142e-01 +C At t = 4.0000e+05 y = 4.935882e-03 1.984013e-08 9.950641e-01 +C At t = 4.0000e+06 y = 5.166183e-04 2.067528e-09 9.994834e-01 +C At t = 4.0000e+07 y = 5.201214e-05 2.080593e-10 9.999480e-01 +C At t = 4.0000e+08 y = 5.213149e-06 2.085271e-11 9.999948e-01 +C At t = 4.0000e+09 y = 5.183495e-07 2.073399e-12 9.999995e-01 +C At t = 4.0000e+10 y = 5.450996e-08 2.180399e-13 9.999999e-01 +C +C No. steps = 595 No. f-s = 832 No. J-s = 13 No. LU-s = 112 +C No. nonlinear iterations = 831 +C No. nonlinear convergence failures = 0 +C No. error test failures = 22 +C----------------------------------------------------------------------- +C Full description of user interface to DVODE. +C +C The user interface to DVODE consists of the following parts. +C +C i. The call sequence to subroutine DVODE, which is a driver +C routine for the solver. This includes descriptions of both +C the call sequence arguments and of user-supplied routines. +C Following these descriptions is +C * a description of optional input available through the +C call sequence, +C * a description of optional output (in the work arrays), and +C * instructions for interrupting and restarting a solution. +C +C ii. Descriptions of other routines in the DVODE package that may be +C (optionally) called by the user. These provide the ability to +C alter error message handling, save and restore the internal +C COMMON, and obtain specified derivatives of the solution y(t). +C +C iii. Descriptions of COMMON blocks to be declared in overlay +C or similar environments. +C +C iv. Description of two routines in the DVODE package, either of +C which the user may replace with his own version, if desired. +C these relate to the measurement of errors. +C +C----------------------------------------------------------------------- +C Part i. Call Sequence. +C +C The call sequence parameters used for input only are +C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, +C and those used for both input and output are +C Y, T, ISTATE. +C The work arrays RWORK and IWORK are also used for conditional and +C optional input and optional output. (The term output here refers +C to the return from subroutine DVODE to the user's calling program.) +C +C The legality of input parameters will be thoroughly checked on the +C initial call for the problem, but not checked thereafter unless a +C change in input parameters is flagged by ISTATE = 3 in the input. + +C +C The descriptions of the call arguments are as follows. +C +C F = The name of the user-supplied subroutine defining the +C ODE system. The system must be put in the first-order +C form dy/dt = f(t,y), where f is a vector-valued function +C of the scalar t and the vector y. Subroutine F is to +C compute the function f. It is to have the form +C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) +C DOUBLE PRECISION T, Y, YDOT, RPAR + +C DIMENSION Y(NEQ), YDOT(NEQ) +C where NEQ, T, and Y are input, and the array YDOT = f(t,y) +C is output. Y and YDOT are arrays of length NEQ. +C (In the DIMENSION statement above, NEQ can be replaced by +C * to make Y and YDOT assumed size arrays.) +C Subroutine F should not alter Y(1),...,Y(NEQ). +C F must be declared EXTERNAL in the calling program. + +C +C Subroutine F may access user-defined real and integer +C work arrays RPAR and IPAR, which are to be dimensioned + +C in the main program. +C +C If quantities computed in the F routine are needed +C externally to DVODE, an extra call to F should be made + +C for this purpose, for consistent and accurate results. +C If only the derivative dy/dt is needed, use DVINDY instead. +C +C NEQ = The size of the ODE system (number of first order +C ordinary differential equations). Used only for input. +C NEQ may not be increased during the problem, but +C can be decreased (with ISTATE = 3 in the input). + +C +C Y = A real array for the vector of dependent variables, of + +C length NEQ or more. Used for both input and output on the +C first call (ISTATE = 1), and only for output on other calls. +C On the first call, Y must contain the vector of initial +C values. In the output, Y contains the computed solution +C evaluated at T. If desired, the Y array may be used + +C for other purposes between calls to the solver. +C +C This array is passed as the Y argument in all calls to +C F and JAC. +C +C T = The independent variable. In the input, T is used only on +C the first call, as the initial point of the integration. + +C In the output, after each call, T is the value at which a +C computed solution Y is evaluated (usually the same as TOUT). +C On an error return, T is the farthest point reached. + +C +C TOUT = The next value of t at which a computed solution is desired. +C Used only for input. +C +C When starting the problem (ISTATE = 1), TOUT may be equal +C to T for one call, then should .ne. T for the next call. +C For the initial T, an input value of TOUT .ne. T is used +C in order to determine the direction of the integration +C (i.e. the algebraic sign of the step sizes) and the rough +C scale of the problem. Integration in either direction +C (forward or backward in t) is permitted. +C +C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after +C the first call (i.e. the first call with TOUT .ne. T). +C Otherwise, TOUT is required on every call. +C +C If ITASK = 1, 3, or 4, the values of TOUT need not be + +C monotone, but a value of TOUT which backs up is limited +C to the current internal t interval, whose endpoints are +C TCUR - HU and TCUR. (See optional output, below, for +C TCUR and HU.) +C +C ITOL = An indicator for the type of error control. See +C description below under ATOL. Used only for input. +C +C RTOL = A relative error tolerance parameter, either a scalar or +C an array of length NEQ. See description below under ATOL. +C Input only. +C +C ATOL = An absolute error tolerance parameter, either a scalar or +C an array of length NEQ. Input only. +C +C The input parameters ITOL, RTOL, and ATOL determine +C the error control performed by the solver. The solver will +C control the vector e = (e(i)) of estimated local errors +C in Y, according to an inequality of the form + +C rms-norm of ( e(i)/EWT(i) ) .le. 1, +C where EWT(i) = RTOL(i)*abs(Y(i)) + ATOL(i), +C and the rms-norm (root-mean-square norm) here is +C rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) +C is a vector of weights which must always be positive, and +C the values of RTOL and ATOL should all be non-negative. +C The following table gives the types (scalar/array) of +C RTOL and ATOL, and the corresponding form of EWT(i). +C +C ITOL RTOL ATOL EWT(i) +C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL +C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) +C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL +C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) +C +C When either of these parameters is a scalar, it need not +C be dimensioned in the user's calling program. +C +C If none of the above choices (with ITOL, RTOL, and ATOL +C fixed throughout the problem) is suitable, more general +C error controls can be obtained by substituting +C user-supplied routines for the setting of EWT and/or for +C the norm calculation. See Part iv below. +C +C If global errors are to be estimated by making a repeated +C run on the same problem with smaller tolerances, then all +C components of RTOL and ATOL (i.e. of EWT) should be scaled +C down uniformly. +C +C ITASK = An index specifying the task to be performed. +C Input only. ITASK has the following values and meanings. +C 1 means normal computation of output values of y(t) at +C t = TOUT (by overshooting and interpolating). +C 2 means take one step only and return. + +C 3 means stop at the first internal mesh point at or + +C beyond t = TOUT and return. +C 4 means normal computation of output values of y(t) at +C t = TOUT but without overshooting t = TCRIT. +C TCRIT must be input as RWORK(1). TCRIT may be equal to +C or beyond TOUT, but not behind it in the direction of +C integration. This option is useful if the problem +C has a singularity at or beyond t = TCRIT. +C 5 means take one step, without passing TCRIT, and return. +C TCRIT must be input as RWORK(1). +C +C Note.. If ITASK = 4 or 5 and the solver reaches TCRIT +C (within roundoff), it will return T = TCRIT (exactly) to +C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, +C in which case answers at T = TOUT are returned first). +C +C ISTATE = an index used for input and output to specify the +C the state of the calculation. +C +C In the input, the values of ISTATE are as follows. +C 1 means this is the first call for the problem +C (initializations will be done). See note below. +C 2 means this is not the first call, and the calculation +C is to continue normally, with no change in any input +C parameters except possibly TOUT and ITASK. +C (If ITOL, RTOL, and/or ATOL are changed between calls +C with ISTATE = 2, the new values will be used but not + +C tested for legality.) +C 3 means this is not the first call, and the +C calculation is to continue normally, but with +C a change in input parameters other than +C TOUT and ITASK. Changes are allowed in +C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, + +C and any of the optional input except H0. +C (See IWORK description for ML and MU.) + +C Note.. A preliminary call with TOUT = T is not counted +C as a first call here, as no initialization or checking of +C input is done. (Such a call is sometimes useful to include +C the initial conditions in the output.) +C Thus the first call for which TOUT .ne. T requires +C ISTATE = 1 in the input. +C +C In the output, ISTATE has the following values and meanings. +C 1 means nothing was done, as TOUT was equal to T with +C ISTATE = 1 in the input. +C 2 means the integration was performed successfully. +C -1 means an excessive amount of work (more than MXSTEP +C steps) was done on this call, before completing the +C requested task, but the integration was otherwise +C successful as far as T. (MXSTEP is an optional input +C and is normally 500.) To continue, the user may +C simply reset ISTATE to a value .gt. 1 and call again. +C (The excess work step counter will be reset to 0.) +C In addition, the user may increase MXSTEP to avoid +C this error return. (See optional input below.) +C -2 means too much accuracy was requested for the precision +C of the machine being used. This was detected before +C completing the requested task, but the integration +C was successful as far as T. To continue, the tolerance +C parameters must be reset, and ISTATE must be set +C to 3. The optional output TOLSF may be used for this +C purpose. (Note.. If this condition is detected before +C taking any steps, then an illegal input return +C (ISTATE = -3) occurs instead.) +C -3 means illegal input was detected, before taking any +C integration steps. See written message for details. +C Note.. If the solver detects an infinite loop of calls +C to the solver with illegal input, it will cause +C the run to stop. +C -4 means there were repeated error test failures on +C one attempted step, before completing the requested +C task, but the integration was successful as far as T. +C The problem may have a singularity, or the input +C may be inappropriate. +C -5 means there were repeated convergence test failures on +C one attempted step, before completing the requested +C task, but the integration was successful as far as T. +C This may be caused by an inaccurate Jacobian matrix, +C if one is being used. +C -6 means EWT(i) became zero for some i during the +C integration. Pure relative error control (ATOL(i)=0.0) +C was requested on a variable which has now vanished. +C The integration was successful as far as T. +C +C Note.. Since the normal output value of ISTATE is 2, +C it does not need to be reset for normal continuation. + +C Also, since a negative input value of ISTATE will be +C regarded as illegal, a negative output value requires the +C user to change it, and possibly other input, before +C calling the solver again. +C +C IOPT = An integer flag to specify whether or not any optional +C input is being used on this call. Input only. +C The optional input is listed separately below. +C IOPT = 0 means no optional input is being used. +C Default values will be used in all cases. +C IOPT = 1 means optional input is being used. +C +C RWORK = A real working array (double precision). +C The length of RWORK must be at least +C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where +C NYH = the initial value of NEQ, +C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a +C smaller value is given as an optional input), +C LWM = length of work space for matrix-related data.. +C LWM = 0 if MITER = 0, +C LWM = 2*NEQ**2 + 2 if MITER = 1 or 2, and MF.gt.0, +C LWM = NEQ**2 + 2 if MITER = 1 or 2, and MF.lt.0, +C LWM = NEQ + 2 if MITER = 3, +C LWM = (3*ML+2*MU+2)*NEQ + 2 if MITER = 4 or 5, and MF.gt.0, +C LWM = (2*ML+MU+1)*NEQ + 2 if MITER = 4 or 5, and MF.lt.0. +C (See the MF description for METH and MITER.) +C Thus if MAXORD has its default value and NEQ is constant, +C this length is.. + +C 20 + 16*NEQ for MF = 10, +C 22 + 16*NEQ + 2*NEQ**2 for MF = 11 or 12, +C 22 + 16*NEQ + NEQ**2 for MF = -11 or -12, +C 22 + 17*NEQ for MF = 13, +C 22 + 18*NEQ + (3*ML+2*MU)*NEQ for MF = 14 or 15, +C 22 + 17*NEQ + (2*ML+MU)*NEQ for MF = -14 or -15, +C 20 + 9*NEQ for MF = 20, +C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, +C 22 + 9*NEQ + NEQ**2 for MF = -21 or -22, +C 22 + 10*NEQ for MF = 23, +C 22 + 11*NEQ + (3*ML+2*MU)*NEQ for MF = 24 or 25. +C 22 + 10*NEQ + (2*ML+MU)*NEQ for MF = -24 or -25. +C The first 20 words of RWORK are reserved for conditional +C and optional input and optional output. +C +C The following word in RWORK is a conditional input.. +C RWORK(1) = TCRIT = critical value of t which the solver +C is not to overshoot. Required if ITASK is +C 4 or 5, and ignored otherwise. (See ITASK.) +C +C LRW = The length of the array RWORK, as declared by the user. + +C (This will be checked by the solver.) +C +C IWORK = An integer work array. The length of IWORK must be at least +C 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or +C 30 + NEQ otherwise (abs(MF) = 11,12,14,15,21,22,24,25). +C The first 30 words of IWORK are reserved for conditional and +C optional input and optional output. +C +C The following 2 words in IWORK are conditional input.. +C IWORK(1) = ML These are the lower and upper +C IWORK(2) = MU half-bandwidths, respectively, of the +C banded Jacobian, excluding the main diagonal. +C The band is defined by the matrix locations +C (i,j) with i-ML .le. j .le. i+MU. ML and MU +C must satisfy 0 .le. ML,MU .le. NEQ-1. +C These are required if MITER is 4 or 5, and +C ignored otherwise. ML and MU may in fact be +C the band parameters for a matrix to which +C df/dy is only approximately equal. +C +C LIW = the length of the array IWORK, as declared by the user. +C (This will be checked by the solver.) +C +C Note.. The work arrays must not be altered between calls to DVODE +C for the same problem, except possibly for the conditional and +C optional input, and except for the last 3*NEQ words of RWORK. +C The latter space is used for internal scratch space, and so is +C available for use by the user outside DVODE between calls, if +C desired (but not for use by F or JAC). +C +C JAC = The name of the user-supplied routine (MITER = 1 or 4) to +C compute the Jacobian matrix, df/dy, as a function of +C the scalar t and the vector y. It is to have the form +C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, +C RPAR, IPAR) +C DOUBLE PRECISION T, Y, PD, RPAR +C DIMENSION Y(NEQ), PD(NROWPD, NEQ) +C where NEQ, T, Y, ML, MU, and NROWPD are input and the array +C PD is to be loaded with partial derivatives (elements of the + +C Jacobian matrix) in the output. PD must be given a first +C dimension of NROWPD. T and Y have the same meaning as in +C Subroutine F. (In the DIMENSION statement above, NEQ can +C be replaced by * to make Y and PD assumed size arrays.) +C In the full matrix case (MITER = 1), ML and MU are +C ignored, and the Jacobian is to be loaded into PD in +C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). +C In the band matrix case (MITER = 4), the elements +C within the band are to be loaded into PD in columnwise +C manner, with diagonal lines of df/dy loaded into the rows +C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). +C ML and MU are the half-bandwidth parameters. (See IWORK). +C The locations in PD in the two triangular areas which +C correspond to nonexistent matrix elements can be ignored +C or loaded arbitrarily, as they are overwritten by DVODE. +C JAC need not provide df/dy exactly. A crude +C approximation (possibly with a smaller bandwidth) will do. +C In either case, PD is preset to zero by the solver, +C so that only the nonzero elements need be loaded by JAC. +C Each call to JAC is preceded by a call to F with the same +C arguments NEQ, T, and Y. Thus to gain some efficiency, +C intermediate quantities shared by both calculations may be +C saved in a user COMMON block by F and not recomputed by JAC, +C if desired. Also, JAC may alter the Y array, if desired. +C JAC must be declared external in the calling program. +C Subroutine JAC may access user-defined real and integer +C work arrays, RPAR and IPAR, whose dimensions are set by the +C user in the main program. +C +C MF = The method flag. Used only for input. The legal values of +C MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, +C -11, -12, -14, -15, -21, -22, -24, -25. +C MF is a signed two-digit integer, MF = JSV*(10*METH + MITER). +C JSV = SIGN(MF) indicates the Jacobian-saving strategy.. +C JSV = 1 means a copy of the Jacobian is saved for reuse +C in the corrector iteration algorithm. +C JSV = -1 means a copy of the Jacobian is not saved + +C (valid only for MITER = 1, 2, 4, or 5). +C METH indicates the basic linear multistep method.. +C METH = 1 means the implicit Adams method. +C METH = 2 means the method based on backward +C differentiation formulas (BDF-s). +C MITER indicates the corrector iteration method.. +C MITER = 0 means functional iteration (no Jacobian matrix +C is involved). +C MITER = 1 means chord iteration with a user-supplied +C full (NEQ by NEQ) Jacobian. +C MITER = 2 means chord iteration with an internally +C generated (difference quotient) full Jacobian +C (using NEQ extra calls to F per df/dy value). +C MITER = 3 means chord iteration with an internally +C generated diagonal Jacobian approximation +C (using 1 extra call to F per df/dy evaluation). +C MITER = 4 means chord iteration with a user-supplied +C banded Jacobian. +C MITER = 5 means chord iteration with an internally +C generated banded Jacobian (using ML+MU+1 extra +C calls to F per df/dy evaluation). +C If MITER = 1 or 4, the user must supply a subroutine JAC +C (the name is arbitrary) as described above under JAC. +C For other values of MITER, a dummy argument can be used. + +C +C RPAR User-specified array used to communicate real parameters +C to user-supplied subroutines. If RPAR is a vector, then +C it must be dimensioned in the user's main program. If it +C is unused or it is a scalar, then it need not be +C dimensioned. +C +C IPAR User-specified array used to communicate integer parameter +C to user-supplied subroutines. The comments on dimensioning +C RPAR apply to IPAR. +C----------------------------------------------------------------------- +C Optional Input. + +C +C The following is a list of the optional input provided for in the +C call sequence. (See also Part ii.) For each such input variable, +C this table lists its name as used in this documentation, its +C location in the call sequence, its meaning, and the default value. +C The use of any of this input requires IOPT = 1, and in that +C case all of this input is examined. A value of zero for any +C of these optional input variables will cause the default value to be +C used. Thus to use a subset of the optional input, simply preload +C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and +C then set those of interest to nonzero values. +C +C NAME LOCATION MEANING AND DEFAULT VALUE +C +C H0 RWORK(5) The step size to be attempted on the first step. + +C The default value is determined by the solver. +C + +C HMAX RWORK(6) The maximum absolute step size allowed. +C The default value is infinite. +C + +C HMIN RWORK(7) The minimum absolute step size allowed. +C The default value is 0. (This lower bound is not + +C enforced on the final step before reaching TCRIT +C when ITASK = 4 or 5.) +C +C MAXORD IWORK(5) The maximum order to be allowed. The default +C value is 12 if METH = 1, and 5 if METH = 2. +C If MAXORD exceeds the default value, it will +C be reduced to the default value. +C If MAXORD is changed during the problem, it may +C cause the current order to be reduced. +C +C MXSTEP IWORK(6) Maximum number of (internally defined) steps +C allowed during one call to the solver. +C The default value is 500. +C +C MXHNIL IWORK(7) Maximum number of messages printed (per problem) +C warning that T + H = T on a step (H = step size). +C This must be positive to result in a non-default +C value. The default value is 10. +C +C----------------------------------------------------------------------- +C Optional Output. +C +C As optional additional output from DVODE, the variables listed +C below are quantities related to the performance of DVODE +C which are available to the user. These are communicated by way of +C the work arrays, but also have internal mnemonic names as shown. +C Except where stated otherwise, all of this output is defined +C on any successful return from DVODE, and on any return with +C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return +C (ISTATE = -3), they will be unchanged from their existing values +C (if any), except possibly for TOLSF, LENRW, and LENIW. + +C On any error return, output relevant to the error will be defined, +C as noted below. +C +C NAME LOCATION MEANING +C +C HU RWORK(11) The step size in t last used (successfully). +C +C HCUR RWORK(12) The step size to be attempted on the next step. +C +C TCUR RWORK(13) The current value of the independent variable +C which the solver has actually reached, i.e. the +C current internal mesh point in t. In the output, +C TCUR will always be at least as far from the +C initial value of t as the current argument T, +C but may be farther (if interpolation was done). +C +C TOLSF RWORK(14) A tolerance scale factor, greater than 1.0, +C computed when a request for too much accuracy was +C detected (ISTATE = -3 if detected at the start of +C the problem, ISTATE = -2 otherwise). If ITOL is + +C left unaltered but RTOL and ATOL are uniformly +C scaled up by a factor of TOLSF for the next call, +C then the solver is deemed likely to succeed. +C (The user may also ignore TOLSF and alter the +C tolerance parameters in any other way appropriate.) +C +C NST IWORK(11) The number of steps taken for the problem so far. +C +C NFE IWORK(12) The number of f evaluations for the problem so far. +C +C NJE IWORK(13) The number of Jacobian evaluations so far. +C + + +C NQU IWORK(14) The method order last used (successfully). +C +C NQCUR IWORK(15) The order to be attempted on the next step. +C +C IMXER IWORK(16) The index of the component of largest magnitude in +C the weighted local error vector ( e(i)/EWT(i) ), +C on an error return with ISTATE = -4 or -5. +C +C LENRW IWORK(17) The length of RWORK actually required. +C This is defined on normal returns and on an illegal +C input return for insufficient storage. +C +C LENIW IWORK(18) The length of IWORK actually required. +C This is defined on normal returns and on an illegal +C input return for insufficient storage. +C +C NLU IWORK(19) The number of matrix LU decompositions so far. +C +C NNI IWORK(20) The number of nonlinear (Newton) iterations so far. +C +C NCFN IWORK(21) The number of convergence failures of the nonlinear +C solver so far. +C +C NETF IWORK(22) The number of error test failures of the integrator +C so far. +C +C The following two arrays are segments of the RWORK array which +C may also be of interest to the user as optional output. +C For each array, the table below gives its internal name, +C its base address in RWORK, and its description. +C +C NAME BASE ADDRESS DESCRIPTION +C +C YH 21 The Nordsieck history array, of size NYH by +C (NQCUR + 1), where NYH is the initial value +C of NEQ. For j = 0,1,...,NQCUR, column j+1 +C of YH contains HCUR**j/factorial(j) times +C the j-th derivative of the interpolating +C polynomial currently representing the +C solution, evaluated at t = TCUR. +C +C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated +C corrections on each step, scaled in the output +C to represent the estimated local error in Y +C on the last step. This is the vector e in +C the description of the error control. It is + +C defined only on a successful return from DVODE. +C +C----------------------------------------------------------------------- +C Interrupting and Restarting +C +C If the integration of a given problem by DVODE is to be +C interrrupted and then later continued, such as when restarting +C an interrupted run or alternating between two or more ODE problems, +C the user should save, following the return from the last DVODE call +C prior to the interruption, the contents of the call sequence +C variables and internal COMMON blocks, and later restore these +C values before the next DVODE call for that problem. To save +C and restore the COMMON blocks, use subroutine DVSRCO, as +C described below in part ii. +C +C In addition, if non-default values for either LUN or MFLAG are +C desired, an extra call to XSETUN and/or XSETF should be made just +C before continuing the integration. See Part ii below for details. +C +C----------------------------------------------------------------------- +C Part ii. Other Routines Callable. +C +C The following are optional calls which the user may make to +C gain additional capabilities in conjunction with DVODE. +C (The routines XSETUN and XSETF are designed to conform to the +C SLATEC error handling package.) +C +C FORM OF CALL FUNCTION +C CALL XSETUN(LUN) Set the logical unit number, LUN, for +C output of messages from DVODE, if +C the default is not desired. +C The default value of LUN is 6. +C +C CALL XSETF(MFLAG) Set a flag to control the printing of +C messages by DVODE. +C MFLAG = 0 means do not print. (Danger.. +C This risks losing valuable information.) +C MFLAG = 1 means print (the default). +C +C Either of the above calls may be made at +C any time and will take effect immediately. +C + +C CALL DVSRCO(RSAV,ISAV,JOB) Saves and restores the contents of +C the internal COMMON blocks used by + +C DVODE. (See Part iii below.) +C RSAV must be a real array of length 49 +C or more, and ISAV must be an integer +C array of length 40 or more. +C JOB=1 means save COMMON into RSAV/ISAV. +C JOB=2 means restore COMMON from RSAV/ISAV. +C DVSRCO is useful if one is +C interrupting a run and restarting +C later, or alternating between two or +C more problems solved with DVODE. +C +C CALL DVINDY(,,,,,) Provide derivatives of y, of various +C (See below.) orders, at a specified point T, if +C desired. It may be called only after +C a successful return from DVODE. +C +C The detailed instructions for using DVINDY are as follows. +C The form of the call is.. +C +C CALL DVINDY (T, K, RWORK(21), NYH, DKY, IFLAG) +C +C The input parameters are.. +C +C T = Value of independent variable where answers are desired +C (normally the same as the T last returned by DVODE). +C For valid results, T must lie between TCUR - HU and TCUR. +C (See optional output for TCUR and HU.) + +C K = Integer order of the derivative desired. K must satisfy +C 0 .le. K .le. NQCUR, where NQCUR is the current order +C (see optional output). The capability corresponding +C to K = 0, i.e. computing y(T), is already provided +C by DVODE directly. Since NQCUR .ge. 1, the first +C derivative dy/dt is always available with DVINDY. +C RWORK(21) = The base address of the history array YH. +C NYH = Column length of YH, equal to the initial value of NEQ. +C +C The output parameters are.. +C +C DKY = A real array of length NEQ containing the computed value +C of the K-th derivative of y(t). +C IFLAG = Integer flag, returned as 0 if K and T were legal, +C -1 if K was illegal, and -2 if T was illegal. +C On an error return, a message is also written. +C----------------------------------------------------------------------- +C Part iii. COMMON Blocks. +C If DVODE is to be used in an overlay situation, the user +C must declare, in the primary overlay, the variables in.. +C (1) the call sequence to DVODE, +C (2) the two internal COMMON blocks +C /DVOD01/ of length 81 (48 double precision words +C followed by 33 integer words), +C /DVOD02/ of length 9 (1 double precision word +C followed by 8 integer words), +C + +C If DVODE is used on a system in which the contents of internal +C COMMON blocks are not preserved between calls, the user should +C declare the above two COMMON blocks in his main program to insure +C that their contents are preserved. +C +C----------------------------------------------------------------------- +C Part iv. Optionally Replaceable Solver Routines. +C +C Below are descriptions of two routines in the DVODE package which +C relate to the measurement of errors. Either routine can be +C replaced by a user-supplied version, if desired. However, since such +C a replacement may have a major impact on performance, it should be +C done only when absolutely necessary, and only with great caution. +C (Note.. The means by which the package version of a routine is + + +C superseded by the user's version may be system-dependent.) +C + +C (a) DEWSET. +C The following subroutine is called just before each internal +C integration step, and sets the array of error weights, EWT, as +C described under ITOL/RTOL/ATOL above.. + +C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) +C where NEQ, ITOL, RTOL, and ATOL are as in the DVODE call sequence, +C YCUR contains the current dependent variable vector, and +C EWT is the array of weights set by DEWSET. +C +C If the user supplies this subroutine, it must return in EWT(i) +C (i = 1,...,NEQ) a positive quantity suitable for comparison with +C errors in Y(i). The EWT array returned by DEWSET is passed to the +C DVNORM routine (See below.), and also used by DVODE in the computation +C of the optional output IMXER, the diagonal Jacobian approximation, +C and the increments for difference quotient Jacobians. +C +C In the user-supplied version of DEWSET, it may be desirable to use +C the current values of derivatives of y. Derivatives up to order NQ +C are available from the history array YH, described above under +C Optional Output. In DEWSET, YH is identical to the YCUR array, +C extended to NQ + 1 columns with a column length of NYH and scale +C factors of h**j/factorial(j). On the first call for the problem, +C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. +C NYH is the initial value of NEQ. The quantities NQ, H, and NST +C can be obtained by including in DEWSET the statements.. +C DOUBLE PRECISION RVOD, H, HU +C COMMON /DVOD01/ RVOD(48), IVOD(33) +C COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST + +C NQ = IVOD(28) +C H = RVOD(21) +C Thus, for example, the current value of dy/dt can be obtained as +C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is +C unnecessary when NST = 0). +C +C (b) DVNORM. +C The following is a real function routine which computes the weighted +C root-mean-square norm of a vector v.. +C D = DVNORM (N, V, W) +C where.. + +C N = the length of the vector, +C V = real array of length N containing the vector, +C W = real array of length N containing weights, + +C D = sqrt( (1/N) * sum(V(i)*W(i))**2 ). +C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where +C EWT is as set by subroutine DEWSET. + +C +C If the user supplies this function, it should return a non-negative +C value of DVNORM suitable for use in the error control in DVODE. +C None of the arguments should be altered by DVNORM. +C For example, a user-supplied DVNORM routine might.. +C -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or +C -ignore some components of V in the norm, with the effect of +C suppressing the error control on those components of Y. +C----------------------------------------------------------------------- +C Other Routines in the DVODE Package. +C +C In addition to subroutine DVODE, the DVODE package includes the +C following subroutines and function routines.. +C DVHIN computes an approximate step size for the initial step. +C DVINDY computes an interpolated value of the y vector at t = TOUT. +C DVSTEP is the core integrator, which does one step of the +C integration and the associated error control. +C DVSET sets all method coefficients and test constants. +C DVNLSD solves the underlying nonlinear system -- the corrector. +C DVJAC computes and preprocesses the Jacobian matrix J = df/dy +C and the Newton iteration matrix P = I - (h/l1)*J. + +C DVSOL manages solution of linear system in chord iteration. + +C DVJUST adjusts the history array on a change of order. +C DEWSET sets the error weight vector EWT before each step. +C DVNORM computes the weighted r.m.s. norm of a vector. + +C DVSRCO is a user-callable routines to save and restore +C the contents of the internal COMMON blocks. +C DACOPY is a routine to copy one two-dimensional array to another. +C DGEFA and DGESL are routines from LINPACK for solving full +C systems of linear algebraic equations. +C DGBFA and DGBSL are routines from LINPACK for solving banded +C linear systems. +C DAXPY, DSCAL, and DCOPY are basic linear algebra modules (BLAS). +C D1MACH sets the unit roundoff of the machine. +C XERRWD, XSETUN, XSETF, LUNSAV, and MFLGSV handle the printing of all +C error messages and warnings. XERRWD is machine-dependent. +C Note.. DVNORM, D1MACH, LUNSAV, and MFLGSV are function routines. +C All the others are subroutines. +C +C The intrinsic and external routines used by the DVODE package are.. +C ABS, MAX, MIN, REAL, SIGN, SQRT, and WRITE. +C +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + DOUBLE PRECISION HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + EXTERNAL DVNLSD + LOGICAL IHIT + DOUBLE PRECISION ATOLI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, + 1 PT2, RH, RTOLI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO + INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENRW, + 1 LENWM, LF0, MBAND, ML, MORD, MU, MXHNL0, MXSTP0, NITER, NSLAST + CHARACTER*80 MSG + +C +C Type declaration for function subroutines called --------------------- +C + DOUBLE PRECISION D1MACH, DVNORM +C + + DIMENSION MORD(2) + +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to DVODE. +C----------------------------------------------------------------------- + SAVE MORD, MXHNL0, MXSTP0 + + SAVE ZERO, ONE, TWO, FOUR, PT2, HUN +C----------------------------------------------------------------------- +C The following internal COMMON blocks contain variables which are +C communicated between subroutines in the DVODE package, or which are + + +C to be saved between calls to DVODE. +C In each block, real variables precede integers. +C The block /DVOD01/ appears in subroutines DVODE, DVINDY, DVSTEP, +C DVSET, DVNLSD, DVJAC, DVSOL, DVJUST and DVSRCO. +C The block /DVOD02/ appears in subroutines DVODE, DVINDY, DVSTEP, +C DVNLSD, DVJAC, and DVSRCO. +C +C The variables stored in the internal COMMON blocks are as follows.. +C +C ACNRM = Weighted r.m.s. norm of accumulated correction vectors. +C CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.) +C CONP = The saved value of TQ(5). +C CRATE = Estimated corrector convergence rate constant. +C DRC = Relative change in H*RL1 since last DVJAC call. +C EL = Real array of integration coefficients. See DVSET. +C ETA = Saved tentative ratio of new to old H. + +C ETAMAX = Saved maximum value of ETA to be allowed. +C H = The step size. +C HMIN = The minimum absolute value of the step size H to be used. +C HMXI = Inverse of the maximum absolute value of H to be used. +C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. +C HNEW = The step size to be attempted on the next step. +C HSCAL = Stepsize in scaling of YH array. + +C PRL1 = The saved value of RL1. +C RC = Ratio of current H*RL1 to value on last DVJAC call. +C RL1 = The reciprocal of the coefficient EL(1). +C TAU = Real vector of past NQ step sizes, length 13. +C TQ = A real vector of length 5 in which DVSET stores constants +C used for the convergence test, the error test, and the +C selection of H at a new order. +C TN = The independent variable, updated on each step taken. +C UROUND = The machine unit roundoff. The smallest positive real number +C such that 1.0 + UROUND .ne. 1.0 +C ICF = Integer flag for convergence failure in DVNLSD.. +C 0 means no failures. + +C 1 means convergence failure with out of date Jacobian +C (recoverable error). +C 2 means convergence failure with current Jacobian or +C singular matrix (unrecoverable error). +C INIT = Saved integer flag indicating whether initialization of the +C problem has been done (INIT = 1) or not. +C IPUP = Saved flag to signal updating of Newton matrix. +C JCUR = Output flag from DVJAC showing Jacobian status.. +C JCUR = 0 means J is not current. +C JCUR = 1 means J is current. +C JSTART = Integer flag used as input to DVSTEP.. +C 0 means perform the first step. +C 1 means take a new step continuing from the last. +C -1 means take the next step with a new value of MAXORD, +C HMIN, HMXI, N, METH, MITER, and/or matrix parameters. +C On return, DVSTEP sets JSTART = 1. +C JSV = Integer flag for Jacobian saving, = sign(MF). +C KFLAG = A completion code from DVSTEP with the following meanings.. +C 0 the step was succesful. +C -1 the requested error could not be achieved. +C -2 corrector convergence could not be achieved. +C -3, -4 fatal error in VNLS (can not occur here). +C KUTH = Input flag to DVSTEP showing whether H was reduced by the +C driver. KUTH = 1 if H was reduced, = 0 otherwise. +C L = Integer variable, NQ + 1, current order plus one. +C LMAX = MAXORD + 1 (used for dimensioning). +C LOCJS = A pointer to the saved Jacobian, whose storage starts at +C WM(LOCJS), if JSV = 1. +C LYH, LEWT, LACOR, LSAVF, LWM, LIWM = Saved integer pointers +C to segments of RWORK and IWORK. +C MAXORD = The maximum order of integration method to be allowed. +C METH/MITER = The method flags. See MF. +C MSBJ = The maximum number of steps between J evaluations, = 50. +C MXHNIL = Saved value of optional input MXHNIL. +C MXSTEP = Saved value of optional input MXSTEP. +C N = The number of first-order ODEs, = NEQ. +C NEWH = Saved integer to flag change of H. +C NEWQ = The method order to be used on the next step. +C NHNIL = Saved counter for occurrences of T + H = T. +C NQ = Integer variable, the current integration method order. +C NQNYH = Saved value of NQ*NYH. +C NQWAIT = A counter controlling the frequency of order changes. +C An order change is about to be considered if NQWAIT = 1. +C NSLJ = The number of steps taken as of the last Jacobian update. + +C NSLP = Saved value of NST as of last Newton matrix update. +C NYH = Saved value of the initial value of NEQ. +C HU = The step size in t last used. +C NCFN = Number of nonlinear convergence failures so far. +C NETF = The number of error test failures of the integrator so far. +C NFE = The number of f evaluations for the problem so far. +C NJE = The number of Jacobian evaluations so far. +C NLU = The number of matrix LU decompositions so far. + +C NNI = Number of nonlinear iterations so far. +C NQU = The method order last used. +C NST = The number of steps taken for the problem so far. +C----------------------------------------------------------------------- + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ + DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, + 1 PT2 /0.2D0/, HUN /100.0D0/ +C----------------------------------------------------------------------- +C Block A. +C This code block is executed on every call. +C It tests ISTATE and ITASK for legality and branches appropriately. +C If ISTATE .gt. 1 but the flag INIT shows that initialization has +C not yet been done, an error return occurs. +C If ISTATE = 1 and TOUT = T, return immediately. +C----------------------------------------------------------------------- + IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 + IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 + IF (ISTATE .EQ. 1) GO TO 10 + IF (INIT .NE. 1) GO TO 603 + IF (ISTATE .EQ. 2) GO TO 200 + GO TO 20 + 10 INIT = 0 + IF (TOUT .EQ. T) RETURN +C----------------------------------------------------------------------- +C Block B. +C The next code block is executed for the initial call (ISTATE = 1), +C or for a continuation call with parameter changes (ISTATE = 3). +C It contains checking of all input and various initializations. +C +C First check legality of the non-optional input NEQ, ITOL, IOPT, +C MF, ML, and MU. + +C----------------------------------------------------------------------- + 20 IF (NEQ .LE. 0) GO TO 604 + + IF (ISTATE .EQ. 1) GO TO 25 + IF (NEQ .GT. N) GO TO 605 + 25 N = NEQ + + IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 + IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 + JSV = SIGN(1,MF) + MF = ABS(MF) + METH = MF/10 + MITER = MF - 10*METH + IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 + IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 + IF (MITER .LE. 3) GO TO 30 + ML = IWORK(1) + MU = IWORK(2) + IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 + IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 + 30 CONTINUE +C Next process and check the optional input. --------------------------- + IF (IOPT .EQ. 1) GO TO 40 + MAXORD = MORD(METH) + MXSTEP = MXSTP0 + MXHNIL = MXHNL0 + IF (ISTATE .EQ. 1) H0 = ZERO + HMXI = ZERO + HMIN = ZERO + GO TO 60 + 40 MAXORD = IWORK(5) + IF (MAXORD .LT. 0) GO TO 611 + IF (MAXORD .EQ. 0) MAXORD = 100 + MAXORD = MIN(MAXORD,MORD(METH)) + MXSTEP = IWORK(6) + IF (MXSTEP .LT. 0) GO TO 612 + + IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 + MXHNIL = IWORK(7) + IF (MXHNIL .LT. 0) GO TO 613 + IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 + IF (ISTATE .NE. 1) GO TO 50 + H0 = RWORK(5) + + IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 + 50 HMAX = RWORK(6) + IF (HMAX .LT. ZERO) GO TO 615 + HMXI = ZERO + IF (HMAX .GT. ZERO) HMXI = ONE/HMAX + HMIN = RWORK(7) + IF (HMIN .LT. ZERO) GO TO 616 +C----------------------------------------------------------------------- +C Set work array pointers and check lengths LRW and LIW. +C Pointers to segments of RWORK and IWORK are named by prefixing L to +C the name of the segment. E.g., the segment YH starts at RWORK(LYH). +C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. +C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). +C----------------------------------------------------------------------- + 60 LYH = 21 + IF (ISTATE .EQ. 1) NYH = N + LWM = LYH + (MAXORD + 1)*NYH + JCO = MAX(0,JSV) + IF (MITER .EQ. 0) LENWM = 0 + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN + LENWM = 2 + (1 + JCO)*N*N + LOCJS = N*N + 3 + ENDIF + IF (MITER .EQ. 3) LENWM = 2 + N + + IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN + MBAND = ML + MU + 1 + LENP = (MBAND + ML)*N + LENJ = MBAND*N + + LENWM = 2 + LENP + JCO*LENJ + LOCJS = LENP + 3 + ENDIF + LEWT = LWM + LENWM + LSAVF = LEWT + N + LACOR = LSAVF + N + LENRW = LACOR + N - 1 + IWORK(17) = LENRW + LIWM = 1 + LENIW = 30 + N + IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 + IWORK(18) = LENIW + IF (LENRW .GT. LRW) GO TO 617 + IF (LENIW .GT. LIW) GO TO 618 +C Check RTOL and ATOL for legality. ------------------------------------ + RTOLI = RTOL + ATOLI = ATOL(1) + DO 70 I = 1,N + IF (ITOL .GE. 3) RTOLI = RTOL + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + IF (RTOLI .LT. ZERO) GO TO 619 + IF (ATOLI .LT. ZERO) GO TO 620 + 70 CONTINUE + IF (ISTATE .EQ. 1) GO TO 100 + +C If ISTATE = 3, set flag to signal parameter changes to DVSTEP. ------- + JSTART = -1 + IF (NQ .LE. MAXORD) GO TO 90 +C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- + CALL DCOPY (N, RWORK(LWM), 1, RWORK(LSAVF), 1) +C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- + 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) +C----------------------------------------------------------------------- +C Block C. +C The next block is for the initial call only (ISTATE = 1). +C It contains all remaining initializations, the initial call to F, + +C and the calculation of the initial step size. +C The error weights in EWT are inverted after being loaded. +C----------------------------------------------------------------------- + 100 UROUND = D1MACH(4) + TN = T + + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 + TCRIT = RWORK(1) + IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 + IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) + 1 H0 = TCRIT - T + 110 JSTART = 0 + + IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) + CCMXJ = PT2 + MSBJ = 50 + NHNIL = 0 + NST = 0 + NJE = 0 + NNI = 0 + NCFN = 0 + NETF = 0 + NLU = 0 + NSLJ = 0 + NSLAST = 0 + HU = ZERO + NQU = 0 +C Initial call to F. (LF0 points to YH(*,2).) ------------------------- + LF0 = LYH + NYH + + CALL F (N, T, Y, RWORK(LF0), RPAR, IPAR) + NFE = 1 +C Load the initial value vector in YH. --------------------------------- + CALL DCOPY (N, Y, 1, RWORK(LYH), 1) +C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- + NQ = 1 + H = ONE + CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 120 I = 1,N + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 + + 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + IF (H0 .NE. ZERO) GO TO 180 +C Call DVHIN to set initial step size H0 to be attempted. -------------- + CALL DVHIN (N, T, RWORK(LYH), RWORK(LF0), F, RPAR, IPAR, TOUT, + 1 UROUND, RWORK(LEWT), ITOL, ATOL, Y, RWORK(LACOR), H0, + 2 NITER, IER) + NFE = NFE + NITER + IF (IER .NE. 0) GO TO 622 +C Adjust H0 if necessary to meet HMAX bound. --------------------------- + 180 RH = ABS(H0)*HMXI + IF (RH .GT. ONE) H0 = H0/RH +C Load H with H0 and scale YH(*,2) by H0. ------------------------------ + H = H0 + CALL DSCAL (N, H0, RWORK(LF0), 1) + + GO TO 270 +C----------------------------------------------------------------------- +C Block D. +C The next code block is for continuation calls only (ISTATE = 2 or 3) +C and is to check stop conditions before taking a step. +C----------------------------------------------------------------------- + 200 NSLAST = NST + KUTH = 0 + GO TO (210, 250, 220, 230, 240), ITASK + 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 220 TP = TN - HU*(ONE + HUN*UROUND) + + IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 + + IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + GO TO 400 + 230 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 + + IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + IF (IFLAG .NE. 0) GO TO 627 + T = TOUT + GO TO 420 + 240 TCRIT = RWORK(1) + IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 + 245 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + HNEW*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + KUTH = 1 +C----------------------------------------------------------------------- +C Block E. +C The next block is normally executed for all calls and contains +C the call to the one-step core integrator DVSTEP. +C + + +C This is a looping point for the integration steps. + +C +C First check for too many steps being taken, update EWT (if not at +C start of problem), check for too much accuracy being requested, and +C check for H below the roundoff level in T. +C----------------------------------------------------------------------- + 250 CONTINUE + IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 + CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) + DO 260 I = 1,N + IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 + 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) + 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) + IF (TOLSF .LE. ONE) GO TO 280 + TOLSF = TOLSF*TWO + IF (NST .EQ. 0) GO TO 626 + GO TO 520 + 280 IF ((TN + H) .NE. TN) GO TO 290 + NHNIL = NHNIL + 1 + IF (NHNIL .GT. MXHNIL) GO TO 290 + MSG = 'DVODE-- Warning..internal T (=R1) and H (=R2) are' + CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG=' such that in the machine, T + H = T on the next step ' + CALL XERRWD (MSG, 60, 101, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' (H = step size). solver will continue anyway' + CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 2, TN, H) + IF (NHNIL .LT. MXHNIL) GO TO 290 + MSG = 'DVODE-- Above warning has been issued I1 times. ' + CALL XERRWD (MSG, 50, 102, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' it will not be issued again for this problem' + CALL XERRWD (MSG, 50, 102, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) + 290 CONTINUE +C----------------------------------------------------------------------- +C CALL DVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, +C WM, IWM, F, JAC, F, DVNLSD, RPAR, IPAR) +C----------------------------------------------------------------------- + CALL DVSTEP (Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), + 1 RWORK(LSAVF), Y, RWORK(LACOR), RWORK(LWM), IWORK(LIWM), + + 2 F, JAC, F, DVNLSD, RPAR, IPAR) + KGO = 1 - KFLAG +C Branch on KFLAG. Note..In this version, KFLAG can not be set to -3. +C KFLAG .eq. 0, -1, -2 + GO TO (300, 530, 540), KGO +C----------------------------------------------------------------------- +C Block F. +C The following block handles the case of a successful return from the +C core integrator (KFLAG = 0). Test for stop conditions. +C----------------------------------------------------------------------- + + + 300 INIT = 1 + KUTH = 0 + GO TO (310, 400, 330, 340, 350), ITASK +C ITASK = 1. If TOUT has been reached, interpolate. ------------------- + 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + + T = TOUT + GO TO 420 +C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ + 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 + GO TO 250 +C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. + 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 + CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) + T = TOUT + GO TO 420 + 345 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX + IF (IHIT) GO TO 400 + TNEXT = TN + HNEW*(ONE + FOUR*UROUND) + IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 + H = (TCRIT - TN)*(ONE - FOUR*UROUND) + KUTH = 1 + GO TO 250 +C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- + + 350 HMX = ABS(TN) + ABS(H) + IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX +C----------------------------------------------------------------------- +C Block G. +C The following block handles all successful returns from DVODE. +C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. +C ISTATE is set to 2, and the optional output is loaded into the work +C arrays before returning. +C----------------------------------------------------------------------- + 400 CONTINUE + CALL DCOPY (N, RWORK(LYH), 1, Y, 1) + T = TN + IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 + IF (IHIT) T = TCRIT + 420 ISTATE = 2 + RWORK(11) = HU + RWORK(12) = HNEW + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NEWQ + IWORK(19) = NLU + IWORK(20) = NNI + IWORK(21) = NCFN + IWORK(22) = NETF + RETURN +C----------------------------------------------------------------------- +C Block H. +C The following block handles all unsuccessful returns other than +C those for illegal input. First the error message routine is called. +C if there was an error test or convergence test failure, IMXER is set. +C Then Y is loaded from YH, T is set to TN, and the illegal input +C The optional output is loaded into the work arrays before returning. +C----------------------------------------------------------------------- +C The maximum number of steps was taken before reaching TOUT. ---------- + 500 MSG = 'DVODE-- At current T (=R1), MXSTEP (=I1) steps ' + CALL XERRWD (MSG, 50, 201, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' taken on this call before reaching TOUT ' + CALL XERRWD (MSG, 50, 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) + ISTATE = -1 + GO TO 580 +C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- + 510 EWTI = RWORK(LEWT+I-1) + MSG = 'DVODE-- At T (=R1), EWT(I1) has become R2 .le. 0.' + CALL XERRWD (MSG, 50, 202, 1, 1, I, 0, 2, TN, EWTI) + ISTATE = -6 + GO TO 580 +C Too much accuracy requested for machine precision. ------------------- + 520 MSG = 'DVODE-- At T (=R1), too much accuracy requested ' + CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' for precision of machine.. see TOLSF (=R2) ' + CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 2, TN, TOLSF) + RWORK(14) = TOLSF + ISTATE = -2 + GO TO 580 +C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- + 530 MSG = 'DVODE-- At T(=R1) and step size H(=R2), the error' + CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' test failed repeatedly or with abs(H) = HMIN' + CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 2, TN, H) + ISTATE = -4 + GO TO 560 +C KFLAG = -2. Convergence failed repeatedly or with abs(H) = HMIN. ---- + 540 MSG = 'DVODE-- At T (=R1) and step size H (=R2), the ' + CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' corrector convergence failed repeatedly ' + CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG = ' or with abs(H) = HMIN ' + CALL XERRWD (MSG, 30, 205, 1, 0, 0, 0, 2, TN, H) + ISTATE = -5 +C Compute IMXER if relevant. ------------------------------------------- + 560 BIG = ZERO + IMXER = 1 + DO 570 I = 1,N + SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) + IF (BIG .GE. SIZE) GO TO 570 + BIG = SIZE + IMXER = I + 570 CONTINUE + IWORK(16) = IMXER +C Set Y vector, T, and optional output. -------------------------------- + 580 CONTINUE + CALL DCOPY (N, RWORK(LYH), 1, Y, 1) + T = TN + RWORK(11) = HU + RWORK(12) = H + RWORK(13) = TN + IWORK(11) = NST + IWORK(12) = NFE + IWORK(13) = NJE + IWORK(14) = NQU + IWORK(15) = NQ + IWORK(19) = NLU + IWORK(20) = NNI + IWORK(21) = NCFN + IWORK(22) = NETF + RETURN +C----------------------------------------------------------------------- +C Block I. + +C The following block handles all error returns due to illegal input +C (ISTATE = -3), as detected before calling the core integrator. +C First the error message routine is called. If the illegal input +C is a negative ISTATE, the run is aborted (apparent infinite loop). +C----------------------------------------------------------------------- + 601 MSG = 'DVODE-- ISTATE (=I1) illegal ' + CALL XERRWD (MSG, 30, 1, 1, 1, ISTATE, 0, 0, ZERO, ZERO) + IF (ISTATE .LT. 0) GO TO 800 + GO TO 700 + + + 602 MSG = 'DVODE-- ITASK (=I1) illegal ' + CALL XERRWD (MSG, 30, 2, 1, 1, ITASK, 0, 0, ZERO, ZERO) + GO TO 700 + 603 MSG='DVODE-- ISTATE (=I1) .gt. 1 but DVODE not initialized ' + CALL XERRWD (MSG, 60, 3, 1, 1, ISTATE, 0, 0, ZERO, ZERO) + GO TO 700 + 604 MSG = 'DVODE-- NEQ (=I1) .lt. 1 ' + CALL XERRWD (MSG, 30, 4, 1, 1, NEQ, 0, 0, ZERO, ZERO) + GO TO 700 + + 605 MSG = 'DVODE-- ISTATE = 3 and NEQ increased (I1 to I2) ' + CALL XERRWD (MSG, 50, 5, 1, 2, N, NEQ, 0, ZERO, ZERO) + GO TO 700 + + 606 MSG = 'DVODE-- ITOL (=I1) illegal ' + CALL XERRWD (MSG, 30, 6, 1, 1, ITOL, 0, 0, ZERO, ZERO) + GO TO 700 + 607 MSG = 'DVODE-- IOPT (=I1) illegal ' + CALL XERRWD (MSG, 30, 7, 1, 1, IOPT, 0, 0, ZERO, ZERO) + GO TO 700 + 608 MSG = 'DVODE-- MF (=I1) illegal ' + CALL XERRWD (MSG, 30, 8, 1, 1, MF, 0, 0, ZERO, ZERO) + GO TO 700 + 609 MSG = 'DVODE-- ML (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' + CALL XERRWD (MSG, 50, 9, 1, 2, ML, NEQ, 0, ZERO, ZERO) + + + GO TO 700 + 610 MSG = 'DVODE-- MU (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' + CALL XERRWD (MSG, 50, 10, 1, 2, MU, NEQ, 0, ZERO, ZERO) + GO TO 700 + 611 MSG = 'DVODE-- MAXORD (=I1) .lt. 0 ' + CALL XERRWD (MSG, 30, 11, 1, 1, MAXORD, 0, 0, ZERO, ZERO) + GO TO 700 + 612 MSG = 'DVODE-- MXSTEP (=I1) .lt. 0 ' + CALL XERRWD (MSG, 30, 12, 1, 1, MXSTEP, 0, 0, ZERO, ZERO) + GO TO 700 + 613 MSG = 'DVODE-- MXHNIL (=I1) .lt. 0 ' + CALL XERRWD (MSG, 30, 13, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) + GO TO 700 + 614 MSG = 'DVODE-- TOUT (=R1) behind T (=R2) ' + CALL XERRWD (MSG, 40, 14, 1, 0, 0, 0, 2, TOUT, T) + MSG = ' integration direction is given by H0 (=R1) ' + CALL XERRWD (MSG, 50, 14, 1, 0, 0, 0, 1, H0, ZERO) + GO TO 700 + 615 MSG = 'DVODE-- HMAX (=R1) .lt. 0.0 ' + CALL XERRWD (MSG, 30, 15, 1, 0, 0, 0, 1, HMAX, ZERO) + GO TO 700 + 616 MSG = 'DVODE-- HMIN (=R1) .lt. 0.0 ' + CALL XERRWD (MSG, 30, 16, 1, 0, 0, 0, 1, HMIN, ZERO) + GO TO 700 + 617 CONTINUE + MSG='DVODE-- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' + CALL XERRWD (MSG, 60, 17, 1, 2, LENRW, LRW, 0, ZERO, ZERO) + GO TO 700 + 618 CONTINUE + MSG='DVODE-- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' + CALL XERRWD (MSG, 60, 18, 1, 2, LENIW, LIW, 0, ZERO, ZERO) + + GO TO 700 + 619 MSG = 'DVODE-- RTOL is R1 .lt. 0.0 ' + CALL XERRWD (MSG, 40, 19, 1, 1, I, 0, 1, RTOLI, ZERO) + GO TO 700 + 620 MSG = 'DVODE-- ATOL(I1) is R1 .lt. 0.0 ' + CALL XERRWD (MSG, 40, 20, 1, 1, I, 0, 1, ATOLI, ZERO) + + GO TO 700 + + 621 EWTI = RWORK(LEWT+I-1) + MSG = 'DVODE-- EWT(I1) is R1 .le. 0.0 ' + CALL XERRWD (MSG, 40, 21, 1, 1, I, 0, 1, EWTI, ZERO) + GO TO 700 + 622 CONTINUE + MSG='DVODE-- TOUT (=R1) too close to T(=R2) to start integration' + CALL XERRWD (MSG, 60, 22, 1, 0, 0, 0, 2, TOUT, T) + GO TO 700 + 623 CONTINUE + MSG='DVODE-- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' + CALL XERRWD (MSG, 60, 23, 1, 1, ITASK, 0, 2, TOUT, TP) + GO TO 700 + 624 CONTINUE + + MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' + CALL XERRWD (MSG, 60, 24, 1, 0, 0, 0, 2, TCRIT, TN) + GO TO 700 + 625 CONTINUE + MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' + CALL XERRWD (MSG, 60, 25, 1, 0, 0, 0, 2, TCRIT, TOUT) + GO TO 700 + + 626 MSG = 'DVODE-- At start of problem, too much accuracy ' + CALL XERRWD (MSG, 50, 26, 1, 0, 0, 0, 0, ZERO, ZERO) + MSG=' requested for precision of machine.. see TOLSF (=R1) ' + CALL XERRWD (MSG, 60, 26, 1, 0, 0, 0, 1, TOLSF, ZERO) + RWORK(14) = TOLSF + GO TO 700 + 627 MSG='DVODE-- Trouble from DVINDY. ITASK = I1, TOUT = R1. ' + CALL XERRWD (MSG, 60, 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) +C + 700 CONTINUE + ISTATE = -3 + RETURN +C + 800 MSG = 'DVODE-- Run aborted.. apparent infinite loop ' + CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, ZERO, ZERO) + RETURN +C----------------------- End of Subroutine DVODE ----------------------- + END +*DECK DVHIN + SUBROUTINE DVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, + 1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER) + EXTERNAL F + DOUBLE PRECISION T0, Y0, YDOT, RPAR, TOUT, UROUND, EWT, ATOL, Y, + 1 TEMP, H0 + INTEGER N, IPAR, ITOL, NITER, IER + DIMENSION Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), + 1 TEMP(*) +C----------------------------------------------------------------------- +C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, +C EWT, ITOL, ATOL, Y, TEMP +C Call sequence output -- H0, NITER, IER +C COMMON block variables accessed -- None +C +C Subroutines called by DVHIN.. F +C Function routines called by DVHIN.. DVNORM +C----------------------------------------------------------------------- +C This routine computes the step size, H0, to be attempted on the +C first step, when the user has not supplied a value for this. +C +C First we check that TOUT - T0 differs significantly from zero. Then +C an iteration is done to approximate the initial second derivative +C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. +C A bias factor of 1/2 is applied to the resulting h. +C The sign of H0 is inferred from the initial values of TOUT and T0. +C +C Communication with DVHIN is done with the following variables.. +C +C N = Size of ODE system, input. +C T0 = Initial value of independent variable, input. +C Y0 = Vector of initial conditions, input. +C YDOT = Vector of initial first derivatives, input. +C F = Name of subroutine for right-hand side f(t,y), input. +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C TOUT = First output value of independent variable +C UROUND = Machine unit roundoff +C EWT, ITOL, ATOL = Error weights and tolerance parameters +C as described in the driver routine, input. +C Y, TEMP = Work arrays of length N. +C H0 = Step size to be attempted, output. +C NITER = Number of iterations (and of f evaluations) to compute H0, +C output. +C IER = The error flag, returned with the value +C IER = 0 if no trouble occurred, or +C IER = -1 if TOUT and T0 are considered too close to proceed. +C----------------------------------------------------------------------- +C +C Type declarations for local variables -------------------------------- +C + DOUBLE PRECISION AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT, + 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM + + INTEGER I, ITER +C +C Type declaration for function subroutines called --------------------- +C + DOUBLE PRECISION DVNORM +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE HALF, HUN, PT1, TWO + DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ +C + + NITER = 0 + TDIST = ABS(TOUT - T0) + TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) + IF (TDIST .LT. TWO*TROUND) GO TO 100 +C +C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- + HLB = HUN*TROUND +C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - + HUB = PT1*TDIST + ATOLI = ATOL(1) + DO 10 I = 1, N + IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) + DELYI = PT1*ABS(Y0(I)) + ATOLI + AFI = ABS(YDOT(I)) + IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI + 10 CONTINUE +C +C Set initial guess for h as geometric mean of upper and lower bounds. - + ITER = 0 + HG = SQRT(HLB*HUB) +C If the bounds have crossed, exit with the mean value. ---------------- + IF (HUB .LT. HLB) THEN + H0 = HG + GO TO 90 + ENDIF +C +C Looping point for iteration. ----------------------------------------- + 50 CONTINUE +C Estimate the second derivative as a difference quotient in f. -------- + T1 = T0 + HG + DO 60 I = 1, N + 60 Y(I) = Y0(I) + HG*YDOT(I) + CALL F (N, T1, Y, TEMP, RPAR, IPAR) + DO 70 I = 1, N + 70 TEMP(I) = (TEMP(I) - YDOT(I))/HG + YDDNRM = DVNORM (N, TEMP, EWT) +C Get the corresponding new value of h. -------------------------------- + IF (YDDNRM*HUB*HUB .GT. TWO) THEN + HNEW = SQRT(TWO/YDDNRM) + ELSE + HNEW = SQRT(HG*HUB) + ENDIF + ITER = ITER + 1 +C----------------------------------------------------------------------- +C Test the stopping conditions. +C Stop if the new and previous h values differ by a factor of .lt. 2. +C Stop if four iterations have been done. Also, stop with previous h +C if HNEW/HG .gt. 2 after first iteration, as this probably means that +C the second derivative value is bad because of cancellation error. +C----------------------------------------------------------------------- + IF (ITER .GE. 4) GO TO 80 + HRAT = HNEW/HG + IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 + IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN + HNEW = HG + GO TO 80 + ENDIF + HG = HNEW + GO TO 50 +C +C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- + 80 H0 = HNEW*HALF + IF (H0 .LT. HLB) H0 = HLB + IF (H0 .GT. HUB) H0 = HUB + 90 H0 = SIGN(H0, TOUT - T0) + NITER = ITER + IER = 0 + RETURN +C Error return for TOUT - T0 too small. -------------------------------- + 100 IER = -1 + RETURN +C----------------------- End of Subroutine DVHIN ----------------------- + END +*DECK DVINDY + SUBROUTINE DVINDY (T, K, YH, LDYH, DKY, IFLAG) + DOUBLE PRECISION T, YH, DKY + INTEGER K, LDYH, IFLAG + DIMENSION YH(LDYH,*), DKY(*) +C----------------------------------------------------------------------- +C Call sequence input -- T, K, YH, LDYH + +C Call sequence output -- DKY, IFLAG +C COMMON block variables accessed.. +C /DVOD01/ -- H, TN, UROUND, L, N, NQ +C /DVOD02/ -- HU +C +C Subroutines called by DVINDY.. DSCAL, XERRWD +C Function routines called by DVINDY.. None +C----------------------------------------------------------------------- +C DVINDY computes interpolated values of the K-th derivative of the +C dependent variable vector y, and stores it in DKY. This routine +C is called within the package with K = 0 and T = TOUT, but may +C also be called by the user for any K up to the current order. +C (See detailed instructions in the usage documentation.) +C----------------------------------------------------------------------- +C The computed values in DKY are gotten by interpolation using the +C Nordsieck history array YH. This array corresponds uniquely to a +C vector-valued polynomial of degree NQCUR or less, and DKY is set +C to the K-th derivative of this polynomial at T. +C The formula for DKY is.. +C q +C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) +C j=K +C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. +C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are +C communicated by COMMON. The above sum is done in reverse order. +C IFLAG is returned negative if either K or T is out of bounds. +C +C Discussion above and comments in driver explain all variables. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + DOUBLE PRECISION HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + DOUBLE PRECISION C, HUN, R, S, TFUZZ, TN1, TP, ZERO + INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 + CHARACTER*80 MSG +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE HUN, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + DATA HUN /100.0D0/, ZERO /0.0D0/ +C + IFLAG = 0 + IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 + TFUZZ = HUN*UROUND*(TN + HU) + TP = TN - HU - TFUZZ + + TN1 = TN + TFUZZ + + IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 +C + S = (T - TN)/H + IC = 1 + IF (K .EQ. 0) GO TO 15 + JJ1 = L - K + DO 10 JJ = JJ1, NQ + 10 IC = IC*JJ + 15 C = REAL(IC) + DO 20 I = 1, N + 20 DKY(I) = C*YH(I,L) + IF (K .EQ. NQ) GO TO 55 + + JB2 = NQ - K + DO 50 JB = 1, JB2 + J = NQ - JB + JP1 = J + 1 + + + IC = 1 + IF (K .EQ. 0) GO TO 35 + JJ1 = JP1 - K + DO 30 JJ = JJ1, J + 30 IC = IC*JJ + 35 C = REAL(IC) + DO 40 I = 1, N + 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) + 50 CONTINUE + IF (K .EQ. 0) RETURN + 55 R = H**(-K) + CALL DSCAL (N, R, DKY, 1) + RETURN +C + 80 MSG = 'DVINDY-- K (=I1) illegal ' + CALL XERRWD (MSG, 30, 51, 1, 1, K, 0, 0, ZERO, ZERO) + IFLAG = -1 + RETURN + 90 MSG = 'DVINDY-- T (=R1) illegal ' + CALL XERRWD (MSG, 30, 52, 1, 0, 0, 0, 1, T, ZERO) + MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' + CALL XERRWD (MSG, 60, 52, 1, 0, 0, 0, 2, TP, TN) + IFLAG = -2 + RETURN +C----------------------- End of Subroutine DVINDY ---------------------- + END +*DECK DVSTEP + SUBROUTINE DVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, + 1 WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) + EXTERNAL F, JAC, PSOL, VNLS + DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, VSAV, ACOR, WM, RPAR + INTEGER LDYH, IWM, IPAR + DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), + 1 ACOR(*), WM(*), IWM(*) +C----------------------------------------------------------------------- +C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, +C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR +C Call sequence output -- YH, ACOR, WM, IWM +C COMMON block variables accessed.. +C /DVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), +C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, +C L, LMAX, MAXORD, MITER, N, NEWQ, NQ, NQWAIT +C /DVOD02/ HU, NCFN, NETF, NFE, NQU, NST +C +C Subroutines called by DVSTEP.. F, DAXPY, DCOPY, DSCAL, +C DVJUST, VNLS, DVSET +C Function routines called by DVSTEP.. DVNORM +C----------------------------------------------------------------------- +C DVSTEP performs one step of the integration of an initial value +C problem for a system of ordinary differential equations. +C DVSTEP calls subroutine VNLS for the solution of the nonlinear system +C arising in the time step. Thus it is independent of the problem +C Jacobian structure and the type of nonlinear system solution method. +C DVSTEP returns a completion flag KFLAG (in COMMON). +C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 +C consecutive failures occurred. On a return with KFLAG negative, +C the values of TN and the YH array are as of the beginning of the last + +C step, and H is the last step size attempted. +C +C Communication with DVSTEP is done with the following variables.. +C +C Y = An array of length N used for the dependent variable vector. +C YH = An LDYH by LMAX array containing the dependent variables +C and their approximate scaled derivatives, where +C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate +C j-th derivative of y(i), scaled by H**j/factorial(j) +C (j = 0,1,...,NQ). On entry for the first step, the first +C two columns of YH must be set from the initial values. +C LDYH = A constant integer .ge. N, the first dimension of YH. +C N is the number of ODEs in the system. +C YH1 = A one-dimensional array occupying the same space as YH. + +C EWT = An array of length N containing multiplicative weights +C for local error measurements. Local errors in y(i) are +C compared to 1.0/EWT(i) in various error tests. +C SAVF = An array of working storage, of length N. + + +C also used for input of YH(*,MAXORD+2) when JSTART = -1 +C and MAXORD .lt. the current order NQ. +C VSAV = A work array of length N passed to subroutine VNLS. +C ACOR = A work array of length N, used for the accumulated +C corrections. On a successful return, ACOR(i) contains +C the estimated one-step local error in y(i). +C WM,IWM = Real and integer work arrays associated with matrix +C operations in VNLS. +C F = Dummy name for the user supplied subroutine for f. +C JAC = Dummy name for the user supplied Jacobian subroutine. +C PSOL = Dummy name for the subroutine passed to VNLS, for +C possible use there. +C VNLS = Dummy name for the nonlinear system solving subroutine, +C whose real name is dependent on the method used. +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH + +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + + DOUBLE PRECISION HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + DOUBLE PRECISION ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, + + + 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, + 2 ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, + 3 R, THRESH, TOLD, ZERO + INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG +C +C Type declaration for function subroutines called --------------------- +C + DOUBLE PRECISION DVNORM +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE ADDON, BIAS1, BIAS2, BIAS3, + + 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, + 2 KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO +C----------------------------------------------------------------------- + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + + DATA KFC/-3/, KFH/-7/, MXNCF/10/ + DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, + 1 BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, + 2 ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D0/, + 3 ETAMX3 /10.0D0/, ONEPSM /1.00001D0/, THRESH /1.5D0/ + DATA ONE/1.0D0/, ZERO/0.0D0/ +C + KFLAG = 0 + TOLD = TN + NCF = 0 + JCUR = 0 + NFLAG = 0 + IF (JSTART .GT. 0) GO TO 20 + IF (JSTART .EQ. -1) GO TO 100 +C----------------------------------------------------------------------- +C On the first call, the order is set to 1, and other variables are +C initialized. ETAMAX is the maximum ratio by which H can be increased +C in a single step. It is normally 1.5, but is larger during the +C first 10 steps to compensate for the small initial H. If a failure +C occurs (in corrector convergence or error test), ETAMAX is set to 1 +C for the next increase. +C----------------------------------------------------------------------- + LMAX = MAXORD + 1 + NQ = 1 + L = 2 + NQNYH = NQ*LDYH + TAU(1) = H + PRL1 = ONE + RC = ZERO + ETAMAX = ETAMX1 + NQWAIT = 2 + HSCAL = H + GO TO 200 +C----------------------------------------------------------------------- +C Take preliminary actions on a normal continuation step (JSTART.GT.0). + + +C If the driver changed H, then ETA must be reset and NEWH set to 1. +C If a change of order was dictated on the previous step, then +C it is done here and appropriate adjustments in the history are made. +C On an order decrease, the history array is adjusted by DVJUST. +C On an order increase, the history array is augmented by a column. +C On a change of step size H, the history array YH is rescaled. +C----------------------------------------------------------------------- + 20 CONTINUE + + IF (KUTH .EQ. 1) THEN + ETA = MIN(ETA,H/HSCAL) + NEWH = 1 + ENDIF + 50 IF (NEWH .EQ. 0) GO TO 200 + IF (NEWQ .EQ. NQ) GO TO 150 + IF (NEWQ .LT. NQ) THEN + CALL DVJUST (YH, LDYH, -1) + NQ = NEWQ + L = NQ + 1 + NQWAIT = L + GO TO 150 + ENDIF + IF (NEWQ .GT. NQ) THEN + CALL DVJUST (YH, LDYH, 1) + NQ = NEWQ + L = NQ + 1 + NQWAIT = L + GO TO 150 + ENDIF +C----------------------------------------------------------------------- +C The following block handles preliminaries needed when JSTART = -1. +C If N was reduced, zero out part of YH to avoid undefined references. +C If MAXORD was reduced to a value less than the tentative order NEWQ, +C then NQ is set to MAXORD, and a new H ratio ETA is chosen. +C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. +C In any case, NQWAIT is reset to L = NQ + 1 to prevent further +C changes in order for that many steps. +C The new H ratio ETA is limited by the input H if KUTH = 1, +C by HMIN if KUTH = 0, and by HMXI in any case. +C Finally, the history array YH is rescaled. +C----------------------------------------------------------------------- + 100 CONTINUE + LMAX = MAXORD + 1 + IF (N .EQ. LDYH) GO TO 120 + I1 = 1 + (NEWQ + 1)*LDYH + I2 = (MAXORD + 1)*LDYH + IF (I1 .GT. I2) GO TO 120 + DO 110 I = I1, I2 + 110 YH1(I) = ZERO + 120 IF (NEWQ .LE. MAXORD) GO TO 140 + FLOTL = REAL(LMAX) + IF (MAXORD .LT. NQ-1) THEN + DDN = DVNORM (N, SAVF, EWT)/TQ(1) + ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) + + ENDIF + IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ + IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN + ETA = ETAQM1 + CALL DVJUST (YH, LDYH, -1) + ENDIF + IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN + DDN = DVNORM (N, SAVF, EWT)/TQ(1) + ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) + CALL DVJUST (YH, LDYH, -1) + ENDIF + ETA = MIN(ETA,ONE) + NQ = MAXORD + L = LMAX + 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) + IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) + ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) + NEWH = 1 + + NQWAIT = L + IF (NEWQ .LE. MAXORD) GO TO 50 +C Rescale the history array for a change in H by a factor of ETA. ------ + 150 R = ONE + DO 180 J = 2, L + R = R*ETA + CALL DSCAL (N, R, YH(1,J), 1 ) + 180 CONTINUE + H = HSCAL*ETA + HSCAL = H + RC = RC*ETA + NQNYH = NQ*LDYH +C----------------------------------------------------------------------- +C This section computes the predicted values by effectively +C multiplying the YH array by the Pascal triangle matrix. +C DVSET is called to calculate all integration coefficients. +C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. +C----------------------------------------------------------------------- + 200 TN = TN + H + I1 = NQNYH + 1 + DO 220 JB = 1, NQ + I1 = I1 - LDYH + DO 210 I = I1, NQNYH + 210 YH1(I) = YH1(I) + YH1(I+LDYH) + 220 CONTINUE + CALL DVSET + + RL1 = ONE/EL(2) + RC = RC*(RL1/PRL1) + PRL1 = RL1 +C +C Call the nonlinear system solver. ------------------------------------ +C + CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, + 1 F, JAC, PSOL, NFLAG, RPAR, IPAR) +C + IF (NFLAG .EQ. 0) GO TO 450 + +C----------------------------------------------------------------------- +C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). +C The YH array is retracted to its values before prediction. +C The step size H is reduced and the step is retried, if possible. +C Otherwise, an error exit is taken. +C----------------------------------------------------------------------- + NCF = NCF + 1 + NCFN = NCFN + 1 + ETAMAX = ONE + TN = TOLD + I1 = NQNYH + 1 + DO 430 JB = 1, NQ + I1 = I1 - LDYH + DO 420 I = I1, NQNYH + 420 YH1(I) = YH1(I) - YH1(I+LDYH) + 430 CONTINUE + IF (NFLAG .LT. -1) GO TO 680 + IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 + IF (NCF .EQ. MXNCF) GO TO 670 + + ETA = ETACF + ETA = MAX(ETA,HMIN/ABS(H)) + NFLAG = -1 + GO TO 150 +C----------------------------------------------------------------------- +C The corrector has converged (NFLAG = 0). The local error test is +C made and control passes to statement 500 if it fails. +C----------------------------------------------------------------------- + 450 CONTINUE + DSM = ACNRM/TQ(2) + IF (DSM .GT. ONE) GO TO 500 +C----------------------------------------------------------------------- +C After a successful step, update the YH and TAU arrays and decrement +C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved +C for use in a possible order increase on the next step. +C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. +C----------------------------------------------------------------------- + KFLAG = 0 + NST = NST + 1 + HU = H + NQU = NQ + DO 470 IBACK = 1, NQ + I = L - IBACK + 470 TAU(I+1) = TAU(I) + TAU(1) = H + DO 480 J = 1, L + CALL DAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) + 480 CONTINUE + NQWAIT = NQWAIT - 1 + IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 + CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) + CONP = TQ(5) + 490 IF (ETAMAX .NE. ONE) GO TO 560 + IF (NQWAIT .LT. 2) NQWAIT = 2 + NEWQ = NQ + NEWH = 0 + ETA = ONE + HNEW = H + GO TO 690 +C----------------------------------------------------------------------- +C The error test failed. KFLAG keeps track of multiple failures. +C Restore TN and the YH array to their previous values, and prepare +C to try the step again. Compute the optimum step size for the +C same order. After repeated failures, H is forced to decrease +C more rapidly. +C----------------------------------------------------------------------- + 500 KFLAG = KFLAG - 1 + NETF = NETF + 1 + NFLAG = -2 + TN = TOLD + I1 = NQNYH + 1 + DO 520 JB = 1, NQ + I1 = I1 - LDYH + DO 510 I = I1, NQNYH + 510 YH1(I) = YH1(I) - YH1(I+LDYH) + 520 CONTINUE + IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 + ETAMAX = ONE + IF (KFLAG .LE. KFC) GO TO 530 +C Compute ratio of new H to current H at the current order. ------------ + FLOTL = REAL(L) + ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) + ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) + IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF + GO TO 150 +C----------------------------------------------------------------------- + +C Control reaches this section if 3 or more consecutive failures +C have occurred. It is assumed that the elements of the YH array +C have accumulated errors of the wrong order. The order is reduced +C by one, if possible. Then H is reduced by a factor of 0.1 and +C the step is retried. After a total of 7 consecutive failures, + +C an exit is taken with KFLAG = -1. +C----------------------------------------------------------------------- + 530 IF (KFLAG .EQ. KFH) GO TO 660 + IF (NQ .EQ. 1) GO TO 540 + ETA = MAX(ETAMIN,HMIN/ABS(H)) + CALL DVJUST (YH, LDYH, -1) + L = NQ + NQ = NQ - 1 + NQWAIT = L + GO TO 150 + 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) + H = H*ETA + HSCAL = H + TAU(1) = H + CALL F (N, TN, Y, SAVF, RPAR, IPAR) + NFE = NFE + 1 + DO 550 I = 1, N + 550 YH(I,2) = H*SAVF(I) + NQWAIT = 10 + GO TO 200 +C----------------------------------------------------------------------- +C If NQWAIT = 0, an increase or decrease in order by one is considered. +C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could +C be multiplied at order q, q-1, or q+1, respectively. +C The largest of these is determined, and the new order and +C step size set accordingly. +C A change of H or NQ is made only if H increases by at least a +C factor of THRESH. If an order change is considered and rejected, + +C then NQWAIT is set to 2 (reconsider it after 2 steps). +C----------------------------------------------------------------------- +C Compute ratio of new H to current H at the current order. ------------ + 560 FLOTL = REAL(L) + ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) + IF (NQWAIT .NE. 0) GO TO 600 + NQWAIT = 2 + ETAQM1 = ZERO + IF (NQ .EQ. 1) GO TO 570 +C Compute ratio of new H to current H at the current order less one. --- + + DDN = DVNORM (N, YH(1,L), EWT)/TQ(1) + ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) + 570 ETAQP1 = ZERO + IF (L .EQ. LMAX) GO TO 580 +C Compute ratio of new H to current H at current order plus one. ------- + + CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L + + + DO 575 I = 1, N + 575 SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) + DUP = DVNORM (N, SAVF, EWT)/TQ(3) + ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) + 580 IF (ETAQ .GE. ETAQP1) GO TO 590 + IF (ETAQP1 .GT. ETAQM1) GO TO 620 + GO TO 610 + 590 IF (ETAQ .LT. ETAQM1) GO TO 610 + 600 ETA = ETAQ + NEWQ = NQ + GO TO 630 + 610 ETA = ETAQM1 + NEWQ = NQ - 1 + GO TO 630 + 620 ETA = ETAQP1 + NEWQ = NQ + 1 + CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1) +C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- + 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 + ETA = MIN(ETA,ETAMAX) + ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) + NEWH = 1 + HNEW = H*ETA + GO TO 690 + 640 NEWQ = NQ + NEWH = 0 + ETA = ONE + HNEW = H + GO TO 690 +C----------------------------------------------------------------------- +C All returns are made through this section. +C On a successful return, ETAMAX is reset and ACOR is scaled. + +C----------------------------------------------------------------------- + 660 KFLAG = -1 + GO TO 720 + 670 KFLAG = -2 + GO TO 720 + 680 IF (NFLAG .EQ. -2) KFLAG = -3 + IF (NFLAG .EQ. -3) KFLAG = -4 + GO TO 720 + 690 ETAMAX = ETAMX3 + IF (NST .LE. 10) ETAMAX = ETAMX2 + 700 R = ONE/TQ(2) + CALL DSCAL (N, R, ACOR, 1) + 720 JSTART = 1 + RETURN +C----------------------- End of Subroutine DVSTEP ---------------------- + + END +*DECK DVSET + SUBROUTINE DVSET +C----------------------------------------------------------------------- +C Call sequence communication.. None +C COMMON block variables accessed.. +C /DVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), + +C METH, NQ, NQWAIT +C +C Subroutines called by DVSET.. None +C Function routines called by DVSET.. None +C----------------------------------------------------------------------- +C DVSET is called by DVSTEP and sets coefficients for use there. +C +C For each order NQ, the coefficients in EL are calculated by use of +C the generating polynomial lambda(x), with coefficients EL(i). +C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). +C For the backward differentiation formulas, +C NQ-1 +C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . +C i = 1 +C For the Adams formulas, +C NQ-1 + +C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , + +C i = 1 +C lambda(-1) = 0, lambda(0) = 1, +C where c is a normalization constant. +C In both cases, xi(i) is defined by +C H*xi(i) = t sub n - t sub (n-i) + +C = H + TAU(1) + TAU(2) + ... TAU(i-1). + +C +C +C In addition to variables described previously, communication +C with DVSET uses the following.. +C TAU = A vector of length 13 containing the past NQ values +C of H. +C EL = A vector of length 13 in which vset stores the +C coefficients for the corrector formula. +C TQ = A vector of length 5 in which vset stores constants +C used for the convergence test, the error test, and the +C selection of H at a new order. +C METH = The basic method indicator. +C NQ = The current order. +C L = NQ + 1, the length of the vector stored in EL, and +C the number of columns of the YH array being used. +C NQWAIT = A counter controlling the frequency of order changes. +C An order change is about to be considered if NQWAIT = 1. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for local variables -------------------------------- +C + DOUBLE PRECISION AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, + 1 EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, + 2 T1, T2, T3, T4, T5, T6, TWO, XI, ZERO + INTEGER I, IBACK, J, JP1, NQM1, NQM2 +C + DIMENSION EM(13) +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE CORTES, ONE, SIX, TWO, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH +C + DATA CORTES /0.1D0/ + DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ +C + FLOTL = REAL(L) + NQM1 = NQ - 1 + NQM2 = NQ - 2 + GO TO (100, 200), METH +C +C Set coefficients for Adams methods. ---------------------------------- + 100 IF (NQ .NE. 1) GO TO 110 + EL(1) = ONE + EL(2) = ONE + TQ(1) = ONE + TQ(2) = TWO + TQ(3) = SIX*TQ(2) + TQ(5) = ONE + GO TO 300 + 110 HSUM = H + EM(1) = ONE + FLOTNQ = FLOTL - ONE + DO 115 I = 2, L + 115 EM(I) = ZERO + DO 150 J = 1, NQM1 + IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 + S = ONE + CSUM = ZERO + + DO 120 I = 1, NQM1 + CSUM = CSUM + S*EM(I)/REAL(I+1) + 120 S = -S + TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) + 130 RXI = H/HSUM + DO 140 IBACK = 1, J + I = (J + 2) - IBACK + 140 EM(I) = EM(I) + EM(I-1)*RXI + HSUM = HSUM + TAU(J) + 150 CONTINUE +C Compute integral from -1 to 0 of polynomial and of x times it. ------- + S = ONE + EM0 = ZERO + CSUM = ZERO + DO 160 I = 1, NQ + FLOTI = REAL(I) + EM0 = EM0 + S*EM(I)/FLOTI + CSUM = CSUM + S*EM(I)/(FLOTI+ONE) + 160 S = -S +C In EL, form coefficients of normalized integrated polynomial. -------- + S = ONE/EM0 + EL(1) = ONE + DO 170 I = 1, NQ + 170 EL(I+1) = S*EM(I)/REAL(I) + XI = HSUM/H + TQ(2) = XI*EM0/CSUM + TQ(5) = XI/EL(L) + IF (NQWAIT .NE. 1) GO TO 300 +C For higher order control constant, multiply polynomial by 1+x/xi(q). - + RXI = ONE/XI + DO 180 IBACK = 1, NQ + I = (L + 1) - IBACK + 180 EM(I) = EM(I) + EM(I-1)*RXI +C Compute integral of polynomial. -------------------------------------- + S = ONE + + CSUM = ZERO + DO 190 I = 1, L + CSUM = CSUM + S*EM(I)/REAL(I+1) + 190 S = -S + TQ(3) = FLOTL*EM0/CSUM + GO TO 300 +C +C Set coefficients for BDF methods. ------------------------------------ + 200 DO 210 I = 3, L + 210 EL(I) = ZERO + EL(1) = ONE + EL(2) = ONE + ALPH0 = -ONE + AHATN0 = -ONE + HSUM = H + RXI = ONE + RXIS = ONE + IF (NQ .EQ. 1) GO TO 240 + + DO 230 J = 1, NQM2 +C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ + HSUM = HSUM + TAU(J) + RXI = H/HSUM + JP1 = J + 1 + ALPH0 = ALPH0 - ONE/REAL(JP1) + DO 220 IBACK = 1, JP1 + I = (J + 3) - IBACK + 220 EL(I) = EL(I) + EL(I-1)*RXI + 230 CONTINUE + ALPH0 = ALPH0 - ONE/REAL(NQ) + RXIS = -EL(2) - ALPH0 + HSUM = HSUM + TAU(NQM1) + RXI = H/HSUM + AHATN0 = -EL(2) - RXI + DO 235 IBACK = 1, NQ + I = (NQ + 2) - IBACK + 235 EL(I) = EL(I) + EL(I-1)*RXIS + 240 T1 = ONE - AHATN0 + ALPH0 + T2 = ONE + REAL(NQ)*T1 + TQ(2) = ABS(ALPH0*T2/T1) + TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) + IF (NQWAIT .NE. 1) GO TO 300 + CNQM1 = RXIS/EL(L) + T3 = ALPH0 + ONE/REAL(NQ) + T4 = AHATN0 + RXI + ELP = T3/(ONE - T4 + T3) + TQ(1) = ABS(ELP/CNQM1) + HSUM = HSUM + TAU(NQ) + RXI = H/HSUM + T5 = ALPH0 - ONE/REAL(NQ+1) + T6 = AHATN0 - RXI + ELP = T2/(ONE - T6 + T5) + TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) + 300 TQ(4) = CORTES*TQ(2) + RETURN +C----------------------- End of Subroutine DVSET ----------------------- + END +*DECK DVJUST + SUBROUTINE DVJUST (YH, LDYH, IORD) + DOUBLE PRECISION YH + INTEGER LDYH, IORD + + DIMENSION YH(LDYH,*) +C----------------------------------------------------------------------- +C Call sequence input -- YH, LDYH, IORD +C Call sequence output -- YH +C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N +C COMMON block variables accessed.. +C /DVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, +C +C Subroutines called by DVJUST.. DAXPY +C Function routines called by DVJUST.. None +C----------------------------------------------------------------------- +C This subroutine adjusts the YH array on reduction of order, +C and also when the order is increased for the stiff option (METH = 2). +C Communication with DVJUST uses the following.. +C IORD = An integer flag used when METH = 2 to indicate an order +C increase (IORD = +1) or an order decrease (IORD = -1). +C HSCAL = Step size H used in scaling of Nordsieck array YH. +C (If IORD = +1, DVJUST assumes that HSCAL = TAU(1).) +C See References 1 and 2 for details. +C----------------------------------------------------------------------- +C + +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for local variables -------------------------------- +C + DOUBLE PRECISION ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO + INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE ONE, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH +C + DATA ONE /1.0D0/, ZERO /0.0D0/ +C + IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN + NQM1 = NQ - 1 + NQM2 = NQ - 2 + GO TO (100, 200), METH + +C----------------------------------------------------------------------- +C Nonstiff option... +C Check to see if the order is being increased or decreased. +C----------------------------------------------------------------------- + 100 CONTINUE + IF (IORD .EQ. 1) GO TO 180 + +C Order decrease. ------------------------------------------------------ + DO 110 J = 1, LMAX + 110 EL(J) = ZERO + EL(2) = ONE + HSUM = ZERO + DO 130 J = 1, NQM2 +C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- + HSUM = HSUM + TAU(J) + XI = HSUM/HSCAL + JP1 = J + 1 + DO 120 IBACK = 1, JP1 + I = (J + 3) - IBACK + 120 EL(I) = EL(I)*XI + EL(I-1) + 130 CONTINUE +C Construct coefficients of integrated polynomial. --------------------- + DO 140 J = 2, NQM1 + 140 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) +C Subtract correction terms from YH array. ----------------------------- + DO 170 J = 3, NQ + DO 160 I = 1, N + 160 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) + 170 CONTINUE + RETURN +C Order increase. ------------------------------------------------------ +C Zero out next column in YH array. ------------------------------------ + 180 CONTINUE + LP1 = L + 1 + DO 190 I = 1, N + 190 YH(I,LP1) = ZERO + RETURN +C----------------------------------------------------------------------- +C Stiff option... +C Check to see if the order is being increased or decreased. +C----------------------------------------------------------------------- + 200 CONTINUE + IF (IORD .EQ. 1) GO TO 300 + +C Order decrease. ------------------------------------------------------ + DO 210 J = 1, LMAX + 210 EL(J) = ZERO + EL(3) = ONE + HSUM = ZERO + DO 230 J = 1,NQM2 +C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + HSUM = HSUM + TAU(J) + XI = HSUM/HSCAL + + JP1 = J + 1 + DO 220 IBACK = 1, JP1 + I = (J + 4) - IBACK + 220 EL(I) = EL(I)*XI + EL(I-1) + 230 CONTINUE +C Subtract correction terms from YH array. ----------------------------- + DO 250 J = 3,NQ + DO 240 I = 1, N + 240 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) + 250 CONTINUE + RETURN +C Order increase. ------------------------------------------------------ + 300 DO 310 J = 1, LMAX + 310 EL(J) = ZERO + EL(3) = ONE + ALPH0 = -ONE + ALPH1 = ONE + PROD = ONE + XIOLD = ONE + HSUM = HSCAL + IF (NQ .EQ. 1) GO TO 340 + DO 330 J = 1, NQM1 +C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- + JP1 = J + 1 + HSUM = HSUM + TAU(JP1) + XI = HSUM/HSCAL + PROD = PROD*XI + ALPH0 = ALPH0 - ONE/REAL(JP1) + ALPH1 = ALPH1 + ONE/XI + DO 320 IBACK = 1, JP1 + I = (J + 4) - IBACK + 320 EL(I) = EL(I)*XIOLD + EL(I-1) + XIOLD = XI + 330 CONTINUE + 340 CONTINUE + T1 = (-ALPH0 - ALPH1)/PROD +C Load column L + 1 in YH array. --------------------------------------- + LP1 = L + 1 + DO 350 I = 1, N + + 350 YH(I,LP1) = T1*YH(I,LMAX) +C Add correction terms to YH array. ------------------------------------ + NQP1 = NQ + 1 + DO 370 J = 3, NQP1 + CALL DAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) + 370 CONTINUE + RETURN +C----------------------- End of Subroutine DVJUST ---------------------- + END +*DECK DVNLSD + SUBROUTINE DVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, + 1 F, JAC, PDUM, NFLAG, RPAR, IPAR) + + EXTERNAL F, JAC, PDUM + DOUBLE PRECISION Y, YH, VSAV, SAVF, EWT, ACOR, WM, RPAR + INTEGER LDYH, IWM, NFLAG, IPAR + DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), + 1 IWM(*), WM(*) +C----------------------------------------------------------------------- + +C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, +C F, JAC, NFLAG, RPAR, IPAR +C Call sequence output -- YH, ACOR, WM, IWM, NFLAG +C COMMON block variables accessed.. +C /DVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, + +C JCUR, METH, MITER, N, NSLP +C /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Subroutines called by DVNLSD.. F, DAXPY, DCOPY, DSCAL, DVJAC, DVSOL +C Function routines called by DVNLSD.. DVNORM + +C----------------------------------------------------------------------- +C Subroutine DVNLSD is a nonlinear system solver, which uses functional +C iteration or a chord (modified Newton) method. For the chord method +C direct linear algebraic system solvers are used. Subroutine DVNLSD +C then handles the corrector phase of this integration package. +C +C Communication with DVNLSD is done with the following variables. (For +C more details, please see the comments in the driver subroutine.) +C +C Y = The dependent variable, a vector of length N, input. +C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input +C and output. On input, it contains predicted values. +C LDYH = A constant .ge. N, the first dimension of YH, input. +C VSAV = Unused work array. +C SAVF = A work array of length N. +C EWT = An error weight vector of length N, input. +C ACOR = A work array of length N, used for the accumulated +C corrections to the predicted y vector. +C WM,IWM = Real and integer work arrays associated with matrix +C operations in chord iteration (MITER .ne. 0). +C F = Dummy name for user supplied routine for f. +C JAC = Dummy name for user supplied Jacobian routine. +C PDUM = Unused dummy subroutine name. Included for uniformity +C over collection of integrators. +C NFLAG = Input/output flag, with values and meanings as follows.. +C INPUT +C 0 first call for this time step. +C -1 convergence failure in previous call to DVNLSD. +C -2 error test failure in DVSTEP. +C OUTPUT +C 0 successful completion of nonlinear solver. +C -1 convergence failure or singular matrix. +C -2 unrecoverable error in matrix preprocessing +C (cannot occur here). +C -3 unrecoverable error in solution (cannot occur +C here). +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C +C IPUP = Own variable flag with values and meanings as follows.. +C 0, do not update the Newton matrix. +C MITER .ne. 0, update Newton matrix, because it is the +C initial step, order was changed, the error +C test failed, or an update is indicated by +C the scalar RC or step counter NST. +C +C For more details, see comments in driver subroutine. +C----------------------------------------------------------------------- +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + DOUBLE PRECISION HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C +C Type declarations for local variables -------------------------------- +C + DOUBLE PRECISION CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, + 1 RDIV, TWO, ZERO + INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP + +C +C Type declaration for function subroutines called --------------------- +C + DOUBLE PRECISION DVNORM +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, + 1 RDIV /2.0D0/ + + DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ +C----------------------------------------------------------------------- +C On the first step, on a change of method order, or after a +C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER +C to force a Jacobian update when MITER .ne. 0. +C----------------------------------------------------------------------- + IF (JSTART .EQ. 0) NSLP = 0 + IF (NFLAG .EQ. 0) ICF = 0 + IF (NFLAG .EQ. -2) IPUP = MITER + IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER +C If this is functional iteration, set CRATE .eq. 1 and drop to 220 + IF (MITER .EQ. 0) THEN + CRATE = ONE + GO TO 220 + ENDIF +C----------------------------------------------------------------------- +C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. +C When RC differs from 1 by more than CCMAX, IPUP is set to MITER +C to force DVJAC to be called, if a Jacobian is involved. +C In any case, DVJAC is called at least every MSBP steps. +C----------------------------------------------------------------------- + DRC = ABS(RC-ONE) + IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER +C----------------------------------------------------------------------- +C Up to MAXCOR corrector iterations are taken. A convergence test is +C made on the r.m.s. norm of each correction, weighted by the error +C weight vector EWT. The sum of the corrections is accumulated in the +C vector ACOR(i). The YH array is not altered in the corrector loop. +C----------------------------------------------------------------------- + 220 M = 0 + DELP = ZERO + CALL DCOPY (N, YH(1,1), 1, Y, 1 ) + CALL F (N, TN, Y, SAVF, RPAR, IPAR) + NFE = NFE + 1 + IF (IPUP .LE. 0) GO TO 250 +C----------------------------------------------------------------------- +C If indicated, the matrix P = I - h*rl1*J is reevaluated and +C preprocessed before starting the corrector iteration. IPUP is set +C to 0 as an indicator that this has been done. +C----------------------------------------------------------------------- + CALL DVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, + 1 RPAR, IPAR) + IPUP = 0 + RC = ONE + DRC = ZERO + CRATE = ONE + NSLP = NST +C If matrix is singular, take error return to force cut in step size. -- + IF (IERPJ .NE. 0) GO TO 430 + 250 DO 260 I = 1,N + 260 ACOR(I) = ZERO + +C This is a looping point for the corrector iteration. ----------------- + 270 IF (MITER .NE. 0) GO TO 350 +C----------------------------------------------------------------------- +C In the case of functional iteration, update Y directly from +C the result of the last function evaluation. +C----------------------------------------------------------------------- + DO 280 I = 1,N + 280 SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) + DO 290 I = 1,N + 290 Y(I) = SAVF(I) - ACOR(I) + DEL = DVNORM (N, Y, EWT) + DO 300 I = 1,N + 300 Y(I) = YH(I,1) + SAVF(I) + CALL DCOPY (N, SAVF, 1, ACOR, 1) + GO TO 400 +C----------------------------------------------------------------------- +C In the case of the chord method, compute the corrector error, + +C and solve the linear system with that as right-hand side and +C P as coefficient matrix. The correction is scaled by the factor +C 2/(1+RC) to account for changes in h*rl1 since the last DVJAC call. +C----------------------------------------------------------------------- + 350 DO 360 I = 1,N + 360 Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) + CALL DVSOL (WM, IWM, Y, IERSL) + NNI = NNI + 1 + IF (IERSL .GT. 0) GO TO 410 + IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN + CSCALE = TWO/(ONE + RC) + CALL DSCAL (N, CSCALE, Y, 1) + + ENDIF + DEL = DVNORM (N, Y, EWT) + CALL DAXPY (N, ONE, Y, 1, ACOR, 1) + DO 380 I = 1,N + 380 Y(I) = YH(I,1) + ACOR(I) +C----------------------------------------------------------------------- +C Test for convergence. If M .gt. 0, an estimate of the convergence +C rate constant is stored in CRATE, and this is used in the test. +C----------------------------------------------------------------------- + 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) + DCON = DEL*MIN(ONE,CRATE)/TQ(4) + IF (DCON .LE. ONE) GO TO 450 + M = M + 1 + IF (M .EQ. MAXCOR) GO TO 410 + IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 + DELP = DEL + CALL F (N, TN, Y, SAVF, RPAR, IPAR) + NFE = NFE + 1 + GO TO 270 + +C + + 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 + ICF = 1 + IPUP = MITER + + GO TO 220 +C + 430 CONTINUE + NFLAG = -1 + ICF = 2 + IPUP = MITER + RETURN + +C +C Return for successful step. ------------------------------------------ + 450 NFLAG = 0 + JCUR = 0 + ICF = 0 + IF (M .EQ. 0) ACNRM = DEL + IF (M .GT. 0) ACNRM = DVNORM (N, ACOR, EWT) + RETURN +C----------------------- End of Subroutine DVNLSD ---------------------- + END +*DECK DVJAC + SUBROUTINE DVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, F, JAC, + 1 IERPJ, RPAR, IPAR) + EXTERNAL F, JAC + DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM, RPAR + INTEGER LDYH, IWM, IERPJ, IPAR + DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), + 1 WM(*), IWM(*) +C----------------------------------------------------------------------- +C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, +C F, JAC, RPAR, IPAR +C Call sequence output -- WM, IWM, IERPJ +C COMMON block variables accessed.. +C /DVOD01/ CCMXJ, DRC, H, RL1, TN, UROUND, ICF, JCUR, LOCJS, +C MSBJ, NSLJ +C /DVOD02/ NFE, NST, NJE, NLU + +C + +C Subroutines called by DVJAC.. F, JAC, DACOPY, DCOPY, DGBFA, DGEFA, + +C DSCAL +C Function routines called by DVJAC.. DVNORM +C----------------------------------------------------------------------- +C DVJAC is called by DVSTEP to compute and process the matrix +C P = I - h*rl1*J , where J is an approximation to the Jacobian. +C Here J is computed by the user-supplied routine JAC if +C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. +C If MITER = 3, a diagonal approximation to J is used. +C If JSV = -1, J is computed from scratch in all cases. +C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is +C considered acceptable, then P is constructed from the saved J. +C J is stored in wm and replaced by P. If MITER .ne. 3, P is then +C subjected to LU decomposition in preparation for later solution +C of linear systems with P as coefficient matrix. This is done +C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. +C +C Communication with DVJAC is done with the following variables. (For +C more details, please see the comments in the driver subroutine.) +C Y = Vector containing predicted values on entry. +C YH = The Nordsieck array, an LDYH by LMAX array, input. +C LDYH = A constant .ge. N, the first dimension of YH, input. +C EWT = An error weight vector of length N. +C SAVF = Array containing f evaluated at predicted y, input. +C WM = Real work space for matrices. In the output, it containS +C the inverse diagonal matrix if MITER = 3 and the LU +C decomposition of P if MITER is 1, 2 , 4, or 5. +C Storage of matrix elements starts at WM(3). +C Storage of the saved Jacobian starts at WM(LOCJS). +C WM also contains the following matrix-related data.. +C WM(1) = SQRT(UROUND), used in numerical Jacobian step. +C WM(2) = H*RL1, saved for later use if MITER = 3. +C IWM = Integer work space containing pivot information, +C starting at IWM(31), if MITER is 1, 2, 4, or 5. + +C IWM also contains band parameters ML = IWM(1) and +C MU = IWM(2) if MITER is 4 or 5. +C F = Dummy name for the user supplied subroutine for f. +C JAC = Dummy name for the user supplied Jacobian subroutine. +C RPAR, IPAR = Dummy names for user's real and integer work arrays. +C RL1 = 1/EL(2) (input). +C IERPJ = Output error flag, = 0 if no trouble, 1 if the P +C matrix is found to be singular. +C JCUR = Output flag to indicate whether the Jacobian matrix +C (or approximation) is now current. +C JCUR = 0 means J is not current. + +C JCUR = 1 means J is current. +C----------------------------------------------------------------------- + +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for labeled COMMON block DVOD02 -------------------- +C + DOUBLE PRECISION HU + INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST + +C +C Type declarations for local variables -------------------------------- +C + DOUBLE PRECISION CON, DI, FAC, HRL1, ONE, PT1, R, R0, SRUR, THOU, + 1 YI, YJ, YJJ, ZERO + INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, + 1 MEB1, MEBAND, ML, ML3, MU, NP1 +C +C Type declaration for function subroutines called --------------------- +C + DOUBLE PRECISION DVNORM +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the + +C listed (local) variables to be saved between calls to this subroutine. +C----------------------------------------------------------------------- + SAVE ONE, PT1, THOU, ZERO + +C----------------------------------------------------------------------- + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH + COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST +C + DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ +C + IERPJ = 0 + HRL1 = H*RL1 +C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- + JOK = JSV + IF (JSV .EQ. 1) THEN + IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 + IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 + IF (ICF .EQ. 2) JOK = -1 + ENDIF +C End of setting JOK. -------------------------------------------------- +C + IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN +C If JOK = -1 and MITER = 1, call JAC to evaluate Jacobian. ------------ + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + LENP = N*N + DO 110 I = 1,LENP + 110 WM(I+2) = ZERO + CALL JAC (N, TN, Y, 0, 0, WM(3), N, RPAR, IPAR) + IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) + + ENDIF +C + IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN +C If MITER = 2, make N calls to F to approximate the Jacobian. --------- + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + FAC = DVNORM (N, SAVF, EWT) + R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + SRUR = WM(1) + J1 = 2 + DO 230 J = 1,N + + YJ = Y(J) + R = MAX(SRUR*ABS(YJ),R0/EWT(J)) + Y(J) = Y(J) + R + FAC = ONE/R + CALL F (N, TN, Y, FTEM, RPAR, IPAR) + DO 220 I = 1,N + 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC + Y(J) = YJ + J1 = J1 + N + + 230 CONTINUE + NFE = NFE + N + + LENP = N*N + IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) + ENDIF +C + IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN + JCUR = 0 + LENP = N*N + CALL DCOPY (LENP, WM(LOCJS), 1, WM(3), 1) + ENDIF +C + IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN +C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- + CON = -HRL1 + CALL DSCAL (LENP, CON, WM(3), 1) + J = 3 + NP1 = N + 1 + DO 250 I = 1,N + WM(J) = WM(J) + ONE + 250 J = J + NP1 + NLU = NLU + 1 + CALL DGEFA (WM(3), N, N, IWM(31), IER) + + IF (IER .NE. 0) IERPJ = 1 + RETURN + ENDIF +C End of code block for MITER = 1 or 2. -------------------------------- +C + IF (MITER .EQ. 3) THEN +C If MITER = 3, construct a diagonal approximation to J and P. --------- + NJE = NJE + 1 + JCUR = 1 + WM(2) = HRL1 + R = RL1*PT1 + DO 310 I = 1,N + 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) + CALL F (N, TN, Y, WM(3), RPAR, IPAR) + NFE = NFE + 1 + DO 320 I = 1,N + R0 = H*SAVF(I) - YH(I,2) + DI = PT1*R0 - H*(WM(I+2) - SAVF(I)) + WM(I+2) = ONE + IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 + IF (ABS(DI) .EQ. ZERO) GO TO 330 + WM(I+2) = PT1*R0/DI + 320 CONTINUE + RETURN + 330 IERPJ = 1 + RETURN + ENDIF +C End of code block for MITER = 3. ------------------------------------- + +C +C Set constants for MITER = 4 or 5. ------------------------------------ + ML = IWM(1) + MU = IWM(2) + ML3 = ML + 3 + MBAND = ML + MU + 1 + MEBAND = MBAND + ML + LENP = MEBAND*N +C + IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN +C If JOK = -1 and MITER = 4, call JAC to evaluate Jacobian. ------------ + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + DO 410 I = 1,LENP + 410 WM(I+2) = ZERO + CALL JAC (N, TN, Y, ML, MU, WM(ML3), MEBAND, RPAR, IPAR) + IF (JSV .EQ. 1) + 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) + ENDIF +C + + IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN +C If MITER = 5, make N calls to F to approximate the Jacobian. --------- + NJE = NJE + 1 + NSLJ = NST + JCUR = 1 + MBA = MIN(MBAND,N) + MEB1 = MEBAND - 1 + SRUR = WM(1) + FAC = DVNORM (N, SAVF, EWT) + R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC + IF (R0 .EQ. ZERO) R0 = ONE + DO 560 J = 1,MBA + DO 530 I = J,N,MBAND + YI = Y(I) + R = MAX(SRUR*ABS(YI),R0/EWT(I)) + + 530 Y(I) = Y(I) + R + CALL F (N, TN, Y, FTEM, RPAR, IPAR) + DO 550 JJ = J,N,MBAND + Y(JJ) = YH(JJ,1) + YJJ = Y(JJ) + R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) + FAC = ONE/R + I1 = MAX(JJ-MU,1) + I2 = MIN(JJ+ML,N) + II = JJ*MEB1 - ML + 2 + DO 540 I = I1,I2 + 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC + 550 CONTINUE + 560 CONTINUE + NFE = NFE + MBA + IF (JSV .EQ. 1) + 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) + ENDIF +C + IF (JOK .EQ. 1) THEN + JCUR = 0 + CALL DACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML3), MEBAND) + ENDIF +C +C Multiply Jacobian by scalar, add identity, and do LU decomposition. + CON = -HRL1 + + CALL DSCAL (LENP, CON, WM(3), 1 ) + II = MBAND + 2 + DO 580 I = 1,N + WM(II) = WM(II) + ONE + 580 II = II + MEBAND + NLU = NLU + 1 + CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(31), IER) + IF (IER .NE. 0) IERPJ = 1 + RETURN +C End of code block for MITER = 4 or 5. -------------------------------- +C +C----------------------- End of Subroutine DVJAC ----------------------- + END + + +*DECK DACOPY + SUBROUTINE DACOPY (NROW, NCOL, A, NROWA, B, NROWB) + DOUBLE PRECISION A, B + INTEGER NROW, NCOL, NROWA, NROWB + DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) +C----------------------------------------------------------------------- +C Call sequence input -- NROW, NCOL, A, NROWA, NROWB +C Call sequence output -- B +C COMMON block variables accessed -- None +C +C Subroutines called by DACOPY.. DCOPY +C Function routines called by DACOPY.. None +C----------------------------------------------------------------------- + +C This routine copies one rectangular array, A, to another, B, +C where A and B may have different row dimensions, NROWA and NROWB. +C The data copied consists of NROW rows and NCOL columns. +C----------------------------------------------------------------------- + INTEGER IC +C + DO 20 IC = 1,NCOL + CALL DCOPY (NROW, A(1,IC), 1, B(1,IC), 1) + 20 CONTINUE +C + RETURN +C----------------------- End of Subroutine DACOPY ---------------------- + END +*DECK DVSOL + SUBROUTINE DVSOL (WM, IWM, X, IERSL) + DOUBLE PRECISION WM, X + INTEGER IWM, IERSL + DIMENSION WM(*), IWM(*), X(*) +C----------------------------------------------------------------------- +C Call sequence input -- WM, IWM, X + +C Call sequence output -- X, IERSL +C COMMON block variables accessed.. +C /DVOD01/ -- H, RL1, MITER, N +C +C Subroutines called by DVSOL.. DGESL, DGBSL +C Function routines called by DVSOL.. None +C----------------------------------------------------------------------- +C This routine manages the solution of the linear system arising from +C a chord iteration. It is called if MITER .ne. 0. +C If MITER is 1 or 2, it calls DGESL to accomplish this. +C If MITER = 3 it updates the coefficient H*RL1 in the diagonal +C matrix, and then computes the solution. +C If MITER is 4 or 5, it calls DGBSL. +C Communication with DVSOL uses the following variables.. +C WM = Real work space containing the inverse diagonal matrix if +C MITER = 3 and the LU decomposition of the matrix otherwise. +C Storage of matrix elements starts at WM(3). +C WM also contains the following matrix-related data.. +C WM(1) = SQRT(UROUND) (not used here), +C WM(2) = HRL1, the previous value of H*RL1, used if MITER = 3. + +C IWM = Integer work space containing pivot information, starting at +C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band +C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. +C X = The right-hand side vector on input, and the solution vector +C on output, of length N. +C IERSL = Output flag. IERSL = 0 if no trouble occurred. +C IERSL = 1 if a singular matrix arose with MITER = 3. +C----------------------------------------------------------------------- +C +C Type declarations for labeled COMMON block DVOD01 -------------------- +C + DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU, TQ, TN, UROUND + INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 4 NSLP, NYH +C +C Type declarations for local variables -------------------------------- +C + INTEGER I, MEBAND, ML, MU + DOUBLE PRECISION DI, HRL1, ONE, PHRL1, R, ZERO +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE ONE, ZERO +C + COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), + 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, + 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, + 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, + 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, + 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, + 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, + 7 NSLP, NYH +C + DATA ONE /1.0D0/, ZERO /0.0D0/ +C + + IERSL = 0 + + GO TO (100, 100, 300, 400, 400), MITER + 100 CALL DGESL (WM(3), N, N, IWM(31), X, 0) + RETURN +C + 300 PHRL1 = WM(2) + HRL1 = H*RL1 + + WM(2) = HRL1 + IF (HRL1 .EQ. PHRL1) GO TO 330 + R = HRL1/PHRL1 + DO 320 I = 1,N + DI = ONE - R*(ONE - ONE/WM(I+2)) + IF (ABS(DI) .EQ. ZERO) GO TO 390 + 320 WM(I+2) = ONE/DI +C + 330 DO 340 I = 1,N + 340 X(I) = WM(I+2)*X(I) + RETURN + + 390 IERSL = 1 + RETURN +C + 400 ML = IWM(1) + MU = IWM(2) + MEBAND = 2*ML + MU + 1 + CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(31), X, 0) + RETURN +C----------------------- End of Subroutine DVSOL ----------------------- + END +*DECK DVSRCO + + SUBROUTINE DVSRCO (RSAV, ISAV, JOB) + DOUBLE PRECISION RSAV + INTEGER ISAV, JOB + DIMENSION RSAV(*), ISAV(*) +C----------------------------------------------------------------------- +C Call sequence input -- RSAV, ISAV, JOB +C Call sequence output -- RSAV, ISAV +C COMMON block variables accessed -- All of /DVOD01/ and /DVOD02/ +C +C Subroutines/functions called by DVSRCO.. None +C----------------------------------------------------------------------- +C This routine saves or restores (depending on JOB) the contents of the +C COMMON blocks DVOD01 and DVOD02, which are used internally by DVODE. +C +C RSAV = real array of length 49 or more. +C ISAV = integer array of length 41 or more. +C JOB = flag indicating to save or restore the COMMON blocks.. +C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV). +C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV). +C A call with JOB = 2 presumes a prior call with JOB = 1. +C----------------------------------------------------------------------- + DOUBLE PRECISION RVOD1, RVOD2 + INTEGER IVOD1, IVOD2 + INTEGER I, LENIV1, LENIV2, LENRV1, LENRV2 +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the + +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE LENRV1, LENIV1, LENRV2, LENIV2 +C + COMMON /DVOD01/ RVOD1(48), IVOD1(33) + COMMON /DVOD02/ RVOD2(1), IVOD2(8) + DATA LENRV1/48/, LENIV1/33/, LENRV2/1/, LENIV2/8/ +C + IF (JOB .EQ. 2) GO TO 100 + DO 10 I = 1,LENRV1 + 10 RSAV(I) = RVOD1(I) + DO 15 I = 1,LENRV2 + + 15 RSAV(LENRV1+I) = RVOD2(I) +C + DO 20 I = 1,LENIV1 + 20 ISAV(I) = IVOD1(I) + DO 25 I = 1,LENIV2 + 25 ISAV(LENIV1+I) = IVOD2(I) +C + RETURN +C + 100 CONTINUE + DO 110 I = 1,LENRV1 + 110 RVOD1(I) = RSAV(I) + DO 115 I = 1,LENRV2 + 115 RVOD2(I) = RSAV(LENRV1+I) +C + DO 120 I = 1,LENIV1 + 120 IVOD1(I) = ISAV(I) + DO 125 I = 1,LENIV2 + 125 IVOD2(I) = ISAV(LENIV1+I) +C + RETURN +C----------------------- End of Subroutine DVSRCO ---------------------- + + END +*DECK DEWSET + SUBROUTINE DEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) + DOUBLE PRECISION RTOL, ATOL, YCUR, EWT + INTEGER N, ITOL + DIMENSION ATOL(*), YCUR(N), EWT(N) +C----------------------------------------------------------------------- +C Call sequence input -- N, ITOL, RTOL, ATOL, YCUR +C Call sequence output -- EWT +C COMMON block variables accessed -- None +C +C Subroutines/functions called by DEWSET.. None +C----------------------------------------------------------------------- +C This subroutine sets the error weight vector EWT according to +C EWT(i) = RTOL(i)*abs(YCUR(i)) + ATOL(i), i = 1,...,N, +C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, +C depending on the value of ITOL. +C----------------------------------------------------------------------- + INTEGER I +C + GO TO (10, 20, 30, 40), ITOL + 10 CONTINUE + DO 15 I = 1, N + 15 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(1) + RETURN + 20 CONTINUE + DO 25 I = 1, N + 25 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(I) + RETURN + 30 CONTINUE + + DO 35 I = 1, N + + 35 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(1) + RETURN + 40 CONTINUE + DO 45 I = 1, N + 45 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(I) + RETURN + +C----------------------- End of Subroutine DEWSET ---------------------- + + END +*DECK DVNORM + DOUBLE PRECISION FUNCTION DVNORM (N, V, W) + DOUBLE PRECISION V, W + INTEGER N + DIMENSION V(N), W(N) +C----------------------------------------------------------------------- + +C Call sequence input -- N, V, W +C Call sequence output -- None +C COMMON block variables accessed -- None +C +C Subroutines/functions called by DVNORM.. None +C----------------------------------------------------------------------- +C This function routine computes the weighted root-mean-square norm +C of the vector of length N contained in the array V, with weights +C contained in the array W of length N.. +C DVNORM = sqrt( (1/N) * sum( V(i)*W(i) )**2 ) +C----------------------------------------------------------------------- + DOUBLE PRECISION SUM + INTEGER I +C + SUM = 0.0D0 + DO 10 I = 1, N + 10 SUM = SUM + (V(I)*W(I))**2 + DVNORM = SQRT(SUM/REAL(N)) + RETURN +C----------------------- End of Function DVNORM ------------------------ + END +*DECK D1MACH + DOUBLE PRECISION FUNCTION D1MACH (IDUM) + INTEGER IDUM +C----------------------------------------------------------------------- +C This routine computes the unit roundoff of the machine. +C This is defined as the smallest positive machine number +C u such that 1.0 + u .ne. 1.0 +C +C Subroutines/functions called by D1MACH.. None +C----------------------------------------------------------------------- + DOUBLE PRECISION U, COMP + U = 1.0D0 + 10 U = U*0.5D0 + COMP = 1.0D0 + U + IF (COMP .NE. 1.0D0) GO TO 10 + D1MACH = U*2.0D0 + RETURN +C----------------------- End of Function D1MACH ------------------------ + END + +*DECK XERRWD + + SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) + DOUBLE PRECISION R1, R2 + + INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR + CHARACTER*1 MSG(NMES),ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + COMMON/NXER/NXE +C NXE (NO. OF CALLS TO THIS ROUTINE) IS PASSED BACK TO MAIN FOR +C WRITING TO THE SCREEN. + + + + + +C----------------------------------------------------------------------- +C Subroutines XERRWD, XSETF, XSETUN, and the two function routines +C MFLGSV and LUNSAV, as given here, constitute a simplified version of +C the SLATEC error handling package. + +C Written by A. C. Hindmarsh and P. N. Brown at LLNL. + +C Version of 13 April, 1989. +C This version is in double precision. +C +C All arguments are input arguments. +C +C MSG = The message (character array). +C NMES = The length of MSG (number of characters). +C NERR = The error number (not used). + +C LEVEL = The error level.. +C 0 or 1 means recoverable (control returns to caller). +C 2 means fatal (run is aborted--see note below). +C NI = Number of integers (0, 1, or 2) to be printed with message. +C I1,I2 = Integers to be printed, depending on NI. +C NR = Number of reals (0, 1, or 2) to be printed with message. +C R1,R2 = Reals to be printed, depending on NR. +C + +C Note.. this routine is machine-dependent and specialized for use + +C in limited context, in the following ways.. +C 1. The argument MSG is assumed to be of type CHARACTER, and +C the message is printed with a format of (1X,80A1). +C 2. The message is assumed to take only one line. +C Multi-line messages are generated by repeated calls. +C 3. If LEVEL = 2, control passes to the statement STOP +C to abort the run. This statement may be machine-dependent. +C 4. R1 and R2 are assumed to be in double precision and are printed +C in D21.13 format. +C +C For a different default logical unit number, change the data + +C statement in function routine LUNSAV. +C For a different run-abort command, change the statement following +C statement 100 at the end. +C----------------------------------------------------------------------- +C Subroutines called by XERRWD.. None +C Function routines called by XERRWD.. MFLGSV, LUNSAV +C----------------------------------------------------------------------- +C + INTEGER I, LUNIT, LUNSAV, MESFLG, MFLGSV + +C SKIP ALL ERROR MESSAGES, SIMPLY GO TO LABEL 100. BUT KEEP A RUNNING + +C TOTAL OF CALLS TO THIS ROUTINE, NXE, AND RETURN IT TO MAIN FOR +C OUTPUT. + + NXE = NXE + 1 + GO TO 100 + + + +C Get message print flag and logical unit number. ---------------------- + + MESFLG = MFLGSV (0,.FALSE.) + LUNIT = LUNSAV (0,.FALSE.) + + IF (MESFLG .EQ. 0) GO TO 100 +C Write the message. --------------------------------------------------- + WRITE (LUNIT,10) (MSG(I),I=1,NMES) + 10 FORMAT(1X,80A1) + IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 + + 20 FORMAT(6X,'In above message, I1 =',I10) + IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 + 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) + IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 + 40 FORMAT(6X,'In above message, R1 =',D21.13) + IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 + 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) +C Abort the run if LEVEL = 2. ------------------------------------------ + 100 IF (LEVEL .NE. 2) RETURN + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + WRITE(47,51) + 51 FORMAT(/' LEVEL 2 (FATAL) IN SUBROUTINE XERRWD. '/) + CLOSE(47) + + + + CALL PAUSE + STOP +C----------------------- End of Subroutine XERRWD ---------------------- + END +*DECK XSETF + SUBROUTINE XSETF (MFLAG) +C----------------------------------------------------------------------- +C This routine resets the print control flag MFLAG. +C +C Subroutines called by XSETF.. None +C Function routines called by XSETF.. MFLGSV +C----------------------------------------------------------------------- + INTEGER MFLAG, JUNK, MFLGSV +C + IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = MFLGSV (MFLAG,.TRUE.) + RETURN + +C----------------------- End of Subroutine XSETF ----------------------- + END +*DECK XSETUN + SUBROUTINE XSETUN (LUN) +C----------------------------------------------------------------------- +C This routine resets the logical unit number for messages. +C +C Subroutines called by XSETUN.. None +C Function routines called by XSETUN.. LUNSAV +C----------------------------------------------------------------------- + INTEGER LUN, JUNK, LUNSAV +C + + IF (LUN .GT. 0) JUNK = LUNSAV (LUN,.TRUE.) + + RETURN +C----------------------- End of Subroutine XSETUN ---------------------- + END +*DECK MFLGSV + INTEGER FUNCTION MFLGSV (IVALUE, ISET) + LOGICAL ISET + INTEGER IVALUE +C----------------------------------------------------------------------- +C MFLGSV saves and recalls the parameter MESFLG which controls the +C printing of the error messages. +C +C Saved local variable.. + +C +C MESFLG = Print control flag.. +C 1 means print all messages (the default). +C 0 means no printing. +C +C On input.. +C +C IVALUE = The value to be set for the MESFLG parameter, +C if ISET is .TRUE. . +C +C ISET = Logical flag to indicate whether to read or write. + +C If ISET=.TRUE., the MESFLG parameter will be given +C the value IVALUE. If ISET=.FALSE., the MESFLG +C parameter will be unchanged, and IVALUE is a dummy +C parameter. +C +C On return.. +C +C The (old) value of the MESFLG parameter will be returned +C in the function value, MFLGSV. +C +C This is a modification of the SLATEC library routine J4SAVE. +C +C Subroutines/functions called by MFLGSV.. None +C----------------------------------------------------------------------- + INTEGER MESFLG +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. + +C----------------------------------------------------------------------- + SAVE MESFLG + DATA MESFLG/1/ +C + MFLGSV = MESFLG + IF (ISET) MESFLG = IVALUE + RETURN +C----------------------- End of Function MFLGSV ------------------------ + END +*DECK LUNSAV + INTEGER FUNCTION LUNSAV (IVALUE, ISET) + LOGICAL ISET + INTEGER IVALUE +C----------------------------------------------------------------------- +C LUNSAV saves and recalls the parameter LUNIT which is the logical +C unit number to which error messages are printed. +C +C Saved local variable.. +C +C LUNIT = Logical unit number for messages. +C The default is 6 (machine-dependent). +C +C On input.. +C +C IVALUE = The value to be set for the LUNIT parameter, +C if ISET is .TRUE. . +C +C ISET = Logical flag to indicate whether to read or write. +C If ISET=.TRUE., the LUNIT parameter will be given +C the value IVALUE. If ISET=.FALSE., the LUNIT +C parameter will be unchanged, and IVALUE is a dummy +C parameter. +C + +C On return.. +C +C The (old) value of the LUNIT parameter will be returned +C in the function value, LUNSAV. +C +C This is a modification of the SLATEC library routine J4SAVE. +C +C Subroutines/functions called by LUNSAV.. None +C----------------------------------------------------------------------- + INTEGER LUNIT +C----------------------------------------------------------------------- +C The following Fortran-77 declaration is to cause the values of the +C listed (local) variables to be saved between calls to this integrator. +C----------------------------------------------------------------------- + SAVE LUNIT + DATA LUNIT/6/ +C + LUNSAV = LUNIT + IF (ISET) LUNIT = IVALUE + RETURN +C----------------------- End of Function LUNSAV ------------------------ + END + +C*********************************************************************** +C*********************************************************************** + +C VODEXT.FOR IS SIMPLY A CONCATENATION OF 9 MODULES NEEDED BY +C VODE.FOR. THEY ARE FOUND IN ftp.netlib.org on the web. + +C In \BLAS +c DCOPY.F DSCAL.F DAXPY.F DDOT.F IDAMAX.F + +C In \LINPACK +c DGEFA.F DGESL.F DGBFA.F DGBSL.F + +C ALL ABOVE MODULES HAVE BEEN COPIED INTO FILES WITH EXTENSION .FOR. + + +C----------------------------------------------------------------------- + + subroutine dgefa(a,lda,n,ipvt,info) + integer lda,n,ipvt(1),info + + double precision a(lda,1) + +c +c dgefa factors a double precision matrix by gaussian elimination. +c +c dgefa is usually called by dgeco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dgeco) = (1 + 9/n)*(time for dgefa) . +c +c on entry +c +c a double precision(lda, n) +c the matrix to be factored. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return + +c +c a an upper triangular matrix and the multipliers +c which were used to obtain it. +c the factorization can be written a = l*u where +c l is a product of permutation and unit lower +c triangular matrices and u is upper triangular. +c +c ipvt integer(n) +c an integer vector of pivot indices. +c +c info integer +c = 0 normal value. + +c = k if u(k,k) .eq. 0.0 . this is not an error +c condition for this subroutine, but it does +c indicate that dgesl or dgedi will divide by zero +c if called. use rcond in dgeco for a reliable +c indication of singularity. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions + +c +c blas daxpy,dscal,idamax +c + + +c internal variables +c + double precision t + integer idamax,j,k,kp1,l,nm1 +c +c +c gaussian elimination with partial pivoting +c + info = 0 + nm1 = n - 1 + if (nm1 .lt. 1) go to 70 + do 60 k = 1, nm1 + kp1 = k + 1 +c +c find l = pivot index +c + l = idamax(n-k+1,a(k,k),1) + k - 1 + ipvt(k) = l +c +c zero pivot implies this column already triangularized +c + if (a(l,k) .eq. 0.0d0) go to 40 +c +c interchange if necessary +c + if (l .eq. k) go to 10 + t = a(l,k) + a(l,k) = a(k,k) + a(k,k) = t + 10 continue +c +c compute multipliers +c + t = -1.0d0/a(k,k) + call dscal(n-k,t,a(k+1,k),1) +c +c row elimination with column indexing +c + do 30 j = kp1, n + t = a(l,j) + if (l .eq. k) go to 20 + + a(l,j) = a(k,j) + a(k,j) = t + 20 continue + call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) + 30 continue + go to 50 + 40 continue + info = k + 50 continue + 60 continue + 70 continue + ipvt(n) = n + if (a(n,n) .eq. 0.0d0) info = n + return + end + +C----------------------------------------------------------------------- + + subroutine dgesl(a,lda,n,ipvt,b,job) + + integer lda,n,ipvt(1),job + double precision a(lda,1),b(1) +c + +c dgesl solves the double precision system +c a * x = b or trans(a) * x = b +c using the factors computed by dgeco or dgefa. +c +c on entry +c +c a double precision(lda, n) +c the output from dgeco or dgefa. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c ipvt integer(n) +c the pivot vector from dgeco or dgefa. +c +c b double precision(n) +c the right hand side vector. + +c +c job integer +c = 0 to solve a*x = b , +c = nonzero to solve trans(a)*x = b where +c trans(a) is the transpose. +c +c on return +c +c b the solution vector x . +c +c error condition +c +c a division by zero will occur if the input factor contains a +c zero on the diagonal. technically this indicates singularity +c but it is often caused by improper arguments or improper +c setting of lda . it will not occur if the subroutines are +c called correctly and if dgeco has set rcond .gt. 0.0 +c or dgefa has set info .eq. 0 . +c +c to compute inverse(a) * c where c is a matrix +c with p columns +c call dgeco(a,lda,n,ipvt,rcond,z) +c if (rcond is too small) go to ... +c do 10 j = 1, p +c call dgesl(a,lda,n,ipvt,c(1,j),0) +c 10 continue +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c +c internal variables +c + double precision ddot,t + integer k,kb,l,nm1 + + +c + nm1 = n - 1 + if (job .ne. 0) go to 50 +c +c job = 0 , solve a * x = b +c first solve l*y = b +c + if (nm1 .lt. 1) go to 30 + do 20 k = 1, nm1 + l = ipvt(k) + t = b(l) + if (l .eq. k) go to 10 + b(l) = b(k) + b(k) = t + 10 continue + call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) + 20 continue + 30 continue +c +c now solve u*x = y +c + do 40 kb = 1, n + k = n + 1 - kb + + + b(k) = b(k)/a(k,k) + t = -b(k) + call daxpy(k-1,t,a(1,k),1,b(1),1) + 40 continue + go to 100 + 50 continue +c +c job = nonzero, solve trans(a) * x = b +c first solve trans(u)*y = b +c + do 60 k = 1, n + + t = ddot(k-1,a(1,k),1,b(1),1) + b(k) = (b(k) - t)/a(k,k) + 60 continue +c +c now solve trans(l)*x = y +c + if (nm1 .lt. 1) go to 90 + do 80 kb = 1, nm1 + k = n - kb + b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) + l = ipvt(k) + if (l .eq. k) go to 70 + t = b(l) + b(l) = b(k) + + b(k) = t + 70 continue + 80 continue + 90 continue + 100 continue + + return + end + +C----------------------------------------------------------------------- + + subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) + integer lda,n,ml,mu,ipvt(1),info + double precision abd(lda,1) +c +c dgbfa factors a double precision band matrix by elimination. + +c +c dgbfa is usually called by dgbco, but it can be called +c directly with a saving in time if rcond is not needed. +c +c on entry +c +c abd double precision(lda, n) +c contains the matrix in band storage. the columns +c of the matrix are stored in the columns of abd and +c the diagonals of the matrix are stored in rows +c ml+1 through 2*ml+mu+1 of abd . +c see the comments below for details. +c +c lda integer +c the leading dimension of the array abd . +c lda must be .ge. 2*ml + mu + 1 . +c +c n integer +c the order of the original matrix. +c +c ml integer +c number of diagonals below the main diagonal. +c 0 .le. ml .lt. n . + +c +c mu integer +c number of diagonals above the main diagonal. +c 0 .le. mu .lt. n . +c more efficient if ml .le. mu . +c on return +c +c abd an upper triangular matrix in band storage and + +c the multipliers which were used to obtain it. +c the factorization can be written a = l*u where +c l is a product of permutation and unit lower +c triangular matrices and u is upper triangular. +c +c ipvt integer(n) +c an integer vector of pivot indices. +c +c info integer +c = 0 normal value. +c = k if u(k,k) .eq. 0.0 . this is not an error +c condition for this subroutine, but it does +c indicate that dgbsl will divide by zero if + +c called. use rcond in dgbco for a reliable +c indication of singularity. +c +c band storage +c + +c if a is a band matrix, the following program segment +c will set up the input. +c +c ml = (band width below the diagonal) +c mu = (band width above the diagonal) +c m = ml + mu + 1 +c do 20 j = 1, n +c i1 = max0(1, j-mu) +c i2 = min0(n, j+ml) + + +c do 10 i = i1, i2 +c k = i - j + m +c abd(k,j) = a(i,j) + +c 10 continue +c 20 continue +c +c this uses rows ml+1 through 2*ml+mu+1 of abd . +c in addition, the first ml rows in abd are used for +c elements generated during the triangularization. +c the total number of rows needed in abd is 2*ml+mu+1 . +c the ml+mu by ml+mu upper left triangle and the +c ml by ml lower right triangle are not referenced. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,dscal,idamax +c fortran max0,min0 + +c +c internal variables +c + double precision t + integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 +c +c + m = ml + mu + 1 + info = 0 +c +c zero initial fill-in columns +c + + j0 = mu + 2 + j1 = min0(n,m) - 1 + if (j1 .lt. j0) go to 30 + do 20 jz = j0, j1 + i0 = m + 1 - jz + do 10 i = i0, ml + abd(i,jz) = 0.0d0 + 10 continue + 20 continue + 30 continue + jz = j1 + ju = 0 +c +c gaussian elimination with partial pivoting +c + nm1 = n - 1 + if (nm1 .lt. 1) go to 130 + do 120 k = 1, nm1 + kp1 = k + 1 +c +c zero next fill-in column +c + jz = jz + 1 + if (jz .gt. n) go to 50 + + + if (ml .lt. 1) go to 50 + do 40 i = 1, ml + abd(i,jz) = 0.0d0 + 40 continue + 50 continue +c +c find l = pivot index +c + lm = min0(ml,n-k) + l = idamax(lm+1,abd(m,k),1) + m - 1 + ipvt(k) = l + k - m +c +c zero pivot implies this column already triangularized +c + if (abd(l,k) .eq. 0.0d0) go to 100 +c +c interchange if necessary +c + if (l .eq. m) go to 60 + t = abd(l,k) + abd(l,k) = abd(m,k) + abd(m,k) = t + + 60 continue +c +c compute multipliers +c + t = -1.0d0/abd(m,k) + call dscal(lm,t,abd(m+1,k),1) +c +c row elimination with column indexing +c + ju = min0(max0(ju,mu+ipvt(k)),n) + mm = m + if (ju .lt. kp1) go to 90 + do 80 j = kp1, ju + l = l - 1 + mm = mm - 1 + t = abd(l,j) + if (l .eq. mm) go to 70 + + abd(l,j) = abd(mm,j) + abd(mm,j) = t + 70 continue + call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) + 80 continue + 90 continue + go to 110 + 100 continue + info = k + + 110 continue + 120 continue + + 130 continue + + ipvt(n) = n + if (abd(m,n) .eq. 0.0d0) info = n + return + end + +C----------------------------------------------------------------------- + + subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) + integer lda,n,ml,mu,ipvt(1),job + + double precision abd(lda,1),b(1) +c +c dgbsl solves the double precision band system +c a * x = b or trans(a) * x = b + +c using the factors computed by dgbco or dgbfa. +c +c on entry +c +c abd double precision(lda, n) +c the output from dgbco or dgbfa. +c +c lda integer +c the leading dimension of the array abd . +c +c n integer +c the order of the original matrix. +c +c ml integer +c number of diagonals below the main diagonal. +c +c mu integer +c number of diagonals above the main diagonal. +c +c ipvt integer(n) +c the pivot vector from dgbco or dgbfa. +c + +c b double precision(n) +c the right hand side vector. +c +c job integer +c = 0 to solve a*x = b , +c = nonzero to solve trans(a)*x = b , where +c trans(a) is the transpose. +c +c on return +c +c b the solution vector x . +c +c error condition +c +c a division by zero will occur if the input factor contains a +c zero on the diagonal. technically this indicates singularity +c but it is often caused by improper arguments or improper + +c setting of lda . it will not occur if the subroutines are +c called correctly and if dgbco has set rcond .gt. 0.0 +c or dgbfa has set info .eq. 0 . +c +c to compute inverse(a) * c where c is a matrix +c with p columns +c call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) +c if (rcond is too small) go to ... +c do 10 j = 1, p +c call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) +c 10 continue +c +c linpack. this version dated 08/14/78 . + + +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c fortran min0 +c +c internal variables +c + double precision ddot,t + integer k,kb,l,la,lb,lm,m,nm1 +c + + m = mu + ml + 1 + nm1 = n - 1 + + if (job .ne. 0) go to 50 + +c +c job = 0 , solve a * x = b +c first solve l*y = b +c + if (ml .eq. 0) go to 30 + if (nm1 .lt. 1) go to 30 + do 20 k = 1, nm1 + lm = min0(ml,n-k) + l = ipvt(k) + t = b(l) + if (l .eq. k) go to 10 + b(l) = b(k) + b(k) = t + + + 10 continue + call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) + 20 continue + 30 continue +c +c now solve u*x = y +c + do 40 kb = 1, n + k = n + 1 - kb + b(k) = b(k)/abd(m,k) + lm = min0(k,m) - 1 + la = m - lm + lb = k - lm + t = -b(k) + call daxpy(lm,t,abd(la,k),1,b(lb),1) + 40 continue + go to 100 + 50 continue +c +c job = nonzero, solve trans(a) * x = b +c first solve trans(u)*y = b +c + do 60 k = 1, n + lm = min0(k,m) - 1 + la = m - lm + lb = k - lm + t = ddot(lm,abd(la,k),1,b(lb),1) + b(k) = (b(k) - t)/abd(m,k) + 60 continue +c +c now solve trans(l)*x = y +c + if (ml .eq. 0) go to 90 + if (nm1 .lt. 1) go to 90 + do 80 kb = 1, nm1 + k = n - kb + lm = min0(ml,n-k) + b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) + l = ipvt(k) + if (l .eq. k) go to 70 + t = b(l) + b(l) = b(k) + b(k) = t + 70 continue + 80 continue + 90 continue + 100 continue + return + end + + + subroutine checkd(corden,new,nactveold,ab,maxgrd,nvar,iclose) + + implicit real*8 (a-h,o-z) + real*8 ab(30,2), corden(maxgrd,1) + iclose=0 + do ibas=1,nactveold + sum=0. + do i=1,nvar + sum=sum+abs(corden(new,i)-corden(ibas,i))/(ab(i,2)-ab(i,1)) + enddo + if(sum.le.1.d-4) then + iclose=1 + return + endif + enddo + return + end + + + subroutine emint(psi,ldpsi,theta,ldtheta,npoint,nsub,ijob, + & x,dx,y,dy,fobj,gap,nvar,keep,IHESS) + + implicit real*8 (a-h,o-z) + real*8 mu + dimension psi(ldpsi,*),theta(ldtheta,*),x(*),dx(*),y(*),dy(*) + + +c This subroutine solves the 'EM' problem of maximizing the function + +c fobj(x) = sum_i (log[sum_j ( psi(i,j) * x(j)) ] ), +c j=1,..,npoint and i=1,...,nsub +c subject to: x(j) >= 0, sum_j x(j) = 1 (i.e. x is a probability +c vector of length npoint) +c where psi(i,j) is a fixed non-negative data array representing the +c likelihood of point j for subject i + +c inputs: psi,ldpsi,npoint,nsub,nvar +c psi contains the likelihood vectors for each subject - the i-th +c row of psi is likelikhood vector for subject i. Thus psi(i,j) is +c likelihood of the j-th point for c the i-th subject. The input value +c ldpsi is the 'leading dimension of psi' - i.e. the first dimension of the +c array psi as dimensioned in the calling program. +c +c input work arrays: dx(*), y(*), dy(*) - should be at least large enough to +c contain npoint points, as should the probabiltiy array x(*) + +c +c outputs: x(*), fobj +c x(i) is final probability for point i +c fobj - optimal value of the objective function + +c note - usually npoint is much larger than nsub; here we dimension + +c some internal work arrays with the maximum expected number of subjects +c MAXSUBem and the maximum number of points MAXACTem +c are be set in the parameter statement + + + parameter (MAXSUBem=999,MAXACTem=10000000) + dimension w(MAXSUBem),dw(MAXSUBem),Ptx(MAXSUBem), + & hess(MAXSUBem,2*MAXSUBem) + dimension psisum(MAXSUBem) + + integer kpvt(MAXSUBem), ipivot(MAXACTem), list(MAXACTem) + + CHARACTER ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + +C DATA ILOOP/0/ +C ILOOP IS USED BELOW TO KNOW WHEN TO WRITE MESSAGE TO USER IN CASE +C THE OPTIMIZATION TAKES A 'LONG' TIME. + + +c here w(*) is a vector if `dual variables' +c dw(*) is a calculated change (as a Newton step) in w(*) +c Ptx(*) (Psi times x) is the vector Ptx(j) = sum_i Psi(j,i)*x(i) +c first , perform some dimension checks to make sure no internal dimensions +c are exceeded + keep = nactve + + + + if(nsub.gt.MAXSUBem) then + + + + write(6,*) 'nsub =',nsub, ' is greater than MAXSUBem=',MAXSUBem + write(6,*) 'MAXSUBem needs to be reset as large as nsub' + write(6,*) 'in PARAMETER statement in subroutine emint' + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + write(47,*) 'nsub =',nsub, ' is greater than MAXSUBem=',MAXSUBem + write(47,*) 'MAXSUBem needs to be reset as large as nsub' + write(47,*) 'in PARAMETER statement in subroutine emint' + CLOSE(47) + + + + CALL PAUSE + stop + + + + endif + + + + if(npoint.gt.MAXACTem) then + + + + write(6,*) 'npoint=',npoint,' is larger than MAXACTem=',MAXACTem + write(6,*) 'MAXACTem needs to be reset as large as npoint' + write(6,*) 'in PARAMETER statement in subroutine emint' + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + write(47,*) 'npoint=',npoint,' is larger than MAXACTem=',MAXACTem + write(47,*) 'MAXACTem needs to be reset as large as npoint' + write(47,*) 'in PARAMETER statement in subroutine emint' + CLOSE(47) + + + + CALL PAUSE + stop + + + + endif + + + +c Second, check that psi is non-negative + psimin=0. + do j=1,nsub + do i=1,npoint + if(psi(j,i).le.psimin) psimin=psi(j,i) + enddo + enddo + + + + if(psimin.lt.0) then + + + + write(6,*) 'Psi matrix not non-negative -stop' + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + write(47,*) 'Psi matrix not non-negative -stop' + CLOSE(47) + + + + CALL PAUSE + stop + + + + endif + + + +c Third,check that the row sums of psi are positive - no zero rows +c also initialize x and w + colsummin=1.e10 + do j=1,nsub + s=0. + do i=1,npoint + x(i)=1.d0 + s=s+psi(j,i) + enddo + psisum(j) = s + Ptx(j)=s + if(s.le.colsummin) colsummin=s + + + + if(s.le.0) then + + + + write(6,*) 'psi has a zero row -stop' + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE + +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + write(47,*) 'psi has a zero row -stop' + CLOSE(47) + + + + CALL PAUSE + stop + + + + endif + + + + w(j)=1./s + enddo +c calc ptw = w'*psi + shrink=0. + do i=1,npoint + sum=0.d0 + do j=1,nsub + sum=sum+psi(j,i)*w(j) + enddo + y(i)=sum + if(sum.gt.shrink) shrink=sum + enddo + shrink=2.d0*shrink + + if(s.le.0) then + + write(6,*) 'Psi has a zero column -stop' + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + write(47,*) 'Psi has a zero column -stop' + CLOSE(47) + + CALL PAUSE + stop + + endif + +c stopping tolerance + eps=1.d-10 + sig=0.d0 + mu=0.d0 + do i=1,npoint +c x = x*shrink; + x(i)=1.d0*shrink +c Ptw = Ptw/shrink; + y(i)=y(i)/shrink +c y = ecol-Ptw; + y(i)=1.d0-y(i) +c mu = (x'*y)/npoint; + mu=mu+x(i)*y(i) + enddo + mu=mu/npoint + rmax = -1.e38 + do j=1,nsub +c w = w/shrink; + w(j)=w(j)/shrink +c Plam = Plam*shrink; + + Ptx(j)=Ptx(j)*shrink +c +c R = erow-w.*Plam; + if(dabs(1.d0-w(j)*Ptx(j)).ge.rmax) rmax = + & dabs(1.d0-w(j)*Ptx(j)) + enddo + gap=1.d0 +c start of iterations + iter=0 +100 continue +c following is iteration termination condition + + + conval = mu + if(conval .lt. rmax) conval = rmax + if(conval .lt. gap) conval = gap + convcrit = eps/conval +C IF(ILOOP .GT. 0) WRITE(*,123) iter,convcrit +C123 FORMAT(' Iteration ',I9,' CONV. CRIT = ',G15.2,' (1 OR HIGHER FOR +C 1CONVERGENCE)') + +C ABOVE WRITE STATEMENT ADDED IN bigmlt12.f SO THE USER WILL KNOW +C THE PROGRAM HAS NOT 'HUNG' IF THE OPTIMIZATION TAKES A 'LONG' TIME. + + + if(mu.le.eps.and.rmax.le.eps.and.gap.le.eps) go to 9000 + iter=iter+1 + + ILOOP = ILOOP + 1 + + tbuilda=0 + smu=sig*mu +c zero out hessian + do j=1,nsub + do k=1,nsub + hess(j,k)=0. + enddo + enddo +c do outer product portion of Hessian + do i=1,npoint + scale=x(i)/y(i) + do j=1,nsub + fact=scale*psi(j,i) + do k=j,nsub + hess(k,j)=hess(k,j)+fact*psi(k,i) + enddo + enddo + enddo + do j=1,nsub-1 + do k=j+1,nsub + + hess(j,k)=hess(k,j) + enddo + enddo +c do diagonal portion of hessian + do j=1,nsub + hess(j,j)=hess(j,j)+Ptx(j)/w(j) + enddo + tbuildb=0 + tbuild=tbuildb-tbuilda + + +c now do cholesky decomposition-for time bing, use simple dpofa +c from LINPACK +c call dpofa(hess,MAXSUBem,nsub,info) +c call dsifa(hess,MAXSUBem,nsub,kpvt,info) +c note dpofa is cholesky factorization routine from LINPACK +c dsifa is symmetric indefintie factorization routine from LINAPCK +c DPOTRF is Cholesky factorization routine from LAPACK +c DPOTRF is fastest of the three, but DSIFA may be more reliable for +c nearly singular cases +c Regardless of which of the three routines is used, it must be matched +c with the proper solve routine (dposl for dpofa, dsisl for dsifa, +c DPOTRS for DPOTRF below + + + CALL DPOTRF( 'L', nsub, hess, MAXSUBem, INFO ) + tbuildc=0 + tfactor=tbuildc-tbuildb + + +c As of npageng18.f, set IHESS = 0. If info .ne. 0, reset it = -1 and, +c after writing the indicated message to the screen (and also now to +c the output file), return to MAIN, where IHESS = -1 tells the program +c to create the output files before stopping (previously, if +c info .ne. 0, the program would simply stop after writing the +c indicated message to the screen). + + IHESS = 0 + + if(info .ne. 0) then + + IHESS = -1 + + WRITE(*,163) + 163 FORMAT(//' Hessian matrix in interior point EM algorithm'/ + 1' is singular. Possibly number of grid points is too small,'/ + 2' or assay coefficients are too large. '// + 3' Try again with a new assay polynomial or larger grid.'// + 4' Suggested quick fix: rerun and select error model 2)'/ + 5' in response to the initial question; then enter a'/ + 6' initial value gamma = 10.0 in response to the prompt for'/ + 7' that value.'// + 8' THIS IS IN MODULE NPAGFULL.FOR. '//) + + + WRITE(*,164) info + 164 FORMAT(//' NOTE THAT IN SUBROUTINE emint, THE VALUE OF INFO'/ + 1' IS ',i6,// + 2' IF THIS VALUE IS POSTIVE, IT IS LIKELY THE NO. OF THE SUBJECT'/ + 3' (OR AT LEAST THE FIRST SUBJECT) WHICH CAUSED THE HESSIAN '/ + + 4' ERROR. SO IN THIS CASE, YOU MIGHT ALSO WANT TO EXAMINE THE'/ + 5' DATA IN THIS SUBJECT TO VERIFY THEY ARE CORRECT.'//) + +c As of npageng22.f, the following PAUSE is commented out ... since +c it --> the program will not complete properly if it is run under +c Pmetrics (which cannot supply a keyboard response during a run). +c CALL PAUSE + +c As of npageng18.f, the program does not stop here; it returns to +c MAIN to write out the output files and then stops. + + return + + endif + + + +c construct rhs for linear equation system + do j=1,nsub + sum=0.d0 + do i=1,npoint + + sum=sum+psi(j,i)*smu/y(i) + enddo + dw(j)=1.d0/w(j)-sum + enddo +c now solve linear system with LINPACK routine dposl +c and put answer in dw +c note - these routines match the factor routines dpofa, dsifa, and DPOTRF, respectively +c see note about 15 lines back where the factor routine is called +c call dposl(hess,MAXSUBem,nsub,dw) + +c call dsisl(hess,MAXSUBem,nsub,kpvt,dw) + call DPOTRS( 'L', nsub, 1, hess, MAXSUBem, dw, nsub, INFO ) +c now compute dy and dx from dw + + do i=1,npoint + sum=0. + do j=1,nsub + sum=sum+psi(j,i)*dw(j) + enddo + dy(i)=-sum + dx(i)=smu/y(i)-x(i)-dy(i)*x(i)/y(i) + enddo +c damp the Newton step + alfpri=-.5 + do i=1,npoint + if(dx(i)/x(i).le.alfpri) alfpri=dx(i)/x(i) + enddo + alfpri=-1.d0/alfpri + alfpri=min(1.d0,0.99995*alfpri) + alfdual=-0.5d0 + do i=1,npoint + if(dy(i)/y(i).le.alfdual) alfdual=dy(i)/y(i) + enddo + alfdual=-1.d0/alfdual + + alfdual=min(1.d0,0.99995*alfdual) + mu=0.d0 + do i=1,npoint + x(i)=x(i)+alfpri*dx(i) + y(i)=y(i)+alfdual*dy(i) + mu=mu+x(i)*y(i) + enddo + mu=mu/npoint + do j=1,nsub + sum=0.d0 + do i=1,npoint + sum=sum+psi(j,i)*x(i) + enddo + + Ptx(j)=sum + enddo + do j=1,nsub + w(j)=w(j)+alfdual*dw(j) + + enddo +c compute rmax (norm(r,inf)-note we don't really need to compute r + rmax=0. + do j=1,nsub + rtest=1.d0-w(j)*Ptx(j) + if(dabs(rtest).gt.rmax) rmax=dabs(rtest) + enddo + sumlogw=0.d0 + sumlgPtx=0.d0 + do j=1,nsub + sumlogw=sumlogw+dlog(w(j)) + sumlgPtx=sumlgPtx+dlog(Ptx(j)) + enddo + gap = dabs(sumlogw+sumlgPtx)/(1.d0+dabs(sumlgPtx)) + if(mu.lt.eps.and.rmax.gt.eps) then + sig=1.d0 + else + c2=1.d2 + term1=(1.d0-alfpri)**2 + term2=(1.d0-alfdual)**2 + term3=(rmax-mu)/(rmax+c2*mu) + term=max(term1,term2) + term=max(term,term3) + sig=min(0.3d0,term) + endif + sumx=0.d0 + do i=1,npoint + sumx=sumx+x(i) + enddo + fobj=0. + do j=1,nsub + fobj=fobj+dlog(Ptx(j)/sumx) + enddo + go to 100 +c following is exit point +9000 continue +c finish by normalizing x to sum to 1. +c fobj has already been computed + sumx=0. + do i=1,npoint + sumx=sumx+x(i) + enddo + do i=1,npoint + x(i)=x(i)/sumx + enddo +c finished if ijob=0 + if(ijob.eq.0) return + isum=0 + xlim=0. + do i=1,npoint + if(x(i).gt.xlim) xlim=x(i) + enddo + xlim=xlim*1.d-3 + isum = 0 + do i=1,npoint + if(x(i).gt.xlim) then + isum = isum + 1 + list(isum) = i + do j=1,nsub + psi(j,isum) = psi(j,i) + enddo +cpull +c now condense the original density grid + do j=1,nvar + theta(isum,j)=theta(i,j) + enddo + x(isum)=x(i) + endif + enddo + job=1 + do k=1,npoint + ipivot(k)=0 + enddo +c save a copy of psi after current end of psi + do i=1,isum + do j=1,nsub + psi(j,i+isum)=psi(j,i) + enddo + enddo + do i=1,isum + do j=1,nsub + psi(j,i) = psi(j,i)/psisum(j) + enddo + enddo + call dqrdc(psi,ldpsi,nsub,isum,y,ipivot,dy,job) + + keep = 0 + limloop = nsub + if(isum.lt.nsub) limloop = isum + do i=1,limloop + test=dnrm2(i,psi(1,i),1) +cdebugwrite(6,*) i,psi(i,i),test,psi(i,i)/test + + if(dabs(psi(i,i)/test).ge.1.d-8) keep=keep+1 + enddo +c sort ipivot to avoid collisions during condensing + + if(isum.gt.1) then + do i=1,keep-1 + do j=i,keep + if(ipivot(i)*ipivot(j).ne.0.and.ipivot(i).gt.ipivot(j)) then + itemp=ipivot(i) + ipivot(i)=ipivot(j) + + ipivot(j)=itemp + endif + enddo + enddo + endif + do i=1,isum + do j=1,nsub + psi(j,i)=psi(j,i+isum) + enddo + enddo +c restore psi + + + + +C CALL PAUSE + do k=1,npoint + dx(k)=0 + enddo + sumkeep = 0. + do k=1,keep + j=ipivot(k) + + if(j.ne.0) then + do jj=1,nsub + psi(jj,k)=psi(jj,j) + enddo + do jvar=1,nvar + theta(k,jvar) = theta(j,jvar) + enddo + endif + if(j.gt.0) dx(list(j))=1. + if(j.gt.0) sumkeep = sumkeep + x(list(j)) + if(j.gt.0) w(k)=x(list(j)) + enddo + return + end + subroutine dpoco(a,lda,n,rcond,z,info) + integer lda,n,info + double precision a(lda,1),z(1) + double precision rcond +c +c dpoco factors a double precision symmetric positive definite +c matrix and estimates the condition of the matrix. +c +c if rcond is not needed, dpofa is slightly faster. +c to solve a*x = b , follow dpoco by dposl. +c to compute inverse(a)*c , follow dpoco by dposl. + +c to compute determinant(a) , follow dpoco by dpodi. +c to compute inverse(a) , follow dpoco by dpodi. +c + +c on entry +c +c a double precision(lda, n) +c the symmetric matrix to be factored. only the +c diagonal and upper triangle are used. +c + +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix r so that a = trans(r)*r + +c where trans(r) is the transpose. +c the strict lower triangle is unaltered. +c if info .ne. 0 , the factorization is not complete. +c +c rcond double precision +c an estimate of the reciprocal condition of a . +c for the system a*x = b , relative perturbations +c in a and b of size epsilon may cause +c relative perturbations in x of size epsilon/rcond . +c if rcond is so small that the logical expression +c 1.0 + rcond .eq. 1.0 +c is true, then a may be singular to working +c precision. in particular, rcond is zero if +c exact singularity is detected or the estimate +c underflows. if info .ne. 0 , rcond is unchanged. +c +c z double precision(n) +c a work vector whose contents are usually unimportant. +c if a is close to a singular matrix, then z is +c an approximate null vector in the sense that +c norm(a*z) = rcond*norm(a)*norm(z) . +c if info .ne. 0 , z is unchanged. +c +c info integer +c = 0 for normal return. +c = k signals an error condition. the leading minor +c of order k is not positive definite. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c linpack dpofa + + +c blas daxpy,ddot,dscal,dasum +c fortran dabs,dmax1,dreal,dsign +c +c internal variables +c + double precision ddot,ek,t,wk,wkm + double precision anorm,s,dasum,sm,ynorm + integer i,j,jm1,k,kb,kp1 +c +c +c find norm of a using only upper half +c + do 30 j = 1, n + z(j) = dasum(j,a(1,j),1) + jm1 = j - 1 + if (jm1 .lt. 1) go to 20 + do 10 i = 1, jm1 + + z(i) = z(i) + dabs(a(i,j)) + 10 continue + + 20 continue + 30 continue + anorm = 0.0d0 + do 40 j = 1, n + anorm = dmax1(anorm,z(j)) + 40 continue +c +c factor +c + call dpofa(a,lda,n,info) + if (info .ne. 0) go to 180 +c +c rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . +c estimate = norm(z)/norm(y) where a*z = y and a*y = e . +c the components of e are chosen to cause maximum local +c growth in the elements of w where trans(r)*w = e . +c the vectors are frequently rescaled to avoid overflow. + +c +c solve trans(r)*w = e +c + ek = 1.0d0 + do 50 j = 1, n + z(j) = 0.0d0 + 50 continue + do 110 k = 1, n + if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k)) + if (dabs(ek-z(k)) .le. a(k,k)) go to 60 + s = a(k,k)/dabs(ek-z(k)) + call dscal(n,s,z,1) + ek = s*ek + 60 continue + wk = ek - z(k) + wkm = -ek - z(k) + s = dabs(wk) + sm = dabs(wkm) + wk = wk/a(k,k) + wkm = wkm/a(k,k) + kp1 = k + 1 + if (kp1 .gt. n) go to 100 + do 70 j = kp1, n + sm = sm + dabs(z(j)+wkm*a(k,j)) + z(j) = z(j) + wk*a(k,j) + s = s + dabs(z(j)) + 70 continue + if (s .ge. sm) go to 90 + t = wkm - wk + wk = wkm + do 80 j = kp1, n + z(j) = z(j) + t*a(k,j) + 80 continue + 90 continue + 100 continue + z(k) = wk + 110 continue + s = 1.0d0/dasum(n,z,1) + call dscal(n,s,z,1) +c +c solve r*y = w +c + do 130 kb = 1, n + k = n + 1 - kb + if (dabs(z(k)) .le. a(k,k)) go to 120 + s = a(k,k)/dabs(z(k)) + call dscal(n,s,z,1) + 120 continue + z(k) = z(k)/a(k,k) + t = -z(k) + call daxpy(k-1,t,a(1,k),1,z(1),1) + 130 continue + s = 1.0d0/dasum(n,z,1) + call dscal(n,s,z,1) +c + ynorm = 1.0d0 +c +c solve trans(r)*v = y +c + do 150 k = 1, n + z(k) = z(k) - ddot(k-1,a(1,k),1,z(1),1) + if (dabs(z(k)) .le. a(k,k)) go to 140 + s = a(k,k)/dabs(z(k)) + call dscal(n,s,z,1) + ynorm = s*ynorm + 140 continue + z(k) = z(k)/a(k,k) + 150 continue + s = 1.0d0/dasum(n,z,1) + call dscal(n,s,z,1) + ynorm = s*ynorm + + +c +c solve r*z = v +c + do 170 kb = 1, n + k = n + 1 - kb + if (dabs(z(k)) .le. a(k,k)) go to 160 + s = a(k,k)/dabs(z(k)) + call dscal(n,s,z,1) + ynorm = s*ynorm + 160 continue + z(k) = z(k)/a(k,k) + t = -z(k) + call daxpy(k-1,t,a(1,k),1,z(1),1) + 170 continue +c make znorm = 1.0 + s = 1.0d0/dasum(n,z,1) + call dscal(n,s,z,1) + ynorm = s*ynorm +c + if (anorm .ne. 0.0d0) rcond = ynorm/anorm + if (anorm .eq. 0.0d0) rcond = 0.0d0 + 180 continue + return + end + subroutine dpofa(a,lda,n,info) + integer lda,n,info + double precision a(lda,1) +c +c dpofa factors a double precision symmetric positive definite +c matrix. +c + +c dpofa is usually called by dpoco, but it can be called +c directly with a saving in time if rcond is not needed. +c (time for dpoco) = (1 + 18/n)*(time for dpofa) . +c +c on entry +c +c a double precision(lda, n) +c the symmetric matrix to be factored. only the +c diagonal and upper triangle are used. +c +c lda integer +c the leading dimension of the array a . + +c +c n integer +c the order of the matrix a . +c +c on return +c +c a an upper triangular matrix r so that a = trans(r)*r +c where trans(r) is the transpose. +c the strict lower triangle is unaltered. +c if info .ne. 0 , the factorization is not complete. +c +c info integer +c = 0 for normal return. +c = k signals an error condition. the leading minor +c of order k is not positive definite. +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c +c subroutines and functions +c +c blas ddot +c fortran dsqrt +c +c internal variables +c + + double precision ddot,t + double precision s + integer j,jm1,k +c begin block with ...exits to 40 + +c +c + do 30 j = 1, n + info = j + s = 0.0d0 + jm1 = j - 1 + if (jm1 .lt. 1) go to 20 + do 10 k = 1, jm1 + t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1) + t = t/a(k,k) + a(k,j) = t + s = s + t*t + 10 continue + 20 continue + s = a(j,j) - s +c ......exit + if (s .le. 0.0d0) go to 40 + a(j,j) = dsqrt(s) + 30 continue + info = 0 + 40 continue + return + end + subroutine dposl(a,lda,n,b) + + integer lda,n + double precision a(lda,1),b(1) +c + +c dposl solves the double precision symmetric positive definite +c system a * x = b +c using the factors computed by dpoco or dpofa. +c +c on entry +c +c a double precision(lda, n) +c the output from dpoco or dpofa. +c +c lda integer +c the leading dimension of the array a . +c +c n integer + +c the order of the matrix a . +c +c b double precision(n) +c the right hand side vector. +c + +c on return +c +c b the solution vector x . +c +c error condition +c +c a division by zero will occur if the input factor contains +c a zero on the diagonal. technically this indicates +c singularity but it is usually caused by improper subroutine +c arguments. it will not occur if the subroutines are called +c correctly and info .eq. 0 . +c +c to compute inverse(a) * c where c is a matrix + +c with p columns +c call dpoco(a,lda,n,rcond,z,info) +c if (rcond is too small .or. info .ne. 0) go to ... +c do 10 j = 1, p +c call dposl(a,lda,n,c(1,j)) +c 10 continue +c +c linpack. this version dated 08/14/78 . +c cleve moler, university of new mexico, argonne national lab. +c + +c subroutines and functions +c +c blas daxpy,ddot +c +c internal variables +c + double precision ddot,t + integer k,kb +c +c solve trans(r)*y = b +c + do 10 k = 1, n + + t = ddot(k-1,a(1,k),1,b(1),1) + b(k) = (b(k) - t)/a(k,k) + 10 continue +c +c solve r*x = y +c + do 20 kb = 1, n + k = n + 1 - kb + b(k) = b(k)/a(k,k) + t = -b(k) + call daxpy(k-1,t,a(1,k),1,b(1),1) + 20 continue + return + end + subroutine dsifa(a,lda,n,kpvt,info) + integer lda,n,kpvt(1),info + double precision a(lda,1) +c +c dsifa factors a double precision symmetric matrix by elimination +c with symmetric pivoting. +c +c to solve a*x = b , follow dsifa by dsisl. +c to compute inverse(a)*c , follow dsifa by dsisl. +c to compute determinant(a) , follow dsifa by dsidi. +c to compute inertia(a) , follow dsifa by dsidi. +c to compute inverse(a) , follow dsifa by dsidi. +c +c on entry +c +c a double precision(lda,n) +c the symmetric matrix to be factored. +c only the diagonal and upper triangle are used. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c on return +c +c a a block diagonal matrix and the multipliers which +c were used to obtain it. + +c the factorization can be written a = u*d*trans(u) +c where u is a product of permutation and unit +c upper triangular matrices , trans(u) is the +c transpose of u , and d is block diagonal + +c with 1 by 1 and 2 by 2 blocks. +c +c kpvt integer(n) +c an integer vector of pivot indices. +c +c info integer +c = 0 normal value. +c = k if the k-th pivot block is singular. this is +c not an error condition for this subroutine, +c but it does indicate that dsisl or dsidi may +c divide by zero if called. +c + +c linpack. this version dated 08/14/78 . +c james bunch, univ. calif. san diego, argonne nat. lab. + +c +c subroutines and functions +c +c blas daxpy,dswap,idamax +c fortran dabs,dmax1,dsqrt +c +c internal variables +c + double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t + double precision absakk,alpha,colmax,rowmax + integer imax,imaxp1,j,jj,jmax,k,km1,km2,kstep,idamax + logical swap +c +c +c initialize +c +c alpha is used in choosing pivot block size. + alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0 +c + info = 0 +c +c main loop on k, which goes from n to 1. +c + k = n + 10 continue +c +c leave the loop if k=0 or k=1. +c +c ...exit + if (k .eq. 0) go to 200 + if (k .gt. 1) go to 20 + kpvt(1) = 1 + if (a(1,1) .eq. 0.0d0) info = 1 +c ......exit + go to 200 + 20 continue +c +c this section of code determines the kind of +c elimination to be performed. when it is completed, +c kstep will be set to the size of the pivot block, and +c swap will be set to .true. if an interchange is +c required. +c + km1 = k - 1 + absakk = dabs(a(k,k)) +c +c determine the largest off-diagonal element in +c column k. +c + + imax = idamax(k-1,a(1,k),1) + colmax = dabs(a(imax,k)) + if (absakk .lt. alpha*colmax) go to 30 + kstep = 1 + swap = .false. + go to 90 + 30 continue +c +c determine the largest off-diagonal element in +c row imax. +c + rowmax = 0.0d0 + + imaxp1 = imax + 1 + do 40 j = imaxp1, k + rowmax = dmax1(rowmax,dabs(a(imax,j))) + 40 continue + if (imax .eq. 1) go to 50 + jmax = idamax(imax-1,a(1,imax),1) + rowmax = dmax1(rowmax,dabs(a(jmax,imax))) + 50 continue + if (dabs(a(imax,imax)) .lt. alpha*rowmax) go to 60 + kstep = 1 + swap = .true. + go to 80 + 60 continue + if (absakk .lt. alpha*colmax*(colmax/rowmax)) go to 70 + kstep = 1 + swap = .false. + go to 80 + 70 continue + kstep = 2 + swap = imax .ne. km1 + 80 continue + 90 continue + if (dmax1(absakk,colmax) .ne. 0.0d0) go to 100 +c +c column k is zero. set info and iterate the loop. +c + kpvt(k) = k + info = k + go to 190 + + 100 continue + + if (kstep .eq. 2) go to 140 +c +c 1 x 1 pivot block. +c + if (.not.swap) go to 120 +c +c perform an interchange. +c + call dswap(imax,a(1,imax),1,a(1,k),1) + do 110 jj = imax, k + j = k + imax - jj + t = a(j,k) + + + a(j,k) = a(imax,j) + a(imax,j) = t + 110 continue + 120 continue +c +c perform the elimination. +c + do 130 jj = 1, km1 + j = k - jj + mulk = -a(j,k)/a(k,k) + t = mulk + call daxpy(j,t,a(1,k),1,a(1,j),1) + a(j,k) = mulk + 130 continue +c +c set the pivot array. +c + kpvt(k) = k + + if (swap) kpvt(k) = imax + go to 190 + 140 continue +c +c 2 x 2 pivot block. +c + if (.not.swap) go to 160 +c +c perform an interchange. +c + call dswap(imax,a(1,imax),1,a(1,k-1),1) + do 150 jj = imax, km1 + j = km1 + imax - jj + t = a(j,k-1) + a(j,k-1) = a(imax,j) + a(imax,j) = t + 150 continue + t = a(k-1,k) + a(k-1,k) = a(imax,k) + a(imax,k) = t + + 160 continue +c +c perform the elimination. +c + km2 = k - 2 + if (km2 .eq. 0) go to 180 + ak = a(k,k)/a(k-1,k) + akm1 = a(k-1,k-1)/a(k-1,k) + + denom = 1.0d0 - ak*akm1 + do 170 jj = 1, km2 + j = km1 - jj + bk = a(j,k)/a(k-1,k) + bkm1 = a(j,k-1)/a(k-1,k) + mulk = (akm1*bk - bkm1)/denom + + mulkm1 = (ak*bkm1 - bk)/denom + t = mulk + call daxpy(j,t,a(1,k),1,a(1,j),1) + t = mulkm1 + call daxpy(j,t,a(1,k-1),1,a(1,j),1) + a(j,k) = mulk + a(j,k-1) = mulkm1 + + + + 170 continue + + 180 continue +c +c set the pivot array. +c + kpvt(k) = 1 - k + if (swap) kpvt(k) = -imax + kpvt(k-1) = kpvt(k) + + 190 continue + k = k - kstep + go to 10 + 200 continue + return + end + subroutine dsisl(a,lda,n,kpvt,b) + integer lda,n,kpvt(1) + double precision a(lda,1),b(1) +c +c dsisl solves the double precision symmetric system +c a * x = b + +c using the factors computed by dsifa. +c +c on entry +c +c a double precision(lda,n) +c the output from dsifa. +c +c lda integer +c the leading dimension of the array a . +c +c n integer +c the order of the matrix a . +c +c kpvt integer(n) +c the pivot vector from dsifa. +c +c b double precision(n) +c the right hand side vector. +c +c on return +c +c b the solution vector x . +c +c error condition +c +c a division by zero may occur if dsico has set rcond .eq. 0.0 + +c or dsifa has set info .ne. 0 . +c +c to compute inverse(a) * c where c is a matrix +c with p columns +c call dsifa(a,lda,n,kpvt,info) +c if (info .ne. 0) go to ... +c do 10 j = 1, p +c call dsisl(a,lda,n,kpvt,c(1,j)) +c 10 continue +c +c linpack. this version dated 08/14/78 . +c james bunch, univ. calif. san diego, argonne nat. lab. +c +c subroutines and functions +c +c blas daxpy,ddot +c fortran iabs +c +c internal variables. +c + double precision ak,akm1,bk,bkm1,ddot,denom,temp + integer k,kp + +c +c loop backward applying the transformations and +c d inverse to b. +c + k = n + 10 if (k .eq. 0) go to 80 + if (kpvt(k) .lt. 0) go to 40 +c +c 1 x 1 pivot block. +c + if (k .eq. 1) go to 30 + kp = kpvt(k) + if (kp .eq. k) go to 20 +c +c interchange. +c + + temp = b(k) + b(k) = b(kp) + + b(kp) = temp + + 20 continue +c +c apply the transformation. +c + call daxpy(k-1,b(k),a(1,k),1,b(1),1) + 30 continue +c + +c apply d inverse. +c + b(k) = b(k)/a(k,k) + k = k - 1 + go to 70 + 40 continue + +c +c 2 x 2 pivot block. +c + if (k .eq. 2) go to 60 + kp = iabs(kpvt(k)) + if (kp .eq. k - 1) go to 50 +c +c interchange. +c + temp = b(k-1) + b(k-1) = b(kp) + b(kp) = temp + 50 continue +c +c apply the transformation. +c + call daxpy(k-2,b(k),a(1,k),1,b(1),1) + call daxpy(k-2,b(k-1),a(1,k-1),1,b(1),1) + 60 continue +c +c apply d inverse. +c + ak = a(k,k)/a(k-1,k) + akm1 = a(k-1,k-1)/a(k-1,k) + bk = b(k)/a(k-1,k) + bkm1 = b(k-1)/a(k-1,k) + denom = ak*akm1 - 1.0d0 + b(k) = (akm1*bk - bkm1)/denom + b(k-1) = (ak*bkm1 - bk)/denom + k = k - 2 + 70 continue + go to 10 + 80 continue +c +c loop forward applying the transformations. +c + k = 1 + 90 if (k .gt. n) go to 160 + if (kpvt(k) .lt. 0) go to 120 +c +c 1 x 1 pivot block. +c + if (k .eq. 1) go to 110 +c +c apply the transformation. +c + b(k) = b(k) + ddot(k-1,a(1,k),1,b(1),1) + kp = kpvt(k) + if (kp .eq. k) go to 100 + +c +c interchange. +c + temp = b(k) + b(k) = b(kp) + b(kp) = temp + + + 100 continue + 110 continue + k = k + 1 + go to 150 + 120 continue +c +c 2 x 2 pivot block. +c + if (k .eq. 1) go to 140 +c +c apply the transformation. +c + b(k) = b(k) + ddot(k-1,a(1,k),1,b(1),1) + b(k+1) = b(k+1) + ddot(k-1,a(1,k+1),1,b(1),1) + kp = iabs(kpvt(k)) + if (kp .eq. k) go to 130 +c +c interchange. + + +c + temp = b(k) + b(k) = b(kp) + b(kp) = temp + 130 continue + 140 continue + k = k + 2 + 150 continue + + go to 90 + 160 continue + return + end + subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job) + integer ldx,n,p,job + integer jpvt(1) + double precision x(ldx,1),qraux(1),work(1) +c +c dqrdc uses householder transformations to compute the qr +c factorization of an n by p matrix x. column pivoting +c based on the 2-norms of the reduced columns may be +c performed at the users option. +c +c on entry +c +c x double precision(ldx,p), where ldx .ge. n. +c x contains the matrix whose decomposition is to be + +c computed. +c +c ldx integer. +c ldx is the leading dimension of the array x. +c +c n integer. +c n is the number of rows of the matrix x. +c +c p integer. +c p is the number of columns of the matrix x. + +c +c jpvt integer(p). +c jpvt contains integers that control the selection +c of the pivot columns. the k-th column x(k) of x +c is placed in one of three classes according to the +c value of jpvt(k). +c +c if jpvt(k) .gt. 0, then x(k) is an initial +c column. + +c +c if jpvt(k) .eq. 0, then x(k) is a free column. + +c +c if jpvt(k) .lt. 0, then x(k) is a final column. +c +c before the decomposition is computed, initial columns +c are moved to the beginning of the array x and final +c columns to the end. both initial and final columns +c are frozen in place during the computation and only +c free columns are moved. at the k-th stage of the +c reduction, if x(k) is occupied by a free column +c it is interchanged with the free column of largest +c reduced norm. jpvt is not referenced if +c job .eq. 0. +c +c work double precision(p). +c work is a work array. work is not referenced if +c job .eq. 0. +c +c job integer. +c job is an integer that initiates column pivoting. +c if job .eq. 0, no pivoting is done. +c if job .ne. 0, pivoting is done. +c +c on return +c +c x x contains in its upper triangle the upper + +c triangular matrix r of the qr factorization. +c below its diagonal x contains information from +c which the orthogonal part of the decomposition +c can be recovered. note that if pivoting has + +c been requested, the decomposition is not that +c of the original matrix x but that of x +c with its columns permuted as described by jpvt. +c +c qraux double precision(p). +c qraux contains further information required to recover +c the orthogonal part of the decomposition. +c +c jpvt jpvt(k) contains the index of the column of the +c original matrix that has been interchanged into +c the k-th column, if pivoting was requested. +c +c linpack. this version dated 08/14/78 . +c g.w. stewart, university of maryland, argonne national lab. +c + +c dqrdc uses the following functions and subprograms. +c +c blas daxpy,ddot,dscal,dswap,dnrm2 +c fortran dabs,dmax1,min0,dsqrt +c +c internal variables +c + integer j,jp,l,lp1,lup,maxj,pl,pu + double precision maxnrm,dnrm2,tt + double precision ddot,nrmxl,t + logical negj,swapj +c +c + pl = 1 + pu = 0 + if (job .eq. 0) go to 60 +c +c pivoting has been requested. rearrange the columns +c according to jpvt. +c + do 20 j = 1, p + swapj = jpvt(j) .gt. 0 + negj = jpvt(j) .lt. 0 + jpvt(j) = j + if (negj) jpvt(j) = -j + if (.not.swapj) go to 10 + if (j .ne. pl) call dswap(n,x(1,pl),1,x(1,j),1) + jpvt(j) = jpvt(pl) + jpvt(pl) = j + pl = pl + 1 + 10 continue + + 20 continue + pu = p + do 50 jj = 1, p + j = p - jj + 1 + if (jpvt(j) .ge. 0) go to 40 + + jpvt(j) = -jpvt(j) + if (j .eq. pu) go to 30 + call dswap(n,x(1,pu),1,x(1,j),1) + jp = jpvt(pu) + jpvt(pu) = jpvt(j) + jpvt(j) = jp + 30 continue + pu = pu - 1 + 40 continue + 50 continue + 60 continue + +c +c compute the norms of the free columns. +c + if (pu .lt. pl) go to 80 + do 70 j = pl, pu + qraux(j) = dnrm2(n,x(1,j),1) + work(j) = qraux(j) + 70 continue + 80 continue +c +c perform the householder reduction of x. +c + lup = min0(n,p) + do 200 l = 1, lup + if (l .lt. pl .or. l .ge. pu) go to 120 + +c +c locate the column of largest norm and bring it +c into the pivot position. +c + maxnrm = 0.0d0 + + maxj = l + do 100 j = l, pu + if (qraux(j) .le. maxnrm) go to 90 + maxnrm = qraux(j) + maxj = j + 90 continue + + 100 continue + if (maxj .eq. l) go to 110 + call dswap(n,x(1,l),1,x(1,maxj),1) + qraux(maxj) = qraux(l) + work(maxj) = work(l) + jp = jpvt(maxj) + jpvt(maxj) = jpvt(l) + jpvt(l) = jp + 110 continue + 120 continue + qraux(l) = 0.0d0 + if (l .eq. n) go to 190 +c +c compute the householder transformation for column l. +c + nrmxl = dnrm2(n-l+1,x(l,l),1) + if (nrmxl .eq. 0.0d0) go to 180 + if (x(l,l) .ne. 0.0d0) nrmxl = dsign(nrmxl,x(l,l)) + call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1) + x(l,l) = 1.0d0 + x(l,l) +c +c apply the transformation to the remaining columns, +c updating the norms. +c + lp1 = l + 1 + + if (p .lt. lp1) go to 170 + do 160 j = lp1, p + t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) + call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) + if (j .lt. pl .or. j .gt. pu) go to 150 + if (qraux(j) .eq. 0.0d0) go to 150 + tt = 1.0d0 - (dabs(x(l,j))/qraux(j))**2 + tt = dmax1(tt,0.0d0) + t = tt + tt = 1.0d0 + 0.05d0*tt*(qraux(j)/work(j))**2 + if (tt .eq. 1.0d0) go to 130 + qraux(j) = qraux(j)*dsqrt(t) + + go to 140 + 130 continue + qraux(j) = dnrm2(n-l,x(l+1,j),1) + work(j) = qraux(j) + 140 continue + 150 continue + 160 continue + 170 continue +c +c save the transformation. + +c + qraux(l) = x(l,l) + x(l,l) = -nrmxl + 180 continue + + 190 continue + 200 continue + return + end +C LAPACK routines follow +C note that thte call to the LAPACK auxialliary routine +C that defines NB has been rpelaced by a hardwired +C NB=16 in dpotrf.f +C This is probably OK for PCs, but workstations may be a bit faster with +C NB = 32 + SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 + +* +* .. Scalar Arguments .. + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) + +* .. +* +* Purpose +* ======= +* +* DPOTRF computes the Cholesky factorization of a real symmetric +* positive definite matrix A. +* +* The factorization has the form +* A = U**T * U, if UPLO = 'U', or +* A = L * L**T, if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular. + +* +* This is the block version of the algorithm, calling Level 3 BLAS. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* + +* N (input) INTEGER + +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* N-by-N upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading N-by-N lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization A = U**T*U or A = L*L**T. +* +* LDA (input) INTEGER +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value + +* > 0: if INFO = i, the leading minor of order i is not +* positive definite, and the factorization could not be +* completed. +* +* ===================================================================== +* +* .. Parameters .. + + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J, JB, NB +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. + +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -4 + END IF + + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOTRF', -INFO ) + RETURN + END IF +* +* Quick return if possible + +* + IF( N.EQ.0 ) + $ RETURN +* +* Determine the block size for this environment. +* + nb = 16 + IF( NB.LE.1 .OR. NB.GE.N ) THEN +* +* Use unblocked code. +* + CALL DPOTF2( UPLO, N, A, LDA, INFO ) + ELSE +* +* Use blocked code. +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U'*U. +* + DO 10 J = 1, N, NB +* +* Update and factorize the current diagonal block and test +* for non-positive-definiteness. +* + JB = MIN( NB, N-J+1 ) + CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, + $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) + CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 30 + IF( J+JB.LE.N ) THEN +* +* Compute the current block row. +* + CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, + $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), + $ LDA, ONE, A( J, J+JB ), LDA ) + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', + $ JB, N-J-JB+1, ONE, A( J, J ), LDA, + $ A( J, J+JB ), LDA ) + END IF + 10 CONTINUE + +* + ELSE +* +* Compute the Cholesky factorization A = L*L'. +* + DO 20 J = 1, N, NB +* +* Update and factorize the current diagonal block and test +* for non-positive-definiteness. +* + JB = MIN( NB, N-J+1 ) + CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, + $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) + CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) + IF( INFO.NE.0 ) + $ GO TO 30 + IF( J+JB.LE.N ) THEN +* +* Compute the current block column. +* + CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, + $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), + + $ LDA, ONE, A( J+JB, J ), LDA ) + CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', + $ N-J-JB+1, JB, ONE, A( J, J ), LDA, + $ A( J+JB, J ), LDA ) + END IF + 20 CONTINUE + END IF + END IF + GO TO 40 +* + 30 CONTINUE + INFO = INFO + J - 1 +* + 40 CONTINUE + RETURN +* +* End of DPOTRF +* + END + SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) +* + +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* March 31, 1993 +* +* .. Scalar Arguments .. + + CHARACTER UPLO + + INTEGER INFO, LDA, LDB, N, NRHS +* .. +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ), B( LDB, * ) +* .. +* +* Purpose +* ======= +* +* DPOTRS solves a system of linear equations A*X = B with a symmetric +* positive definite matrix A using the Cholesky factorization +* A = U**T*U or A = L*L**T computed by DPOTRF. +* +* Arguments +* ========= +* +* UPLO (input) CHARACTER*1 +* = 'U': Upper triangle of A is stored; +* = 'L': Lower triangle of A is stored. +* + +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* NRHS (input) INTEGER +* The number of right hand sides, i.e., the number of columns +* of the matrix B. NRHS >= 0. +* +* A (input) DOUBLE PRECISION array, dimension (LDA,N) +* The triangular factor U or L from the Cholesky factorization +* A = U**T*U or A = L*L**T, as computed by DPOTRF. +* +* LDA (input) INTEGER + +* The leading dimension of the array A. LDA >= max(1,N). + +* +* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) +* On entry, the right hand side matrix B. +* On exit, the solution matrix X. +* + +* LDB (input) INTEGER +* The leading dimension of the array B. LDB >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -i, the i-th argument had an illegal value +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ONE + PARAMETER ( ONE = 1.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER +* .. +* .. External Functions .. + LOGICAL LSAME + EXTERNAL LSAME +* .. +* .. External Subroutines .. + EXTERNAL DTRSM, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX +* .. + +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( NRHS.LT.0 ) THEN + INFO = -3 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + INFO = -5 + ELSE IF( LDB.LT.MAX( 1, N ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOTRS', -INFO ) + RETURN + END IF + +* +* Quick return if possible +* + IF( N.EQ.0 .OR. NRHS.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Solve A*X = B where A = U'*U. +* + +* Solve U'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) +* +* Solve U*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) + ELSE +* +* Solve A*X = B where A = L*L'. +* +* Solve L*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, + $ NRHS, ONE, A, LDA, B, LDB ) +* +* Solve L'*X = B, overwriting B with X. +* + CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, + $ ONE, A, LDA, B, LDB ) + END IF +* + RETURN +* +* End of DPOTRS +* + END + SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) +* +* -- LAPACK routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + + CHARACTER UPLO + INTEGER INFO, LDA, N +* .. + +* .. Array Arguments .. + DOUBLE PRECISION A( LDA, * ) +* .. +* +* Purpose +* ======= + +* +* DPOTF2 computes the Cholesky factorization of a real symmetric +* positive definite matrix A. + +* +* The factorization has the form +* A = U' * U , if UPLO = 'U', or +* A = L * L', if UPLO = 'L', +* where U is an upper triangular matrix and L is lower triangular. +* +* This is the unblocked version of the algorithm, calling Level 2 BLAS. +* +* Arguments + +* ========= +* +* UPLO (input) CHARACTER*1 +* Specifies whether the upper or lower triangular part of the +* symmetric matrix A is stored. +* = 'U': Upper triangular + +* = 'L': Lower triangular +* +* N (input) INTEGER +* The order of the matrix A. N >= 0. +* +* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) + + +* On entry, the symmetric matrix A. If UPLO = 'U', the leading +* n by n upper triangular part of A contains the upper +* triangular part of the matrix A, and the strictly lower +* triangular part of A is not referenced. If UPLO = 'L', the +* leading n by n lower triangular part of A contains the lower +* triangular part of the matrix A, and the strictly upper +* triangular part of A is not referenced. +* +* On exit, if INFO = 0, the factor U or L from the Cholesky +* factorization A = U'*U or A = L*L'. +* +* LDA (input) INTEGER + +* The leading dimension of the array A. LDA >= max(1,N). +* +* INFO (output) INTEGER +* = 0: successful exit +* < 0: if INFO = -k, the k-th argument had an illegal value +* > 0: if INFO = k, the leading minor of order k is not +* positive definite, and the factorization could not be +* completed. +* +* ===================================================================== + +* +* .. Parameters .. + DOUBLE PRECISION ONE, ZERO + PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) +* .. +* .. Local Scalars .. + LOGICAL UPPER + INTEGER J + DOUBLE PRECISION AJJ +* .. +* .. External Functions .. + LOGICAL LSAME + DOUBLE PRECISION DDOT + EXTERNAL LSAME, DDOT +* .. +* .. External Subroutines .. + EXTERNAL DGEMV, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, SQRT + +* .. +* .. Executable Statements .. +* +* Test the input parameters. +* + INFO = 0 + UPPER = LSAME( UPLO, 'U' ) + IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -2 + ELSE IF( LDA.LT.MAX( 1, N ) ) THEN + + INFO = -4 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DPOTF2', -INFO ) + RETURN + END IF +* +* Quick return if possible +* + IF( N.EQ.0 ) + $ RETURN +* + IF( UPPER ) THEN +* +* Compute the Cholesky factorization A = U'*U. +* + DO 10 J = 1, N +* +* Compute U(J,J) and test for non-positive-definiteness. +* + AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) + IF( AJJ.LE.ZERO ) THEN + A( J, J ) = AJJ + GO TO 30 + END IF + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of row J. +* + IF( J.LT.N ) THEN + CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), + $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) + CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) + END IF + + 10 CONTINUE + ELSE +* +* Compute the Cholesky factorization A = L*L'. +* + DO 20 J = 1, N +* +* Compute L(J,J) and test for non-positive-definiteness. +* + AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), + $ LDA ) + IF( AJJ.LE.ZERO ) THEN + A( J, J ) = AJJ + GO TO 30 + END IF + AJJ = SQRT( AJJ ) + A( J, J ) = AJJ +* +* Compute elements J+1:N of column J. +* + IF( J.LT.N ) THEN + CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), + $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) + CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) + END IF + 20 CONTINUE + END IF + GO TO 40 +* + 30 CONTINUE + INFO = J +* + 40 CONTINUE + RETURN +* +* End of DPOTF2 +* + END + LOGICAL FUNCTION LSAME( CA, CB ) +* +* -- LAPACK auxiliary routine (version 3.0) -- +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* September 30, 1994 +* +* .. Scalar Arguments .. + CHARACTER CA, CB +* .. +* +* Purpose +* ======= +* +* LSAME returns .TRUE. if CA is the same letter as CB regardless of +* case. +* +* Arguments +* ========= +* +* CA (input) CHARACTER*1 +* CB (input) CHARACTER*1 +* CA and CB specify the single characters to be compared. +* +* ===================================================================== +* +* .. Intrinsic Functions .. + INTRINSIC ICHAR +* .. +* .. Local Scalars .. + INTEGER INTA, INTB, ZCODE +* .. +* .. Executable Statements .. + +* +* Test if the characters are equal + +* + LSAME = CA.EQ.CB + + IF( LSAME ) + $ RETURN +* +* Now test for equivalence if both characters are alphabetic. +* + + ZCODE = ICHAR( 'Z' ) + +* +* Use 'Z' rather than 'A' so that ASCII can be detected on Prime +* machines, on which ICHAR returns a value with bit 8 set. +* ICHAR('A') on Prime machines returns 193 which is the same as +* ICHAR('A') on an EBCDIC machine. +* + INTA = ICHAR( CA ) + INTB = ICHAR( CB ) +* + IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN +* +* ASCII is assumed - ZCODE is the ASCII code of either lower or +* upper case 'Z'. +* + IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 + IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 +* + ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN +* +* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or +* upper case 'Z'. + +* + IF( INTA.GE.129 .AND. INTA.LE.137 .OR. + $ INTA.GE.145 .AND. INTA.LE.153 .OR. + $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 + IF( INTB.GE.129 .AND. INTB.LE.137 .OR. + $ INTB.GE.145 .AND. INTB.LE.153 .OR. + $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 + +* + ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN +* +* ASCII is assumed, on Prime machines - ZCODE is the ASCII code +* plus 128 of either lower or upper case 'Z'. +* + IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 + IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 + END IF + LSAME = INTA.EQ.INTB +* +* RETURN +* +* End of LSAME +* + END + + SUBROUTINE XERBLA( SRNAME, INFO ) + +* +* -- LAPACK auxiliary routine (preliminary version) -- + + +* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., +* Courant Institute, Argonne National Lab, and Rice University +* February 29, 1992 +* +* .. Scalar Arguments .. + + + INTEGER INFO + CHARACTER*6 SRNAME,ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + +* .. + +* +* Purpose +* ======= +* +* XERBLA is an error handler for the LAPACK routines. +* It is called by an LAPACK routine if an input parameter has an +* invalid value. A message is printed and execution stops. +* +* Installers may consider modifying the STOP statement in order to +* call system-specific exception-handling facilities. +* +* Arguments +* ========= +* +* SRNAME (input) CHARACTER*6 +* The name of the routine which called XERBLA. + +* +* INFO (input) INTEGER +* The position of the invalid parameter in the parameter list +* of the calling routine. +* +* + WRITE( *, FMT = 9999 )SRNAME, INFO + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + WRITE( 47, FMT = 9999 )SRNAME, INFO + CLOSE(47) + + CALL PAUSE + STOP +* + 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', + $ 'an illegal value' ) +* +* End of XERBLA +* + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE GETIPATF + +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE GETNUMSF + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE WRITEPT2 + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE GETSUB + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE CALCTPRED + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE CONDENSE + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE PAUSE (IT'S IN ANOTHER MODULE) + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE NEWWORK1 + + IMPLICIT REAL*8(A-H,O-Z) + PARAMETER(MAXNUMEQ=7) + DIMENSION SIG(5000),RS(5000,34),DELTAIV(7),ORDELT(7), + 1 RSS(5000,34),SIGG(5000),TIM(594),TIMM(594),YO(594,MAXNUMEQ), + 2 TIMDELAY(99) + + CHARACTER READLINE*300,ERRFIL*20 + + COMMON/ERR/ERRFIL + +C SUBROUTINE NEWWORK1 (BASED ON THE STAND-A-LONE VERSION OF THE SAME +C NAME) READS IN A WORKING COPY PATIENT DATA FILE, AND OUTPUTS ANOTHER +C FILE WHICH IS: + +C a. EXACTLY THE SAME IF THE ORIGINAL FILE HAS NO STEADY STATE DOSE +C INDICATORS; + +C OR + +C b. ALTERED TO HAVE THE SAME INFO AS IN THE ORIGINAL FILE, BUT ALSO +C CONTAINING AN EXTRA 100 DOSES FOR EACH STEADY STATE DOSE +C INDICATOR. + +C NOTES: + +C 1. A STEADY STATE DOSE INDICATOR IS A NEGATIVE VALUE IN THE TIME +C ENTRY FOR A DOSE. THIS IS ACCOMPANIED BY INFORMATION ON THE SET OF +C DOSES IN THE IV AND BOLUS ENTRIES, AS THE FOLLOWING EXAMPLE SHOWS: + +C Time IV Bolus +C -2.0 100.0 150.0 ... + +C THE ABOVE LINE WOULD TELL THE PROGRAM: + +C a. THAT THIS WAS INFO ON 100 STEADY STATE DOSES BECAUSE OF THE +C NEGATIVE TIME VALUE; +C b. THE TIME BETWEEN CONSECUTIVE IV START TIMES = 2 HOURS, BECAUSE +C THIS IS THE ABS. VALUE OF THE TIME; +C C. THE IV RATE = 100MG/HOUR; +C D. THE TOTAL DRUG AMT. FOR EACH IV DOSE IS 150MG. + +C SO THE PROGRAM WOULD THEN ADD 100 DOSES TO THE PATIENT DATA FILE, +C STARTING AT T = 0, EACH WITH AN IV RATE = 100, AND CONTINUING FOR +C 1.5 HOURS. + +C 2. IT WILL BE ASSUMED THAT EACH STEADY STATE DOSE INDICATOR ALWAYS +C WILL BE REPLACED BY 100 IV DOSES (NOT BOLUS DOSES). +C AS OF npageng17.f, STEADY STATE DOSES MAY BE BOLUS DOSES. IN THIS +C CASE, THE IV RATE WILL BE 0.0 OF COURSE. + +C 3. ALL OTHER TIMES IN THE PATIENT DATA FILE (UP TO THE NEXT TIME +C RESET IF THERE IS ONE) WILL BE ASSUMED TO BE TIMES FROM THE END OF +C THE 100TH DOSE INTERVAL. IN THE ABOVE EXAMPLE, THE 100TH DOSE +C INTERVAL WOULD END AT T = 200 (THE LAST IV ITSELF WOULD END AT +C T = 199.5, BUT THE 100TH DOSE INTERVAL WOULD END AT T = 200). SO ALL +C OTHER TIMES IN THE DOSAGE AND OBSERVATION BLOCKS WOULD HAVE 200 ADDED +C TO THEIR VALUES. + +C 4. THE ABOVE EXAMPLE IS FOR ONE DRUG ONLY, BUT ANY OR ALL OF THE +C NDRUGS IN A PATIENT'S FILE CAN HAVE STEADY STATE DOSES. ANY DRUG +C WHICH HAS A NON-0 VALUE IN THE BOLUS COLUMN OF A STEADY STATE DOSE +C LINE (I.E., ONE WITH TIME < 0) WILL PARTICIPATE IN A STEADY STATE +C DOSE SET, GETTING THAT AMOUNT OF DRUG IN EACH OF THE 100 DOSES. IF +C THE IV COLUMN IS > 0, THEN THE DRUG WILL BE GIVEN AT THE RATE +C SHOWN IN THE IV COLUMN. IF THE IV COLUMN IS 0, THEN THE DRUG WILL +C BE GIVEN AS A BOLUS. + +C 5. THE 100 STEADY STATE DOSES CAN BE GIVEN AS THE FIRST SET OF DOSES +C IN A PATIENT'S FILE, AS INDICATED ABOVE, OR AT ANY TIME RESET. IF +C THEY ARE AT A TIME RESET, ALL THE SUBSEQUENT TIMES AFTER THAT TIME +C RESET (UP TO THE NEXT TIME RESET IF THERE IS ONE) ARE ADJUSTED AS +C INDICATED ABOVE TO BE TIMES AFTER THE END OF THAT SET OF 100 DOSES. + +C----------------------------------------------------------------------- + + +C FILE 27 WAS OPENED IN MAIN AND THE POINTER IS AT THE TOP OF A PATIENT +C WHOSE INFO IS TO BE PUT ONTO FILE 37. BUT IT WILL NOT BE PUT ON TO +C FILE 37 UNTIL THE DOSE BLOCK OF FILE 27 HAS BEEN READ ... AND +C EXAMINED TO SEE IF IT HAS A STEADY STATE DOSE INDICATOR. IF IT DOES, +C IT MEANS THAT THIS PART OF FILE 37 WILL HAVE AN EXTRA SET OF 100 +C DOSES FOR EACH DRUG. + +C NOTE ALSO THAT, AS OF npagen18.f, TIMOBREL(JSUB,J), J=1,M, WILL BE +C STORED AND RETURNED TO MAIN. NO! IN NPAGFULLA, TIMOBREL IS NOT +C NEEDED. + + + 1717 FORMAT(A300) + + 10 READ(27,1717) READLINE + IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 + +C READLINE NOW CONTAINS THE NO. OF DRUGS, NDRUG. BACKSPACE AND READ +C NDRUG; THEN READ THE NO. OF ADDITIONAL COVARIATES, AND THE NO. OF + +C DOSE EVENTS. + + 3 FORMAT(T2,I5) + + BACKSPACE(27) + READ(27,3) NDRUG + READ(27,3) NADD + READ(27,3) ND + NI = 2*NDRUG + NADD + +C IF THERE ARE NO DOSE EVENTS (ND = 0), THE INFO ON FILE 37 WILL BE THE +C SAME AS ON FILE 27 (SINCE THERE CAN BE NO STEADY STATE DOSE EVENTS IF +C THERE ARE NO DOSES). IN THIS CASE, SET ICOPY = 1 (SEE BELOW). + + IF(ND .EQ. 0) ICOPY = 1 + +C IF ANY SIG(.) IS NEGATIVE, SET ICOPY = 0 SINCE A SIG(.) < 0 IS THE +C INDICATOR FOR A STEADY STATE SET OF DOSES. + + + IF(ND .GE. 1) THEN + + READ(27,*) + READ(27,*) + + ICOPY = 1 + + + DO I = 1,ND + + READ(27,*) SIG(I),(RS(I,J),J=1,NI) + + IF(SIG(I) .LT. 0.D0) ICOPY = 0 + + END DO + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ND .GE. 1) CONDITION. + + + + 140 READ(27,1717) READLINE + + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 140 + + BACKSPACE(27) + + READ(27,*) NUMEQT + READ(27,3) M + + +C IF ICOPY = 1, IT MEANS THAT THIS PATIENT DATA FILE DOES NOT HAVE +C A STEADY STATE DOSE SET, WHICH MEANS THAT THIS PART OF FILE 27 WILL +C BE COPIED LINE FOR LINE TO FILE 37 BELOW. + + IF(ICOPY .EQ. 1) THEN + + +C COPY FILE 27 TO FILE 37,LINE FOR LINE. + +C BACKSPACE FILE 27 TO THE FIRST LINE FOR THIS PATIENT. + + + 1720 BACKSPACE(27) + BACKSPACE(27) + READ(27,1717,IOSTAT=IEND) READLINE + + IF(IEND .LT. 0) THEN + +C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED, BUT IF IT'S REACHED +C AT THIS POINT, NOT ALL "ACTIVE" NSUB SUBJECT DATA SETS WERE READ +C AND WRITTEN CORRECTLY TO FILE 37. IN THIS CASE, WRITE A MESSAGE TO +C THE USER AND STOP. + + WRITE(*,1721) + 1721 FORMAT(/' PATIENT DATA INFORMATION WAS NOT READ CORRECTLY'/ + 1' FROM THE INSTRUCTION FILE, npag102.inp. IF YOU EDITED THIS'/ + 2' FILE MANUALLY, PLEASE RERUN THE PC PREP PROGRAM TO HAVE IT'/ + 3' PREPARE npag102.inp AGAIN AND THEN RERUN THIS PROGRAM.'// + 4' IF YOU DID NOT MANUALLY EDIT npag102.inp, PLEASE SEND THE'/ + 5' DETAILS OF THIS RUN (STARTING WITH THE PC PREP EXECUTION) TO'/ + 5' THE LAPK. '// + 6' THANK YOU.'/) + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + WRITE(47,1721) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + IF(READLINE(3:16) .NE. 'LAST AND FIRST') GO TO 1720 + + + WRITE(37,1717) READLINE + + 30 READ(27,1717) READLINE + WRITE(37,1717) READLINE + + IF(READLINE(12:23) .NE. 'NO. OF DOSE ') GO TO 30 + +C THE LINE JUST WRITTEN TO FILE 37 IS THE NO. OF DOSE EVENTS LINE. +C WRITE THE NEXT TWO LINES ALSO. + + DO I = 1,2 + READ(27,1717) READLINE + WRITE(37,1717) READLINE + END DO + + +C IF ND = 0, SKIP TO THE OUTPUT SECTION. OTHERWISE, WRITE THE DOSAGE +C REGIMEN TO FILE 37. + + IF(ND.EQ.0) GO TO 40 + + DO I = 1,ND + READ(27,*) SIG(I),(RS(I,J),J=1,NI) + WRITE(37,*) SIG(I),(RS(I,J),J=1,NI) + END DO + +C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' +C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC., AND +C WRITE THE REST OF THE FILE 27 TO FILE 37. + + 40 READ(27,1717) READLINE + WRITE(37,1717) READLINE + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 + + BACKSPACE(27) + +C SINCE NUMEQT IS PROVIDED TO THIS ROUTINE IN THE ARGUMENT LIST, +C JUST READ(27,*) ON NEXT LINE. + + READ(27,*) + READ(27,3) M + +C BACKSPACE JUST ONCE TO THE LINE WITH M ON IT, SINCE THE LINE WITH + +C NUMEQT ON IT WAS ALREADY PUT INTO FILE 37. + + BACKSPACE(27) + READ(27,1717) READLINE + WRITE(37,1717) READLINE + + DO I = 1,M + READ(27,*) TIM(I),(YO(I,J),J=1,NUMEQT) + WRITE(37,*) TIM(I),(YO(I,J),J=1,NUMEQT) +C TIMOBREL(JSUB,I) = TIM(I) + END DO + +C NOW COPY LINE FOR LINE THE REST OF THIS PATIENT'S INFO TO FILE 37. +C THIS PATIENT'S INFO WILL END WHEN THE END OF THE FILE IS REACHED +C (IF THIS IS THE LAST PATIENT), OR WHEN THE START OF THE NEXT + +C PATIENT OCCURS. + + + 50 READ(27,1717,IOSTAT=IEND) READLINE + IF(IEND .LT. 0) GO TO 100 + IF(READLINE(3:16) .EQ. 'LAST AND FIRST') GO TO 100 + + WRITE(37,1717) READLINE + GO TO 50 + + + 100 BACKSPACE(27) + +C FILE 27 WAS BACKSPACED ONE LINE SO THE NEXT LINE TO BE READ IN IN +C MAIN WILL BE THE FIRST LINE OF THE NEXT SUBJECT (UNLESS THIS SUBJECT +C IS THE LAST SUBJECT, IN WHICH CASE THE BACKSPACE WON'T MATTER). + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICOPY .EQ. 1) CONDITION. + + + IF(ICOPY .EQ. 0) THEN + + +C SINCE ICOPY = 0, IT MEANS THAT THERE IS AT LEAST ONE SET OF STEADY +C STATE DOSES IN THE DOSAGE BLOCK. THE LOGIC FOR TRANSLATING THESE +C STEADY STATE DOSES TO A REGULAR DOSAGE BLOCK (EXCEPT FOR THE NEGATIVE +C DOSE TIME AT THE START OF EACH STEADY STATE DOSE SET) IS AS FOLLOWS: + +C EACH DOSAGE LINE WILL BE COPIED UNALTERED UNLESS IT IS PART OF A +C STEADY STATE SET. + +C EACH STEADY STATE SET STARTS WITH A SIG(I) < 0. IN THIS CASE, 100 +C DOSES WILL BE APPLIED AT THIS POINT WITH THE STEADY STATE DOSE FOR +C DRUG IDRUG = RS(I,2*IDRUG), WHICH WILL BE APPLIED AS A BOLUS IF +C RS(I,2*IDRUG-1) = 0, AND AS AN IV WITH DURATION +C RS(I,2*IDRUG)/RS(I,2*IDRUG-1) IF RS(I,2*IDRUG-1) > 0. +C THE REST OF THE DOSE TIMES IN THIS BLOCK OF DOSES (I.E., UNTIL THE +C NEXT TIME RESET OR STEADY STATE DOSE INDICATOR) WILL BE INCREASED +C BY 100*DELDOSE, WHERE DELDOSE = -SIG(I) = INTERDOSE INTERVAL FOR +C THIS SET. + + +C ILINE WILL BE THE RUNNING INDEX OF THE NEXT DOSAGE LINE TO BE PUT + +C INTO THE ALTERED DOSAGE REGIMEN. SIGG(ILINE) AND RSS(ILINE,.) ARE +C THE VALUES THAT GO INTO THIS LINE. DELDOSE IS THE CURRENT INTERDOSE +C TIME INTERVAL FOR THE LAST STEADY STATE SET OF DOSES ALREADY PUT +C INTO THE ALTERED DOSAGE REGIMEN (IT IS INITIALIZED TO BE 0 OF +C COURSE). + +C AND NSECTION IS INITIALIZED TO BE 0. IT WILL BE THE RUNNING NO. OF +C DOSAGE SECTIONS. EACH SECTION BEGINS WITH EITHER A 0.0 (BEGINNING +C LINE OR TIME RESET) OR A NEGATIVE NO. (STEADY STATE DOSE SET +C INDICATOR). THE TIME DELAY ASSOCIATED WITH EACH DOSE SECTION (WHICH +C WILL BE 0 IF THAT SECTION IS NOT A STEADY STATE DOSE SET), MUST BE +C STORED TO BE APPLIED TO THE CORRESPONDING SET OF OBSERVED VALUES +C BELOW. + + + ILINE = 0 + DELDOSE = 0.D0 + NSECTION = 0 + + DO ID = 1,ND + + + IF(SIG(ID) .GE. 0.D0) THEN + + CALL THESAME(SIG(ID),0.D0,ISAME) + + IF(ISAME .EQ. 1) THEN + DELDOSE = 0.D0 + NSECTION = NSECTION + 1 + + TIMDELAY(NSECTION) = 0.0 + ENDIF + +C NOTE THAT IF SIG(ID) = 0, THIS LINE IS A TIME RESET LINE, OR THE +C FIRST LINE IN THE DOSAGE REGIMEN. IF IT'S THE FIRST LINE IN THE +C DOSAGE REGIMEN, THERE ARE OBVIOUSLY NO PREVIOUS STEADY STATE DOSE +C SETS. IF ITS A TIME RESET LINE, A PREVIOUS SET OF 100 STEADY STATE +C DOSES HAS NO EFFECT ON IT. THAT'S WHY DELDOSE IS SET = 0, WHICH +C MEANS, BELOW, THAT SIGG(ILINE) WILL = SIG(ID) = 0. ALSO, THE TIME +C DELAY STORED IN TIMDELAY ABOVE IS 0 SINCE SIG(ID) .GE. 0 --> THIS +C IS NOT A STEADY STATE DOSE SET. + + ILINE = ILINE + 1 + SIGG(ILINE) = SIG(ID) + 100.D0*DELDOSE + + DO J = 1,NI + RSS(ILINE,J) = RS(ID,J) + END DO + + ENDIF + + + IF(SIG(ID) .LT. 0.D0) THEN + +C THIS LINE GIVES INFO ON A STEADY STATE SET OF 100 DOSES WHICH IS +C TO APPLIED AT THIS POINT. + + DO IDRUG = 1,NDRUG + +C FOR DRUG, IDRUG, THE AMOUNT OF DRUG FOR DRUG NO. IDRUG IN EACH OF THE +C 100 DOSES WILL BE RS(ID,2*IDRUG). IF RS(ID,2*IDRUG) > 0, DRUG, IDRUG, +C PARTICIPATES IN THE STEADY STATE DOSING. IF THIS VALUE = 0, DRUG, +C IDRUG, DOES NOT PARTICIPATE. NOTE THAT IF A DRUG PARTICIPATES, THE +C ROUTE WILL BE AS AN IV, WITH RATE RS(ID,2*IDRUG-1), IF + +C RS(ID,2*IDRUG-1) > 0. BUT IF THIS VALUE IS 0, THE DRUG WILL BE GIVEN +C AS A BOLUS. NOTE THAT THE INTERVAL BETWEEN DOSES IS -SIG(ID). + + +C IF DRUG, IDRUG, PARTICIPATES IN THE 100 STEADY STATE DOSE SET, PUT +C THE DURATION OF IV INTO DELTAIV(IDRUG) IF RS(ID,2*IDRUG-1) > 0; +C OTHERWISE PUT 0 INTO DELTAIV(IDRUG) SINCE IN THIS CASE, THE DRUG IS +C GIVEN AS A BOLUS. + + DELTAIV(IDRUG) = 0.D0 + IF(RS(ID,2*IDRUG) .GT. 0.D0 .AND. RS(ID,2*IDRUG-1) .GT. 0.D0) + 1 DELTAIV(IDRUG) = RS(ID,2*IDRUG)/RS(ID,2*IDRUG-1) + +C IT SHOULD NOT BE POSSIBLE FOR THE IV OF THIS DRUG TO BE > 0 AT THE +C SAME TIME THAT THE BOLUS ENTRY = 0. THIS WOULD MEAN THAT AN IV +C WAS TO BE GIVEN AT A SPECIFIED RATE, BUT WITH A TOTAL DOSE OF 0, +C AND THIS MAKES NO SENSE. IF, SOMEHOW, THIS HAS OCCURRED, REPORT IT +C TO THE USER AS AN ERROR, AND STOP. + + IF(RS(ID,2*IDRUG) .LE. 0.D0 .AND. RS(ID,2*IDRUG-1) .GT. 0) THEN + + WRITE(*,101) ID,SIG(ID),IDRUG,RS(ID,2*IDRUG-1),RS(ID,2*IDRUG) + 101 FORMAT(//' THERE IS AN ERROR IN YOUR INSTRUCTION FILE, AS'/ + 1' DETERMINED BY SUBROUTINE NEWWORK1.'// + 2' ONE OF THE SUBJECTS HAS A STEADY STATE DOSE SET WITH A '/ + 3' POSITIVE IV RATE, BUT WITH A TOTAL DOSE AMOUNT .LE. 0.'// + 4' IN PARTICULAR, FOR DOSE EVENT ',I4,' AND TIME ',G19.9,/ + 5' FOR DRUG ',I2,', THE IV VALUE IS ',G19.9,' WHILE THE TOTAL'/ + 6' DOSE AMOUNT IS ',G19.9// + 7' THE PROGRAM STOPS. PLEASE CORRECT THE ERROR BEFORE RERUNNING.'/) + + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + WRITE(47,101) ID,SIG(ID),IDRUG,RS(ID,2*IDRUG-1),RS(ID,2*IDRUG) + CLOSE(47) + + CALL PAUSE + STOP + ENDIF + + + END DO + + +C CALL SUBROUTINE ORDERDELTA TO OBTAIN NDELTA, THE NO. OF UNIQUE +C NON-0 VALUES IN THE DELTAIV(.) ARRAY JUST ESTABLISHED ABOVE, AND TO +C PUT THE ORDERED SET OF THESE NDELTA VALUES INTO ORDELT(.). + +C NOTE THAT IF DELTAIV(IDRUG) = 0, IT MEANS THAT DRUG, IDRUG, DOES NOT +C PARTICIPATE IN THE STEADY STATE DOSE SET, OR IF IT DOES, IT IS GIVEN +C AS A BOLUS RATHER THAN AN IV. + + CALL ORDERDELTA(NDRUG,DELTAIV,NDELTA,ORDELT) + +C NOW ESTABLISH THE LINES WITH SIGG(.) AND RSS(.,.) AS FOLLOWS: + +C 1. THE NEXT 100*(NDELTA + 1) ROWS WILL BE FOR THE STEADY STATE +C DOSE SET (I.E., EACH OF THE 100 REPEATED DOSES HAS A START TIME, +C AND THEN NDELTA ENDING TIMES AMONG ALL NDRUG DRUGS). NOTE THAT +C NDELTA WILL BE 0 IF ALL THE PARTICIPATING DRUGS ARE BOLUSES SINCE +C THEY WOULDN'T NEED AN ENDING TIME THEN. + +C 2. EVERY ROW OF THE ORIGINAL DOSAGE REGIMEN AFTER LINE ID +C WILL HAVE THE SAME VALUES IN RSS(.,.) AS IN RS(.,.), BUT THE +C TIMES IN SIGG(.) WILL ALL BE INCREASED BY 100*DELDOSE OVER THOSE +C IN SIG(.) ... UP TO BUT NOT INCLUDING THE NEXT TIME RESET EVENT +C OR NEXT STEADY STATE DOSE INDICATOR LINE, WHERE DELDOSE IS THE TIME +C INCREMENT BETWEEN CONSECUTIVE DOSES IN THE 100 STEADY STATE DOSE SET. +C NOTE THAT DELDOSE IS THE NEGATIVE OF SIG(ID). + + DELDOSE = -SIG(ID) + NSECTION = NSECTION + 1 + TIMDELAY(NSECTION) = 100.D0*DELDOSE + +C NOTE THAT THE TIME DELAY ASSOCIATED WITH THIS STEADY STATE SET IS +C STORED INTO TIMDELAY ABOVE SO THAT IT CAN BE APPLIED TO THE +C CORRESPONDING SET OF OBSERVED VALUES BELOW. + + + DO ISET = 1,100 + + +C FOR EACH SET, ESTABLISH NDELTA + 1 ROWS (DOSE EVENT LINES). + + +C THE FIRST ROW IN THIS SET HAS EACH DRUG IV SET = RS(ID,2*IDRUG-1), +C AND, FOR EACH DRUG IV WHICH IS 0, THE BOLUS VALUE WILL BE SET = +C RS(ID,2*IDRUG). NOTE THAT IF A DRUG IV > 0, THE BOLUS VALUE WILL BE +C SET = 0 SINCE IN THIS CASE, THE VALUE IN THE BOLUS COLUMN IS THE +C TOTAL AMOUNT OF IV (NOT A BOLUS AMOUNT). + + ILINE = ILINE + 1 + + DO IDRUG = 1,NDRUG + RSS(ILINE,2*IDRUG-1) = RS(ID,2*IDRUG-1) + RSS(ILINE,2*IDRUG) = RS(ID,2*IDRUG) + IF(RS(ID,2*IDRUG-1) .GT. 0.D0) RSS(ILINE,2*IDRUG) = 0.D0 + END DO + +C SET ALL THE COVARIATE VALUES = TO THOSE IN LINE ID OF RS OF COURSE. + + DO IADD = 1,NADD + RSS(ILINE,2*NDRUG+IADD) = RS(ID,2*NDRUG+IADD) + END DO + +C THE TIME FOR THIS ROW IS (ISET-1)*DELDOSE, EXCEPT FOR THE FIRST +C LINE, WHICH MUST HAVE THE SAME NEGATIVE VALUE AS IN SIG, SINCE +C THE ID ROUTINES MUST READ THE NEGATIVE SIG VALUE TO KNOW THAT A +C STEADY STATE DOSE SET IS STARTING. + + IF(ISET .EQ. 1) THEN + SIGG(ILINE) = SIG(ID) + DOSESTART = 0.D0 + ENDIF + + IF(ISET .GT. 1) THEN + SIGG(ILINE) = (ISET-1)*DELDOSE + DOSESTART = SIGG(ILINE) + + ENDIF + +C THE NEXT NDELTA ROWS ARE THE IV TURN OFF ROWS FOR THE VARIOUS DRUGS, +C IF NDELTA > 0. NOTE THAT NDELTA COULD = 0 IF ALL PARTICIPATING DRUGS +C ARE GIVEN VIA A BOLUS, SINCE THEN NONE WOULD NEED A TURN OFF ROW. + + IF(NDELTA .GT. 0) THEN + + DO INDEL = 1,NDELTA + + ILINE = ILINE + 1 + +C THE NEXT TURN OFF TIME IS DOSESTART + ORDELT(INDEL). EACH IV WILL BE +C OFF UNLESS ITS DELTAIV(.) IS .GT ORDELT(INDEL). AND EACH BOLUS VALUE +C WILL BE 0 OF COURSE (I.E., EACH BOLUS IS GIVEN JUST ONE TIME AT THE +C START OF EACH SET). + + DO IDRUG = 1,NDRUG + RSS(ILINE,2*IDRUG-1) = 0.D0 + IF(DELTAIV(IDRUG) .GT. ORDELT(INDEL)) + 1 RSS(ILINE,2*IDRUG-1) = RS(ID,2*IDRUG-1) + RSS(ILINE,2*IDRUG) = 0.D0 + END DO + +C SET ALL THE COVARIATE VALUES = TO THOSE IN LINE ID OF RS AGAIN. + + DO IADD = 1,NADD + RSS(ILINE,2*NDRUG+IADD) = RS(ID,2*NDRUG+IADD) + END DO + + +C THE TIME FOR THIS ROW IS DOSESTART + ORDELT(INDEL) + + SIGG(ILINE) = DOSESTART + ORDELT(INDEL) + + END DO + +C THE ABOVE END DO IS FOR THE DO INDEL = 1,NDELTA LOOP. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NDELTA .GT. 0) CONDITION. + + + + END DO + +C THE ABOVE END DO IS FOR DO ISET = 1,100 LOOP. + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(SIG(ID) .LT. 0.D0) CONDITION. + + + + END DO + +C THE ABOVE END DO IS FOR THE DO ID = 1,ND LOOP. + + +C THIS COMPLETES THE ESTABLISHMENT OF RSS(.,.) AND SIGG(.) ABOVE. + + +C NOW ALTER THE OBSERVED VALUE TIMES BY ADDING THE APPROPRIATE VALUE +C IN TIMDELAY(.) TO EACH OBSERVED VALUE TIME BELOW. NOTE THAT +C TIMDELAY(1) APPLIES TO ALL TIMES BEFORE THE FIRST TIME RESET, +C TIMDELAY(2) APPLIES TO THE NEXT SET OF TIMES AFTER THE FIRST +C TIME RESET BUT BEFORE THE 2ND, ETC. IF THERE ARE NO TIME RESETS, +C ALL TIMES WILL HAVE TIMDELAY(1) ADDED TO THEM, AND THIS VALUE WILL +C BE 0.0 (SEE DOSAGE BLOCK CODE ABOVE - IF THERE ARE NO TIME RESETS +C OR STEADY STATE DOSE SETS, TIMDELAY(1) IS SET = 0). + +C SINCE THE OBSERVATION BLOCK WAS READ THROUGH ABOVE, BACKSPACE TO +C THE BEGINNING OF THE OBS. BLOCK, SO THIS PART OF THE PATIENT'S +C DATA CAN BE ACCESSED AGAIN. + +1920 BACKSPACE(27) + BACKSPACE(27) + READ(27,1717,IOSTAT=IEND) READLINE + + IF(IEND .LT. 0) THEN + +C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED, BUT IF IT'S REACHED +C AT THIS POINT, NOT ALL "ACTIVE" NSUB SUBJECT DATA SETS WERE READ +C AND WRITTEN CORRECTLY TO FILE 37. IN THIS CASE, WRITE A MESSAGE TO +C THE USER AND STOP. + + WRITE(*,1721) + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + WRITE(47,1721) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 1920 + + BACKSPACE(27) + +C SINCE NUMEQT IS PROVIDED TO THIS ROUTINE IN THE ARGUMENT LIST, +C JUST READ(27,*) ON NEXT LINE. + + READ(27,*) + + READ(27,3) M + + NSECTION = 1 + + + + DO I = 1,M + READ(27,*) TIM(I),(YO(I,J),J=1,NUMEQT) +C TIMOBREL(JSUB,I) = TIM(I) + CALL THESAME(TIM(I),0.D0,ISAME) + IF(ISAME .EQ. 1 .AND. I .GT. 1) NSECTION = NSECTION + 1 + IF(ISAME .EQ. 1) TIMM(I) = 0.D0 + IF(ISAME .EQ. 0) TIMM(I) = TIM(I) + TIMDELAY(NSECTION) + END DO + + + +C NOW COPY THIS PART OF FILE 27 TO FILE 37 WITH THE FOLLOWING +C EXCEPTIONS: +C 1. ND WILL BE REPLACED BY ILINE (THE TOTAL NO. OF DOSAGE LINES IN +C THE ALTERED DOSAGE REGIMEN). +C 2. SIG(.) WILL BE REPLACED BY SIGG(.). +C 3. RS(.,.) WILL BE REPLACED BY RSS(.,.) +C 4. TIM(.) WILL BE REPLACED BY TIMM(.) +C NOTE THAT YO(.,.) WILL BE UNCHANGED. + +C BACKSPACE FILE 27 TO THE FIRST LINE FOR THIS PATIENT. + + 1820 BACKSPACE(27) + + BACKSPACE(27) + READ(27,1717,IOSTAT=IEND) READLINE + + IF(IEND .LT. 0) THEN + +C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED, BUT IF IT'S REACHED +C AT THIS POINT, NOT ALL "ACTIVE" NSUB SUBJECT DATA SETS WERE READ +C AND WRITTEN CORRECTLY TO FILE 37. IN THIS CASE, WRITE A MESSAGE TO +C THE USER AND STOP. + + WRITE(*,1721) + + +C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE +C TO ERRFIL ALSO. + + OPEN(47,FILE=ERRFIL) + WRITE(47,1721) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + IF(READLINE(3:16) .NE. 'LAST AND FIRST') GO TO 1820 + + WRITE(37,1717) READLINE + + 60 READ(27,1717) READLINE + WRITE(37,1717) READLINE + + IF(READLINE(12:23) .NE. 'NO. OF ADDIT') GO TO 60 + +C THE LINE JUST WRITTEN TO FILE 37 IS THE NO. OF ADDITIONAL COVARIATES +C LINE. WRITE THE NEXT LINE BUT CHANGE FROM ND TO ILINE AS THE NO. +C OF DOSE EVENTS. + + READ(27,1717) READLINE + WRITE(37,133) ILINE + 133 FORMAT(I6,' ... NO. OF DOSE EVENTS') + +C WRITE THE NEXT TWO LINES TO FILE 37 (INCLUDING THE HEADER LINE FOR +C THE DOSAGE BLOCK). + + DO I = 1,2 + READ(27,1717) READLINE + WRITE(37,1717) READLINE + END DO + +C WRITE THE NEW DOSAGE BLOCK. + + + DO I = 1,ILINE + WRITE(37,*) SIGG(I),(RSS(I,J),J=1,NI) + + END DO + + +C READ THROUGH FILE 27 DOWN TO THE END OF THE DOSAGE BLOCK + + + DO I = 1,ND + + READ(27,*) SIG(I),(RS(I,J),J=1,NI) + END DO + +C PUT THE BLANK LINE BETWEEN THE DOSAGE BLOCK AND THE OBSERVATION +C BLOCK TO FILE 37, ALONG WITH THE TWO LINES WHICH GIVE THE NO. OF +C OUTPUT EQS. AND THE NO. OF OBSERVED VALUE TIMES. + + DO I = 1,3 + READ(27,1717) READLINE + WRITE(37,1717) READLINE + END DO + +C WRITE THE OBSERVED BLOCK TO FILE 37, AND READ THROUGH IT IN FILE 27. + + DO I = 1,M + WRITE(37,*) TIMM(I),(YO(I,J),J=1,NUMEQT) + READ(27,*) TIM(I),(YO(I,J),J=1,NUMEQT) + END DO + +C NOW COPY LINE FOR LINE THE REST OF THIS SUBJECT'S INFO TO FILE 37. +C THIS PATIENT'S INFO WILL END WHEN THE END OF THE FILE IS REACHED +C (IF THIS IS THE LAST PATIENT), OR WHEN THE START OF THE NEXT +C PATIENT OCCURS. + + 70 READ(27,1717,IOSTAT=IEND) READLINE + IF(IEND .LT. 0) GO TO 200 + IF(READLINE(3:16) .EQ. 'LAST AND FIRST') GO TO 200 + WRITE(37,1717) READLINE + GO TO 70 + 200 BACKSPACE(27) + +C FILE 27 WAS BACKSPACED ONE LINE SO THE NEXT LINE TO BE READ IN IN +C MAIN WILL BE THE FIRST LINE OF THE NEXT SUBJECT (UNLESS THIS SUBJECT +C IS THE SUBJECT, IN WHICH CASE THE BACKSPACE WON'T MATTER). + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(ICOPY .EQ. 0) CONDITION. + + + RETURN + END + +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C + SUBROUTINE ORDERDELTA(NDRUG,DELTAIV,NDELTA,ORDELT) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION DELTAIV(7),ORDELT(7),X(7) + +C SUBROUTINE ORDERDELTA IS CALLED BY NEWWORK1 TO OBTAIN NDELTA, THE NO. +C OF UNIQUE NON-0 VALUES IN THE DELTAIV(.) ARRAY. THEN THE ORDERED SET +C OF THESE NDELTA VALUES IS PUT INTO ORDELT(.). NOTE THAT +C NDELTA WILL BE 0 IF ALL THE PARTICIPATING DRUGS ARE BOLUSES SINCE +C THEY WOULDN'T NEED AN ENDING TIME THEN. + + +C FIRST STORE ALL THE VALUES IN DELTAIV INTO X SO THAT DELTAIV WILL +C NOT BE CHANGED. + + DO IDRUG = 1,NDRUG + X(IDRUG) = DELTAIV(IDRUG) + END DO + + +C THE LOGIC OF THIS ROUTINE IS BASED ON \PERSONAL\FINANCE\ORDER.FOR. +C TO DO THIS, EACH VALUE IN X(.) WILL BE COMPARED TO THE +C PREVIOUS ONE. IF IT IS < THE PREVIOUS ONE, THE VALUE WILL EXCHANGE +C PLACES WITH THE PREVIOUS ONE, AND THE TESTING WILL CONTINUE. THE +C TESTING WILL STOP FOR A VALUE WHEN IT IS COMPARED TO A PREVIOUS +C VALUE WHICH IS .LE. ITS VALUE. + + DO IDRUG = 2, NDRUG + + +C COMPARE VALUE FOR IDRUG WITH EACH PREVIOUS VALUE, AND HAVE IT +C EXCHANGE PLACES WITH THAT VALUE, UNTIL IT REACHES ONE WHICH HAS A +C SMALLER VALUE. FIRST SET IDRUGNEW = IDRUG; AFTER THE FOLLOWING +C CODE, IDRUGNEW WILL BE THE INDEX NO. FOR VALUE AT THE OLD IDRUG +C POSITION. + + IDRUGNEW = IDRUG + + ICOMP = IDRUG + + 110 ICOMP = ICOMP - 1 + +C NOW COMPARE VALUE IN LOCATION ICOMP WITH THE VALUE IN LOCATION +C IDRUGNEW. IF THE LATTER IS .LT. THE FORMER, INTERCHANGE THE RECORDS. + + IF(X(IDRUGNEW) .LT. X(ICOMP)) THEN + + VALUE = X(IDRUGNEW) + X(IDRUGNEW) = X(ICOMP) + X(ICOMP) = VALUE + IDRUGNEW = ICOMP + + +C IF IDRUGNEW = 1, IT HAS BEEN CHECKED AGAINST ALL RECORDS (AND IS +C THE SMALLEST VALUE); IF IS IS > 1, CONTINUE THE PROCESS. + + IF(IDRUGNEW .EQ. 1) GO TO 150 + IF(IDRUGNEW .GT. 1) GO TO 110 + + + + ENDIF + +C THE ABOVE ENDIF IS FOR THE +C IF(X(IDRUGNEW) .LT. X(ICOMP)) CONDITION. + + + 150 END DO + +C THE ABOVE END DO IS FOR THE DO IDRUG = 2, NDRUG LOOP. + + +C NOW THE NDRUG VALUES ARE ORDERED, FROM SMALL TO LARGE IN X. +C REWRITE THEM INTO ORDELT, BUT PUT ONLY THE NON-0 AND +C UNIQUE VALUES INTO ORDELT, AND KEEP TRACK OF NOW MANY OF THESE +C UNIQUE NON O VALUES THERE ARE - IT WILL BE NDELTA AT THE END OF +C THE FOLLOWING LOOP. + + NDELTA = 0 + + DO IDRUG = 1,NDRUG + +C FOR THIS VALUE TO BE COUNTED, IT CANNOT = THE PREVIOUS VALUE, AND +C IT CANNOT = 0. + + + + IF(IDRUG .EQ. 1 .AND. X(IDRUG) .GT. 0) THEN + NDELTA = NDELTA + 1 + ORDELT(NDELTA) = X(IDRUG) + ENDIF + + + + IF(IDRUG .GE. 2) THEN + + CALL THESAME(X(IDRUG),X(IDRUG-1),ISAME) + + IF(ISAME .EQ. 0) THEN + NDELTA = NDELTA + 1 + ORDELT(NDELTA) = X(IDRUG) + ENDIF + + ENDIF + + END DO + +C THE ABOVE END DO IS FOR THE DO IDRUG = 1,NDRUG LOOP. + + + RETURN + END +C +CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +C TOOK OUT SUBROUTINE THESAME + + + +C NPAGFULLA11.FOR 6/30/14 + +C NPAGFULLA11 HAS THE FOLLOWING CHANGES TO NPAGFULL11: + +C 1. JUST AFTER THE REWIND(27) STATEMENT, SUBROUTINE NEWWORK1 IS +C CALLED TO READ THE PATIENT DATA FROM FILE 27, AND CONVERT IT TO +C PATIENT DATA ON FILE 37, WITH EACH STEADY STATE DOSE INDICATOR +C RESULTING IN AN EXTRA 100 DOSE SETS (WITH THE NEGATIVE DOSE TIME +C LEFT IN - SEE COMMENTS BELOW). NOTE THAT THIS SUBROUTINE NEWWORK1 +C IS THE SAME AS IN THE CURRENT NPAG "ENGINE" MODULE, npageng25.f, +C EXCEPT IT READS FILE 27 AND WRITES TO FILE 37, RATHER THAN READING +C FROM FILE 23 AND WRITING TO FILE 27; ARRAY TIMOBREL IS NOT +C ESTABLISHED IN NEWWORK1, AND NOT PASSED AS AN ARGUMENT (IT IS NOT +C NEEDED IN THIS PROGRAM); MAXSUB IS ALSO NOT PASSED AS AN +C ARGUMENT (IT IS NOT NEEDED); NSUB IS NOT PASSED AS AN ARGUMENT (IT +C IS NOT NEEDED); AND COMMON/DOSEOBS AND THE ARRAYS IN IT ARE DELETED +C (THEY ARE NOT NEEDED). + +C NOTE THAT SUBROUTINE NEWWORK1 IS INCLUDED IN THE NPAGFULLA MODULE. + +C 2. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN +C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx +C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING +C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT +C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT +C USING COMMON/ERR/ERRFIL. + +C 3. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, +C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET +C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED +C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT +C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS +C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL +C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 +C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO +C MAXNUMEQ. + +C 4. COMMON/OBSER IN MAIN IS REMOVED. IT WASN'T NEEDED. SIMILARLY +C ALL THE ARRAYS IN THIS COMMON ARE NO LONGER DIMENSIONED. + +C 5. FORMATS 2345 AND 2346 NOW CORRECTLY REFER TO SUBROUTINE +C NPAGFULL1, RATHER THAN NPAGFULL. + +C----------------------------------------------------------------------- + +C NPAGFULL11.FOR 8/06/13 + +C NPAGFULL11 HAS THE FOLLOWING CHANGE2 FROM NPAGFULL1: +C 1. INSTEAD OF SELELCTING ALL GRID PTS. WHOSE PROBALITIES ARE WITHIN +C 1.D-10 OF THE HIGHEST, THIS PROGRAM TAKES ALL POINTS WHOSE PROBS ARE +C WITHIN 1.D-100 OF THE HIGHEST. + +C SEE THE "IF(MAXCYC .EQ. 0) THEN" CODE NEAR THE END OF MAIN. + +C 2. THE MAIN SUBROUTINE IS RENAMED NPAGFULL11 (INSTEAD OF NPAGFULL). + +C 3. ALL SUBROUTINES OTHER THAN THE MAIN ONE ARE REMOVED SINCE THEY +C ARE ALREADY IN NPAGFULL.FOR, WHICH WILL ALSO BE LINKED TO +C BESTDOSTEMP.FOR (TO BE RENAMED BESTDOS112.FOR) + +C 4. MAXCYC IS REMOVED FROM THE ARGUMENT LIST SINCE IT IS HARDCODED +C TO BE 0 BELOW. + +C----------------------------------------------------------------------- + +C NPAGFULL1.FOR 6/30/13 + +C NPAGFULL1 HAS THE FOLLOWING CHANGES TO NPAGFULL: + +C - MAXCYC IS MANUALLY SET = 0, SO THE VALUE INPUT IN THE ARGUMENT +C STATEMENT IS UNIMPORTANT. +C - AFTER LOOP 800, CONTROL GOES TO LABEL 900 IF MAXCYC = 0. SO THIS +C IS SIMILAR CODE TO npageng24.f, IN THAT IF MAXCYC = 0, NO CYCLE +C CALCS. ARE DONE --> SUBROUTINE emint IS NEVER CALLED. +C - AT LABEL 900, IF MAXCYC = 0 (WHICH OF COURSE IT IS), THEN THE +C REMAINING CODE (FROM SUBROUTINE SUBRES OF npageng24.f) IS USED +C TO FINISH CALCULATING THE BAYESIAN POSTERIOR OF THE SUBJECT. +C AND THIS NEW CORDEN IS RETURNED TO THE MAIN BESTDOS MODULE. + +C------------------------------------------------------------------ + +C NPAGFULL.FOR 3/26/13 + +C NPAGFULL IS BASED ON THE npageng22.f PROGRAM. IT RUNS AN NPAG +C ANALYSIS IN ORDER TO OBTAIN THE FULL POSTERIOR DENSITY OF A SUBJECT +C GIVEN AN APRIORI DENSITY. ALL OTHER CODE IN npageng22.f IS +C REMOVED (E.G., ALL EXTRA CALCULATIONS, ALL WRITING TO FILES, ETC.). + +C NOTE THAT ALL INFO NEEDED BY THIS ROUTINE IS INCLUDED IN THE +C CALLING ARGUMENTS; IN PARTICULAR, npag102.inp IS NOT READ. + +C THIS COMPARES TO NPAGBAY, WHICH CALCULATED THE 0-CYCLE BAYESIAN +C POSTERIOR OF THE SUBJECT. + +C NOTE ALSO THAT ALL DIMENSIONS OF 500 RELATED TO DOSE EVENTS HAVE BEEN +C CHANGE TO 5000. + +C----------------------------------------------------------------------- + +c npageng22.f 11/8/12 + +c npageng22 has the following change from npageng21: + +c 1. It comments out the PAUSE statement following Format 164 in +c Subroutine emint. Reason: the program will not complete properly if +c it is run under Pmetrics (which cannot supply a keyboard response +c during a run). + +c 2. Formats 1657 and 7124 are changed to show that the output file +c is made by npageng22 rather than npageng21. + +c----------------------------------------------------------------------- + +c See npageng22.f code for all the comments from npageng21.f back +c to m2_5calf.f. + + +C----------------------------------------------------------------------- + +C*********************************************************************** + + SUBROUTINE NPAGFULL11(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK, + 1 CORDEN,NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM0, + 2 NGRID,NACTVE,PYJGX,DENSTOR,CORDLAST) + +C NOTE FOR NPAGFULL11, MAXCYC IS NOT SUPPLIED FROM BESTDOS... SINCE +C IT WILL BE HARDCODED TO BE 0 BELOW. + + + IMPLICIT REAL*8(A-H,O-Z) + + PARAMETER(MAXNUMEQ=7) + + + DIMENSION WORK(MAXGRD),WORKK(MAXGRD),PYJGX(MAXSUB,MAXGRD), + 1 DENSTOR(MAXGRD,4),CORDEN(MAXGRD,MAXDIM+1), + 2 CORDLAST(MAXGRD,MAXDIM+1), YO(594,MAXNUMEQ),SIG(594,MAXNUMEQ), + 3 AB(30,2),X(30),VALFIX(20),IRAN(32),PX(32),ATOL(20), + 4 C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ),C3(MAXNUMEQ),ATOLL(20) + +C NOTE THAT ALL DIMENSIONS = 150 HAVE BEEN CHANGED TO 594, SINCE THIS +C NO. REPRESENTS THE TOTAL NO. OF OBSERVATIONS (AND THE MAX. NO IS +C 6 OUTPUT EQUATIONS x 99 OBSERVATIONS/EQ). THIS COULD BE CHANGED +C TO NUMEQT*MAXOBS, BUT IT WOULD BE MORE TROUBLE THAN IT'S WORTH TO +C MAKE THESE DIMENSIONS VARIABLE. + + CHARACTER ERRFIL*20 + + COMMON/ERROR/ERRFIL +C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO +C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. + + + COMMON SIG + COMMON/TOUSER/NDIMM,MFF,RTOLL,ATOLL + COMMON/NXER/NXE +C NXE FROM ABOVE COMMON IS NO. OF TIMES XERRWD IS CALLED. + +C THE BLANK COMMON ABOVE IS SUPPLIED TO SUBROUTINE IDPC. + + +C COMMON/TOUSER IS SUPPLIED TO SUBROUTINE USERANAL IN idfixed.f. +C COMMON/OBSER/ IS SUPPLIED FROM SUBROUTINE FILREAD. +C NO! AS OF NPAGFULLA.FOR, COMMON/OBSER IS REMOVED FROM MAIN. IT IS +C UNNEEDED. SIMILARLY, TIMOB, DOSTIM, RS, Y00, AND BS ARE NO LONGER +C DIMENSIONED IN MAIN. + + +C*********************************************************************** + +C----------------------------------------------------------------------- + + 2 FORMAT(A20) + 222 FORMAT(A3) + 2222 FORMAT(A5) + +C----------------------------------------------------------------------- + +C SET MAXCYC = 0 + MAXCYC = 0 + + NSUB = 1 + + NDIMM = NDIM + MFF = MF + RTOLL = RTOL + DO I = 1,NDIM + ATOLL(I) = ATOL(I) + END DO + +C THE ABOVE VALUES HAD TO BE ESTABLISHED SINCE THE SAME VARIABLES +C CANNOT BE IN COMMON STATEMENTS IF THEY ARE DUMMY CALLING ARGUMENTS. + + + + +C NOTE THAT THIS SUBROUTINE WAS CALLED BY BESTDOSxxx.FOR/MAIN, WHICH +C HAS ALREADY WRITTEN TO SCRATCH FILE 27 THE DATA FROM THE SINGLE +C SUBJECT WHOSE POSTERIOR DENSTIY IS TO BE CALCULATED, BASED ON THE +C PRIOR DENSITY INPUT PASSED TO THIS ROUTINE IN CORDEN. + + +c As of npageng14.f, tol is hardcoded to be 1.D-4. Previously, it +c was allowed to be any positive number .GE. 1.D-4. + + tol = 1.D-4 + + +C ESTABLISH ASSAY VALUES FROM ierrmod AND gamlam0. + + + gamma = 1.d0 + flat = 1.d0 + if(ierrmod .eq. 2) gamma = gamlam0 + if(ierrmod .eq. 3) gamma = gamlam0 + if(ierrmod .eq. 4) flat = gamlam0 + + igamma = 0 + gamdel=0.1 + if(ierrmod.eq.1) gamdel=0.d0 + + +C CHANGE NGRID TO BE MAXGRD, IF IT IS > MAXGRD. + +C???DEBUG 3/23. NGRID IS NOT A DIMENSION --> IT IS NEEDED TO BE +C WHATEVER IT IS FROM THE NPAGDENFILE INPUT INTO THE BESTDOS MAIN +C MODULE. SO DON'T LIMIT IT TO BE .LE. MAXGRD. + +C if(ngrid .gt. MAXGRD) then + +C write(6,*) + +C write(6,*) 'requested NGRID = ',NGRID +C write(6,*) 'maximum allowable is MAXGRD = ',MAXGRD +C write(6,*) 'resetting NGRID = ',MAXGRD +C write(6,*) 'to fit in available storage' +C write(6,*) + +C ngrid = MAXGRD + +C endif + + + +C CALCULATE VOLSPA, THE 'VOLUME' OF THE INTEGRATION SPACE (NEEDED IN +C CALLS TO NOTINT). + + VOLSPA=1.D0 + DO 170 I=1,NVAR + 170 VOLSPA = VOLSPA*(AB(I,2)-AB(I,1)) + + +C NOTE IN THIS PROGRAM, THE USER WILL ALWAYS INPUT A PRIOR DENSITY +C WITH VALUES IN CORDEN, SO THE ICYCLE = 0 CODE HAS BEEN REMOVED. + + +C AS OF npageng19.f, PRESET NACTLAST TO BE NACTVE. THIS WAY, IN THE +C UNLIKELY EVENT THAT THE FIRST CYCLE OF A RUN HAS A HESSIAN ERROR +C (WHICH MEANS THAT WHEN CONTROL COMES BACK TO MAIN FROM SUBROUTINE +C emint, IT IS TRANSFERRED TO LABEL 900 AND THEREFORE SKIPS THE +C cbegin statistics SECTION WHERE NACTLAST = NACTVE IS SET), THERE +C WON'T BE A PROBLEM WHEN NACTVE IS SET = NACTLAST JUST BELOW LABEL +C 900. IN PREVIOUS PROGRAMS, IN THE ABOVE SITUATION, BELOW LABEL 900, +C NACTVE = NACTLAST WOULD RESULT IN NACTVE BEING SET = 0 SINCE +C NACTLAST WAS UNITIALIZED. + + NACTLAST = NACTVE + + + prefobj=-1.d30 + prebig=-1.d30 + + +C SET ICYCLE = 0. THE PROGRAM WILL RUN UP TO MAXCYC CYCLES. + + ICYCLE = 0 + +C CORDEN HOLDS, IN ITS FIRST NACTVE ROWS, THE STARTING JOINT DENSITY +C AND COORDINATE VALUES. FOR K=1,NACTVE, CORDEN(K,J) = JTH COORDINATE +C OF THE KTH ACTIVE POINT, J=1,NVAR; AND CORDEN(K,NVAR+1) IS THE +C ASSOCIATED DENSITY FOR THE KTH ACTIVE POINT. + +C IF ICYCLE .GT. 0, CORDEN WAS READ IN. +C IF ICYCLE = 0, NACTVE=NGRID, AND CORDEN WAS FILLED AT LABEL 30 ABOVE. +C IN THIS CASE, THE DENSITY IS UNIFORM, SO ALL +C CORDEN(K,NVAR+1) VALUES = 1/VOLSPA, K=1,NACTVE. + + +C IPRED=11 + ICYCLE +C JCOL=0 + ITEST=0 + +C IPRED IS THE CYCLE NO. WHERE THE NEXT 2-CYCLE PREDICTION +C ALGORITHM STARTS (IT IS NO LONGER USED). JCOL = COLUMN NO. OF DENSTOR +C IN WHICH IS STORED THE DENSITY OF ONE OF THE 2-CYCLES USED IN THE +C PREDICTION (IT IS NO LONGER USED). IT IS SET = 0 ABOVE, SINCE NO +C STORAGE IS REQUIRED UNTIL CYCLE NO. 11 + + +C (SEE BELOW). ITEST=0 --> THE NEXT CYCLE IS NOT (INITIALIZED) TO BE +C A TEST CYCLE (SEE CODE BELOW WHEN ITEST=1,2, OR 3). + +C NEW FOR m2_13cal.f: NSTORE SET = 0. NSTORE IS THE NO. OF GRID +C POINTS, WHOSE P(YJ|X) VALUES HAVE BEEN STORED IN PYJGX IN LOOP 800. +C THIS NO. CAN BE CHANGED BY THE 'CONDENSING' CODE BELOW, SINCE +C INACTIVE POINTS ARE THROWN OUT. + + NSTORE=0 +cadapt initialize grid resoution to 20% + resolve=0.20 + + + + + 1001 ICYCLE=ICYCLE+1 + + +cgam3 +10001 continue +c above is new entry point for gammaplus/minus eps tries + itest = 0 + + +cadapt reset number of stored points to that before expansion +c nstore=nstoresv + + +C 1239 FORMAT(///' CYCLE NO.',I5,/) + +C ICYCLE IS THE NUMBER OF THE NEXT CYCLE TO BE RUN. +C +C THIS IS WHERE EACH NEW CYCLE STARTS (FOR EACH CYCLE, THE DENSITY OF +C X IS UPDATED FROM THE PREVIOUS DENSITY ESTIMATE, USING THE +C OBSERVED SUBJECT DATA FROM THE INPUT DATA FILES WHICH ARE PASSED TO +C SUBROUTINE IDPC BELOW. +C + + +C START THE SUBJECT LOOP. + + +C REWIND SCRATCH FILE 27 WHICH HAS ALL THE SUBJECT DATA FILES +C CONCATENATED ON IT, IN ORDER. ACTUALLY THERE IS ONLY NSUB = 1 +C SUBJECT IN THIS RUN. + + REWIND(27) + +C PUT THE SUBJECT'S DATA ONTO FILE 37 BY CALLING SUBROUTINE NEWWORK1 +C (SIMILAR ROUTINE TO THE ONE IN npageng25.f, EXCEPT IT READS FILE 27 +C AND WRITES TO FILE 37, RATHER THAN READING FROM FILE 23 AND WRITING +C TO FILE 27). NOTE THAT IT HAS NO ARGUMENTS; NONE ARE NEEDED IN THIS +C PROGRAM. + +C NOTE THAT IF THE SUBJECT FILE HAS NO STEADY STATE DOSE INDICATORS, IT +C WILL NOT BE CHANGED; IF IT DOES, IT WILL BE ALTERED TO INCLUDE AN +C EXTRA 100 DOSES SETS FOR EACH STEADY STATE DOSE INDICATOR. NOTE THAT +C SUBROUTINE NEWWORK1 WILL LEAVE IN THE NEGATIVE DOSE TIME (WHICH IS +C THE STEADY STATE DOSE INDICATOR) BECAUSE THE ID ROUTINES NEED TO SEE +C THIS INDICATOR TO KNOW THAT A STEADY STATE DOSE SET IS COMING. + + OPEN(37) + + + CALL NEWWORK1 + REWIND(37) + + + + +C NOBTOT WILL BE THE RUNNING TOTAL OF ALL NON-MISSING OBSERVED VALUES +C OVER ALL THE NSUB SUBJECTS. THIS IS NEEDED TO CALCULATE BIC BELOW. + + NOBTOT = 0 + + + DO 1000 JSUB=1,NSUB + + +C CALL SUBROUTINE FILREAD TO READ, FOR THIS SUBJECT, FROM SCRATCH FILE +C 37, THE NO. OF OBSERVATION TIMES (NOBSER) AS WELL AS THE +C OBSERVED VALUES THEMSELVES: YO(I,J) = THE 'NOISY' OBSERVED VALUES +C FOR THIS SUBJECT; I=1,NOBSER, J=1,NUMEQT. THESE OBSERVED VALUES ARE +C USED ONLY TO CALCULATE THE ASSAY STANDARD DEVIATIONS (USING THE +C VECTORS, C0,C1,C2,C3, WHICH ARE ALSO READ IN). THE REST OF THE INFO +C IN THE SUBJECT DATA FILE IS PASSED IN COMMONS TO THE IDPC MODULE +C SUBROUTINES. + + CALL FILREAD(NOBSER,YO,C0,C1,C2,C3) + +C FIND THE ASSAY STANDARD DEVIATIONS FOR THIS SUBJECT. FOR EACH +C OF THE NOBSER*NUMEQT OBSERVED VALUES (EXCEPT THAT YO(I,J) = -99 --> +C OUTPUT EQ. J HAS NO OBSERVED LEVEL FOR OBSERVATION TIME I), +C Y, SIG = C0 + C1*Y + C2*Y**2 + C3*Y**3. +C NOTE THAT, THEORETICALLY, SIG SHOULD BE A CUBIC FNT. OF +C THE 'TRUE' OBSERVED VALUES, NOT THE 'NOISY' OBSERVED VALUES (BUT THE +C 'TRUE' VALUES ARE UNKNOWN). + +C ALSO, CALCULATE SIGFAC, THE PRODUCT OF THE NON-MISSING STD. DEV.'S +C (A NON-MISSING S.D. IS ONE FOR WHICH THE CORRESPONDING YO(I,J) IS +C .NE. -99, THE MISSING VALUE CODE). +C INITIALIZE SIGFAC=1, AND THEN UPDATE IT FOR EACH NON-MISSING +C OBSERVATION. + +C MISVAL WILL BE THE RUNNING TOTAL OF MISSING VALUES AMONG ALL THE +C NUMEQT x NOBSER POTENTIAL OBSERVED LEVELS. + + MISVAL = 0 + + SIGFAC=1.D0 + + DO 140 I=1,NOBSER + DO 140 J=1,NUMEQT + + Y = YO(I,J) + +C IF Y = -99, IT MEANS THAT OUTPUT EQ. J HAD NO VALUE AT OBSERVATION +C TIME I. IN THIS CASE, IGNORE THIS Y AND INCREASE MISVAL BY 1. + + + IF(Y .EQ. -99) THEN + MISVAL = MISVAL+1 + GO TO 140 + ENDIF + +C NOTE: FOR EACH SUBJECT, MUST ENSURE THAT ALL THE STD DEV'S ARE NON- +C ZERO. OTHERWISE, THE PROGRAM WILL BLOW UP! THIS IS BECAUSE +C P(YJ|X) INVOLVES SQUARED DIFFERNCES BETWEEN OBSERVED Y'S AND +C EXPECTED Y'S (FOR EACH X GRID POINT)...EACH DIFFERENCE +C NORMALIZED (I.E., DIVIDED) BY THE VARIANCE OF THE RESPECTED +C OBSERSATION. + +C SEE M2_17CAL.F CODE FOR COMMENTS ON HOW A STD. DEV. COULD = 0. + +C ALSO TEST TO MAKE SURE NO STD. DEV. < 0, SINCE SIGFAC BEING NEGATIVE +C WOULD RESULT IN A NEGATIVE PROBABILITY (SEE PYJGX CALCULATION BELOW). + + SIG(I,J) = C0(J)+C1(J)*Y+C2(J)*Y*Y+C3(J)*Y**3 +cgam4 + if(ierrmod.eq.2) sig(i,j) = sig(i,j)*gamma + if(ierrmod.eq.3) sig(i,j)=dsqrt(sig(i,j)**2 + gamma**2) + if(ierrmod.eq.4) sig(i,j) = gamma*flat + + IF(SIG(I,J) .EQ. 0) THEN + + WRITE(*,2345) JSUB +2345 FORMAT(//' A S.D. IS 0 FOR JSUB = ',I5,'. RERUN THE '/ + 1' PROGRAM WITH C0 NOT = 0 FOR THIS SUBJECT, OR WITH THIS'/ + 2' SUBJECT ELIMINATED.'// + 3' THIS IS IN SUBROUTINE NPAGFULL11.'/) + CLOSE(37) + + OPEN(47,FILE=ERRFIL) + WRITE(47,2345) JSUB + CLOSE(47) + + + CALL PAUSE + STOP + + ENDIF + + IF(SIG(I,J) .LT. 0) THEN + + WRITE(*,2346) JSUB +2346 FORMAT(//' A S.D. < 0 FOR JSUB = ',I5,'. RERUN THE '/ + 1' PROGRAM WITH A BETTER CHOICE FOR THE ASSAY ERROR POLYNOMIAL'/ + 2' COEFFICIENTS.'// + 3' THIS IS IN SUBROUTINE NPAGFULL11.'/) + CLOSE(37) + + OPEN(47,FILE=ERRFIL) + WRITE(47,2346) JSUB + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + SIGFAC=SIGFAC*SIG(I,J) + + 140 CONTINUE + +C NOTE THAT SIGFAC WAS CALCULATED IN LOOP 140 ABOVE, AND THAT OFAC IS +C NOW THE RESULT OF (NOBSER*NUMEQT - MISVAL) VALUES. + + OFAC=2.506628274631**(NOBSER*NUMEQT - MISVAL) + NOBTOT = NOBTOT + NOBSER*NUMEQT - MISVAL + + +C NOTE THAT 2.5066... = SQRT(2*PI). + +C FOR EACH SUBJECT, AND EACH GRID POINT, CALL IDPC, A SUBROUTINIZED +C VERSION OF THE ADAPT PROGRAM ID3 TO CALCULATE THE SUM OF SQUARES OF +C DIFFERENCES BETWEEN THE OBSERVED VALUES AND PREDICTED (BY THE MODEL) +C VALUES (NORMALIZED BY THE ASSAY VARIANCE OF EACH OBSERVATION) ... + + 8888 FORMAT(' ',' CYCLE ',I5,', SUBJECT ',I5,' ... % COMPLETED = ', + 1F8.2) + XNEXT = 1.D0 + +C SEVERAL CHANGES FOR m2_13cal.f ARE IN LOOP 800. + + DO 800 IG=1,NACTVE + + +C PRINT TO THE SCREEN THE UPDATE ON WHAT % OF GRID POINTS HAVE BEEN +C CALCULATED IF NACTVE > NSTORE (I.E., IF NACTVE .LE. NSTORE --> +C ALL P(YJ|X)'s ARE ALREADY STORED INTO PYJGX AND SO THIS 8OO LOOP +C WILL GO VERY FAST. + + IF(NACTVE .GT. NSTORE) THEN + +C PRINT GRID PT. AND % COMPLETED TO SCREEN. + XPER=IG*100.D0/NACTVE + + IF(XPER .GE. XNEXT) THEN + + IF(ICYCLE.eq.1) THEN + WRITE(*,8888) ICYCLE,JSUB,XPER + IF(NXE .GT. 0) WRITE(*,1254) NXE + 1254 FORMAT(' TOTAL NO. OF NUM. INTEG. WARNINGS IS ',I20) + ENDIF + + XNEXT=XNEXT+1.D0 + + ENDIF + + ENDIF + + IF(IG .LE. NSTORE) GO TO 700 + + +C ESTABLISH THE IGTH GRID POINT. IT IS STORED IN ROW IG OF +C CORDEN. + + DO J=1,NVAR + X(J)=CORDEN(IG,J) + END DO + +C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO +C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL +C MAKEVEC TO DO THIS. + + + CALL MAKEVEC(NVAR,NOFIX,IRAN,X,VALFIX,PX) + + CALL IDPC(PX,W) + +C W RETURNS AS THE SUM OF: +C ((YO(I,J)-H(I,J))/SIG(I,J))**2, WHERE H(I,J) = PREDICTED VALUE OF THE +C JTH OUTPUT EQ AT THE ITH OBSERVATION TIME, ASSUMING THE IGTH GRID +C POINT, X, ... OVER THE NOBSER x NUMEQT QUANTITIES ABOVE WHICH DON'T +C HAVE YO(I,J) = -99 (WHICH MEANS THAT OUTPUT EQ. J HAS NO OBSERVED +C LEVEL FOR TIME I). + +C CALCULATE P(YJ|X) FOR X-GRID POINT NO. IG. + +C THIS NEXT TEST IS FOR THE PC. AS AN EXAMPLE, THE COMPAC COMPUTER +C CANNOT HANDLE ARGUMENTS TO DEXP WHICH ARE SMALLER THAN -11354. SINCE +C THE ARGUMENT TO DEXP BELOW IS -.5*W, SET PYJGX = 0 IF W IS .GT. +C 22708. + +C SEE CODE AFTER CALCULATION OF P(YJ) TO SEE WHAT HAPPENS IF ALL THE +C P(YJ|X) ARE SET = 0. + +C NOTE THAT WORKK WILL ALWAYS BE SET = P(YJ|X=IG GRID PT), WHICH IS +C NEEDED IN THE CALCULATION OF DXI (NOTE DXI NOT USED AS OF +C bignpaglap1.f) SINCE PYJGX WILL NOT BE COMPLETE IF NACTVE > MAXGRD. + + IF(IG .LE. MAXGRD) PYJGX(JSUB,IG)=0.D0 + WORKK(IG) = 0.D0 + + IF(W .LE. 22708.D0) THEN + IF(IG .LE. MAXGRD) PYJGX(JSUB,IG) = DEXP(-.5D0*W)/SIGFAC/OFAC + WORKK(IG) = DEXP(-.5D0*W)/SIGFAC/OFAC + ENDIF + +C CALCULATE P(X,YJ) FOR X-GRID POINT NO. IG. PUT IT INTO WORK(IG). + + IF(IG .GT. MAXGRD) THEN + WORK(IG) = WORKK(IG)*CORDEN(IG,NVAR+1) + GO TO 800 + ENDIF + + 700 WORK(IG)=PYJGX(JSUB,IG)*CORDEN(IG,NVAR+1) + + WORKK(IG) = PYJGX(JSUB,IG) + +C???DEBUG +C WRITE(*,3631) ICYCLE,IG,PYJGX(JSUB,IG) +C 3631 FORMAT(' ICYCLE,IG,PYJGX(JSUB,IG): ',I3,2X,I2,2X,F20.15) + + 800 CONTINUE + +C???DEBUG +C CALL PAUSE + + +C CALCULATE P(YJ), A SCALAR WHICH IS THE INTEGRAL OF P(X,YJ) OVER + +C X-SPACE. + +C CALL NOTINT, AN INTEGRATION ROUTINE. THE +C FOLLOWING IS SUPPLIED TO THIS ROUTINE: +C VOLSPA = VOLUMNE OF THE INTEGRATION SPACE. +C NGRID = NO. OF ORIGINAL GRID POINTS. +C NACTVE = NO. OF ACTIVE GRID POINTS. +C WORK(I), I=1,NACTVE = VALUE OF THE FUNCTION TO BE INTEGRATED, AT +C THE ITH GRID POINT. +C MAXGRD = THE DIMENSION OF WORK. + + CALL NOTINT(VOLSPA,NGRID,NACTVE,WORK,MAXGRD,PYJ) + + +C IF PYJ RETURNS AS 0, IT IS BECAUSE P(X,YJ)=WORK IS 0 IN ALL ITS +C NACTVE ENTRIES. THIS OCCURS WHEN EACH OF NACTVE VALUES OF W (WHICH +C RETURNS FROM THE CALLS TO IDPC) IS LARGER THAN 1416 (SINCE P(YJ|X) +C INVOLVES e RAISED TO THE POWER -.5*W, AND e RAISED TO A POWER +C SMALLER THAN -708 IS SET TO 0 BY, FOR EXAMPLE, THE COMPAC COMPUTER). +C + +C IN CASE THIS HAPPENS, PRINT A MESSAGE TO THE USER AND STOP. +C + IF (PYJ .EQ. 0.D0) THEN + + WRITE(*,26) + 26 FORMAT(//' FOR THIS SUBJECT, THE PROB. OF THE OBSERVED'/ + 1' CONCENTRATIONS (FOR THE INDICATED DOSAGE REGIMEN), GIVEN EACH '/ + 2' AND EVERY GRID POINT IN THE ESTABLISHED GRID, IS 0. THE '/ + 3' PROGRAM STOPS. THE USER SHOULD CONSIDER INCREASING THE'/ + 4' NO. OF GRID POINTS ALLOWED (HARDCODED INTO MAIN), AND/OR '/ + 5' NARROWING THE GRID BOUNDARIES OF THE VARIABLES, AND/OR '/ + 6' INCREASING THE SIZES OF (C0,C1,C2,C3), THE ASSAY NOISE '/ + 7' COEFFICIENTS. ALL OF THESE CHANGES WILL HAVE THE EFFECT OF'/ + 8' MAKING SOME OF THE ABOVE CONDITIONAL PROBABILITES LARGER.'// + 9' THIS IS IN SUBROUTINE NPAGFUL.'/) + + OPEN(47,FILE=ERRFIL) + WRITE(47,26) + CLOSE(47) + + CALL PAUSE + STOP + + ENDIF + + +C??? FOR NPAGFULL1.FOR, IF MAXCYC = 0, GO TO LABEL 900, WHERE +C THE CODE WILL BE TO FINISH CALCULATING THE SIMPLE BAYESIAN +C POSTERIOR FOR THIS SUBJECT, BASED ON THE ABOVE NACTVE GRID PTS. + + IF(MAXCYC .EQ. 0) GO TO 900 + + + + 1000 CONTINUE + + +c begin optimization +cgam5 +cgam5 - from here (immediately after 1000 CONTINUE to +cgam5 - immediately before c end optimization was lifted +cgam5 - from gamadapt1.f, replacing old material beteen these limits + igamma = igamma + 1 + if(ierrmod.eq.1) igamma=1 +csdsc - added April 2, 2000 +c con first iteration, call hte interior point method + + if(mod(igamma,3).eq.1) then + + gammab = gamma + gammap = gamma * (1.d0+gamdel) + gammam = gamma / (1.d0+gamdel) + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,1, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + + nactve = keep + +C???DEBUG +C WRITE(*,*)' AFTER CALL EMINT, NO. 1, NACTVE = KEEP = ',NACTVE + + + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + +C???DEBUG +C WRITE(*,*)' AFTER CALL EMINT, NO. 2, NACTVE = ',NACTVE + + + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. + +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + + + fobjbase = fobj + + + nactve0 = nactve +c new on Jan 2, 2002 - save otpimal solution in denstor(1,4) +c so that stat program can work on best of base, up, and down +c solutions + do i=1,nactve + denstor(i,4)=corden(i,nvar+1) + enddo + nstore = 0 + fobjbest = fobjbase + + if(ierrmod.eq.1) go to 14001 + gamma = gammap + go to 10001 + + endif +cgamma above endif is for mod(igamma,3).eq.1 case + + if(mod(igamma,3).eq.2) then + + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + +C???DEBUG +C WRITE(*,*)' AFTER CALL EMINT, NO. 3, NACTVE = ',NACTVE + + + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + fobjplus = fobj + +c new Jan 2, 2002 - save solution if fobjplus is better than fobjbase + if(fobjplus.gt.fobjbest) then + fobjbest = fobjplus + do i=1,nactve + + denstor(i,4) = corden(i,nvar+1) + enddo + endif + gamma = gammam + + go to 10001 + + endif + + if(mod(igamma,3).eq.0) then + + call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, + &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), + &fobj,gap,nvar,keep,IHESS) + +C???DEBUG +C WRITE(*,*)' AFTER CALL EMINT, NO. 4, NACTVE = ',NACTVE + + + + +C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. + +C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR +C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO +C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE +C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT +C WAS FROM THE PREVIOUS CYCLE. + + IF(IHESS .EQ. -1) GO TO 900 + + fobjminu = fobj + + if(fobjminu.gt.fobjbest) then + fobjbest = fobjminu + do i=1,nactve + denstor(i,4) = corden(i,nvar+1) + enddo + endif + + endif + +cgamma - above statement changed from "nstore = nactve" to force +c reevaluation of all points. + +c now temporairily reset to gamma + gamma = gammab + fobj = fobjbase + if(fobjplus.gt.fobjbase) then + gamma = gammap + + fobj = fobjplus + gamdel = 4.*gamdel + endif + + if(fobjminu.gt.fobjbase) then + gamma = gammam + fobj = fobjminu + gamdel = 4.*gamdel + endif + gamdel = gamdel*0.5 + if(gamdel.lt.0.01) gamdel=0.01 +14001 continue +cgam5 above label is entry point for ierrmod = 1 (no gamma) case + +c corden(*,nvar+1) sums to 1 when it comes out of emint +c Now reset forden(i,nvar+1) to best of three solutions +c and normalize to funny BIGNPEM factor + fact=ngrid/volspa + do i=1,nactve + corden(i,nvar+1)=fact*denstor(i,4) + enddo + +C???DEBUG +C WRITE(*,*)' AT END OF OPTIMIZATION, NACTVE = ',NACTVE +C CALL PAUSE + + +cend optimization + + +cbegin statistics + + +c now we compute all hte statistical stuff using this distribution +c and the full nactve (before condensation) points. +c Later, in the condensation performed just before the grid refienment +c and subsequent expansion, we will condense by just using the +c 'keep' flags in DENSTOR(i,1) that emint left there. The density will +c not be updated to refelct this cahnge (there is no need) +c until the next call to emint + + +c As of npageng18.f, save CORDEN to CORDLAST AND NACTVE TO NACTLAST. +c The reason is that if, somewhere during the next cycle's calculations +c (during one of the calls to Subroutine emint), a Hessian Matrix is +c singular, then IHESS will be set = -1, and the program will stop. +c And in this case, the program must be able to write out all of the + +c information from this cycle (the last completed cycle). And that +c means that the CORDEN from this cycle (which will be stored into +c CORDLAST), and NACTVE (store into NACTLAST) should be used in the +c call to Subroutine SUBRES in loop 7000. Otherwise, the CORDEN and +c NACTVE used in that call would have already partly updated in the +c next cycle before the Hessian error occurred. + + DO I = 1,NACTVE + DO J = 1,NVAR+1 + CORDLAST(I,J) = CORDEN(I,J) + END DO + END DO + +C???DEBUG +C WRITE(*,*)' CORDEN IS NOW ' +C DO I = 1,NACTVE +C WRITE(*,5497) (CORDEN(I,J),J=1,3) +C 5497 FORMAT(3(F12.8,2X)) +C END DO +C CALL PAUSE + + NACTLAST = NACTVE + + + IF(MAXCYC .EQ. 0) GO TO 900 + +C Starting with bigmlt1.f, this is a jump point. + + +cend statistics +cbegin control +c we are now done wtih statistics - this is the best place to +c check for whether we can exit - if so , last printed statistic +c will agree with current density corden, and corden is still +c correct (e.g. after condensation-expansion, it is no longer +c correct until we call emint again) +cint.9 control section to check for exit criteria, resolution +c refinement, and end of major cycles + +cint9.a first, we exit if we have reached maxcyc on cycle counter + +C SET IMAXCYC = 0; IF IT CHANGES TO 1, IT MEANS THAT MAXCYC CYCLES +C HAVE BEEN RUN, AND THE PROGRAM WILL STOP. + + IMAXCYC = 0 + + if(icycle .ge. maxcyc) then + + + +C SET IMAXCYC = 1 --> MAXCYC WAS REACHED. + + IMAXCYC = 1 + +C COMMENT OUT THE GO TO 900 STATEMENT BELOW SINCE EVEN IF ICYCLE +C = MAXCYC, THE PROGRAM STILL NEEDS TO TEST TO SEE IF CONVERGENCE +C WAS ACHIEVED IN THE FINAL CYCLE. +C go to 900 + + endif + +c The above endif is for the if(icycle .ge. maxcyc) condition. + + +cint9.b second, we check improvement from last cycle + + ximprove=fobj-prefobj + prefobj = fobj + +cint9.c if ximprove is too low, refine the resolve criterion + + if(dabs(ximprove) .le. tol .and. resolve .gt. 0.0001) then + resolve=resolve*0.5 + endif + +cint9.d check to see if resolve bottoms out - if so, start a new +c major cycle by resetting it to its highest allowable value, or +c exit if the improvment from the last major cycle is too small ... + +C AND EXIT IF IMAXCYC = 1 (SEE ABOVE; THIS MEANS THAT THE MAX. NO. +C OF CYCLES HAS ALREADY BEEN RUN AND THE ONLY REASON THIS PART OF THE +C CODE IS BEING RUN IS TO SEE IF CONVERGENCE WAS ACHIEVED IN THE FINAL +C CYCLE. + + if(resolve.le.0.0001) then + + +c saveres = resolve + resolve=0.2 + checkbig = fobj - prebig + prebig =fobj + +C NOTE THAT THE +C CONVERGENCE CRITERION IS THAT DABS(CHECKBIG) .LE. .01. + + +C WRITE(*,1023) ICYCLE +C1023 FORMAT(/' FOR CYCLE NO, ',I6,' THE CONVERGENCE CRITERION AND ME +C 1DIANS ARE: ') + +C WRITE(*,1024) DABS(checkbig) + +C1024 FORMAT(1X,G14.4,' <-- CONVERGENCE OCCURS WHEN THIS NO. < .01') + + + if(dabs(checkbig) .le. 0.01) then + +C CONVERGENCE HAS BEEN ACHIEVED. + + + go to 900 + + endif + + endif + +c above endif is for the if(resolve .le. .0001) condition. + + +C IF IMAXCYC = 1, THE MAX. NO. OF CYCLES HAVE ALREADY BEEN RUN --> +C GO TO 900. THE ONLY REASON THIS PART OF THE CODE WAS BEING RUN IS TO +C SEE IF CONVERGENCE WAS ACHIEVED IN THIS FINAL CYCLE, AND THAT WAS +C JUST TESTED ABOVE. + + IF(IMAXCYC .EQ. 1) GO TO 900 + + +cend control +cbegin expansion + + nactveold=nactve + + do ipoint=1,nactveold +c first, divide current probability into 2*nvar+1 pieces + pcur=corden(ipoint,nvar+1)/(2*nvar+1) +c update original point + corden(ipoint,nvar+1)=pcur + do ivar=1,nvar + del=(ab(ivar,2)-ab(ivar,1))*resolve +c create first new trial point at -eps in coordinate ivar + do i=1,nvar + corden(nactve+1,i)=corden(ipoint,i) + enddo + corden(nactve+1,ivar)=corden(nactve+1,ivar)-del + corden(nactve+1,nvar+1)=pcur + ntry=nactve+1 +c icheck that new point is at least minimally distant from old points + + call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) +c only keep trial lower point if it lies above lower bound and satisfies +c minimal distance requirement + if(corden(nactve+1,ivar).ge.ab(ivar,1)) then + if(iclose.eq.0) nactve=nactve+1 + endif +c now create second trail point at +eps in coordinate ivar + do i=1,nvar + corden(nactve+1,i)=corden(ipoint,i) + enddo + corden(nactve+1,ivar)=corden(nactve+1,ivar)+del + corden(nactve+1,nvar+1)=pcur +c only keep upper point if it lies below upper bound and +c satisfies distance requirement + ntry=nactve+1 + call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) + if(corden(nactve+1,ivar).le.ab(ivar,2)) then + if(iclose.eq.0) nactve=nactve+1 + endif + enddo +c above enddo for loop over ivar=1,nvar + + enddo +c above enddo for loop over ipoint=1,nactveold + + +cend expansion +c go to begin new cycle + + prefobj=fobj + + + + GO TO 1001 + + 900 continue + + +C??? NEW CODE BELOW FOR NPAGFULL1.FOR. + IF(MAXCYC .EQ. 0) THEN + +C NOTE THAT IF MAXCYC = 0, CONTROL HAS BEEN TRANSFERRED HERE AFTER +C LOOP 800 ABOVE. SO FINISH CALCULATING THE BAYESIAN POSTERIOR. + +C THE BAYESIAN POSTERIOR DENSITY OF THIS SUBJECT IS, FOR GRID PT. IG, + +C P(XIG|YJ) = P(YJ,XIG)/P(YJ). PUT THESE VALUES INTO CORDEN(IG,NVAR+1). + + DO IG=1,NACTVE + CORDEN(IG,NVAR+1) = WORK(IG)/PYJ + END DO + +C FOR NPAGFULL11.FOR, THE 1.D-10 BELOW IS CHANGED TO 1.D-100. + +C CALCULATE HOW MANY OF THE NACTVE GRID POINTS FROM THE FINAL CYCLE +C ARE "ACTIVE" (WITHIN 1.D-10 OF THE MAXIMUM DENSITY FOR THIS SUBJECT). +C ... AND, AS OF npageng23.f, ELIMINATE NON-SIGNIFICANT GRID PTS. IN +C CORDEN (PREVIOUSLY ALL THE POINT FROM THE FINAL CYCLE DENSITY +C SHOWED UP IN CORDEN, EVEN THOSE WITH INSIGNIFICANT PROBABILITIES). +C AND NOTE THAT THE BAYESIAN POSTERIOR DENSITY FOR THIS SUBJECT +C WILL BE STORED INTO BAYPOS(JSUB,.,.), AND PASSED IN COMMON/BAY +C TO SUBROUTINE READOUT. AND NACTSUB(JSUB) WILL CONTAIN THE NO. OF +C ACTIVE GRID POINTS FOR THIS SUBJECT'S BAYESIAN POSTERIOR DENSITY. + +C AND NOTE THAT THE NOMINAL DIMENSIONS OF BAYPOS, (800,1500,31), +C CANNOT BE EXCEEDED BECAUSE THESE ARE THE VALUES FOR MAXSUB, MAXGRD, +C AND MAXDIM+1, AS SPECIFIED IN THE PARAMETER STATEMENT IN THE PC PREP +C MAIN MODULE (CURRENTLY NPAG111.FOR). BUT NOTE THAT npageng23.f WILL +C NOT EXECTUTE WITH THESE DIMENSIONS BECAUSE IT IS TOO BIG FOR A +C WIN32 APPLICATION (SEE NPAG111.EXP). SO, IN THIS ROUTINE, AND IN +C SUBROUTINE READOUT (IN read19.f), THE FIRST DIMENSION HAS BEEN +C REDUCED TO 100 (AND SIMILARLY FOR THE DIMENSION OF NACTSUB). IF +C JSUB > 100, THE BAYESIAN POSTERIOR VALUES BELOW WILL NOT BE STORED. + + DENMAX=CORDEN(1,NVAR+1) + + DO I=1,NACTVE + D=CORDEN(I,NVAR+1) + IF(D .GT. DENMAX) DENMAX=D + END DO + + SUMD = 0.D0 + NEWIND = 0 + + DO I=1,NACTVE + D=CORDEN(I,NVAR+1) + IF(D .GT. 1.D-100*DENMAX) THEN + SUMD=SUMD+D + NEWIND=NEWIND+1 + DO J=1,NVAR + CORDEN(NEWIND,J) = CORDEN(I,J) + END DO + CORDEN(NEWIND,NVAR+1)=D + ENDIF + END DO + + NACTVE = NEWIND + + FACT = NGRID/VOLSPA/SUMD + + DO I=1,NACTVE + CORDEN(I,NVAR+1) = CORDEN(I,NVAR+1)*FACT + END DO + + + ENDIF +C THE ABOVE ENDIF IS FOR THE IF(MAXCYC .EQ. 0) CONDITION. + + + +C AS OF npageng18.f, CONTROL CAN BE TRANSFERRED TO LABEL 900 DIRECTLY +C AFTER RETURNING FROM A CALL TO SUBROUTINE emint. THIS HAPPENS WHEN +C IHESS = -1, WHICH MEANS THAT THE HESSIAN MATRIX IN THE INTERIOR +C POINT EM ALGORITHM WAS SINGULAR. RATHER THAN SIMPLY STOPPING AS IT +C DID PREVIOUSLY, NOW THE PROGRAM WILL CREATE THE OUTPUT FILES BEFORE +C STOPPING ... BASED ON THE VALUES FROM THE PREVIOUS CYCLE. +C FIRST, WRITE THE REASON FOR STOPPING AS ICONVERGE = 3 BELOW. THEN +C RESET CORDEN BACK TO CORDLAST (SEE ABOVE), WHICH WAS THE CORDEN +C AT THE END OF THE PREVIOUS CYCLE. +C FOR NPAGFULL, OF COURSE, NO WRITING OCCURS TO OUTPUT FILES. + + +C WRITE WHY THE PROGRAM STOPPED. + + IF(IHESS .EQ. -1) THEN + + NACTVE = NACTLAST + + DO I = 1,NACTVE + DO J = 1,NVAR+1 + CORDEN(I,J) = CORDLAST(I,J) + END DO + END DO + + GO TO 910 + + ENDIF + + +C Starting with bigmlt1.f, this is an entry point to continue +c calculations + + + 910 CONTINUE + +cbegin endgame +c we can only arrive here from the control section, which menas +c that we ahve completed optimizaiton but not done the subsequent +c expansion. This means that the density is correct, and we can safely +c just write it out and exit. + + WRITE(*,1294) ICYCLE,MAXCYC + 1294 FORMAT(/' NPAG RAN ',I6,' OUT OF A MAXIMUM POSSIBLE ',I6/ + 1' CYCLES TO OBTAIN THE POSTERIOR DENSITY.') + +C FOR NPAGFULL, THE DENSITY IS CORRECT AT THIS POINT. SO RETURN TO +C THE BESTDOSxxx PROGRAM. + +C AS OF NPAGFULLA11.FOR, CLOSE FILE 37. + + CLOSE(37) + + + + + RETURN + END + + +c shift9.f 9/28/12 + +c shift9 has the following subtle change from shift8: + +c In step 4, the logic to assign the bolus time, BOL(I,IND,1) is +c simplified in the case where a steady state dose set begins as a +c time reset event. In this case, the bolus time will be TAU(I) only +c if both TAU(I) and the bolus value (RR) are not 0. See the reason +c in the code. + +c----------------------------------------------------------------------- + +c shift8.f 9/20/12 + +c shift8 has changes from shift7 in Step 4 to correct the code in the +c case where bolus inputs are used in steady state dose sets. In +c shift7.f, a timelag for a bolus which was part of a steady state +c dose set would not be applied properly. Now it will. + +c----------------------------------------------------------------------- + +c shift7.f 11/6/11 + +c shift7 differs from shift6 as follows: + +c 1. The dimensions related to the no. of dose events are changed from +c 500 to 5000. This is needed as shift7 is compiled with idm1x7.f, +c idm2x7.f, and idm3x7.f (part of the npageng16.f "engine"), which +c accommodates steady state dose sets. + +c 2. 3 lines testing for IF(SIG(IDOSE) .EQ. 0 .AND. IDOSE .GT. 1) +c are replaced by IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) +c since now a dose reset occurs when a dose time is 0 (a regular +c time reset) or < 0 (a time reset occurring with a steady state +c dose set indicator). + +c----------------------------------------------------------------------- + +C SHIFT6.F 4/26/11 + +C SHIFT5 HAS THE FOLLOWING CHANGES TO SHIFT5: + +C WT AND CCR ARE NO LONGER ASSUMED TO BE SPECIAL COVARIATES IN EACH +C PATIENT'S WORKING COPY PATIENT DATA FILE. SO ALL DO LOOPS THAT +C START WITH DO I = 1, 2+NADD ARE CHANGED TO START WITH DO I = 1,NADD, +C BUT ONLY IF NADD .GT. 0. + +C----------------------------------------------------------------------- + +C SHIFT5.F 9/11/09 + +C SHIFT5 HAS THE FOLLOWING CHANGES TO SHIFT4.F. + + +C THE ARGUMENT LIST CONTAINS TAU(.) RATHER THAN NTLAG(.). THIS +C MEANS THAT TAU(I) IS INPUT DIRECTLY AS THE TIMELAG FOR DRUG I. +C I.E., IT NO LONGER HAS TO BE CALCULATED AS A FUNCTION OF THE +C PARAMETER ARRAY, P. BECAUSE OF THIS, P IS REMOVED FROM THE ARGUMENT +C LIST AND THE DIMENSION STATEMENT. ALSO, NTLAG IS REMOVED FROM +C THT DIMENSION STATEMENT. + +C THE FIRST SET OF ID MODULES TO CALL SHIFT5.F ARE idm1x3.f, +C idm2x3.f, AND idm3x3.f + +C----------------------------------------------------------------------- + +C SHIFT4.FOR 9/1/09 + +C SHIFT4 HAS THE FOLLOWING CHANGES FROM SHIFT3: + +C 1. NTLAG(I) CAN NOW BE NEGATIVE. IF THIS OCCURS, IT MEANS THAT THE +C TIMELAG PARAMETER FOR DRUG I WILL BE EXP(P(-NTLAG(I)). + +C 2. A BUG IS CORRECTED RELATED TO TIME "RESETS". PREVIOUSLY, IF THE +C USER HAD A TIME "RESET" IN HIS DOSAGE REGIMEN, THIS ROUTINE WOULD +C NOT WORK. THE REASON IS THAT IN THE CODE BELOW, EACH NEXT TIME +C FOR AN IV, COVARIATE, OR BOLUS IS COMPARED TO THE PREVIOUSLY +C ESTABLISHED TIME IN THE DOSAGE ARRAY (TIMNXT) AND IS A CANDIDATE +C TO BE THE NEXT TIMNXT IF IT IS .GE. TIMNXT. SO IF A TIME RESET +C VALUE OF 0 OCCURS, IT WILL NEVER BE A CANDIATE SINCE IT IS NOT +C .GE. THE LAST TIMNXT. TO FIX THIS, AND MAKE SURE THAT A TIME +C RESET VALUE OF 0 IS INCLUDED IN THE ADJUSTED DOSAGE BLOCK, THE +C CODE WILL ADD TO EACH IV, BOLUS, AND COVARIATE ARRAY AN EXTRA +C LINE WHEN A TIME RESET OCCURS. THIS LINE WILL HAVE A TIME OF +C 1.D19 (I.E., A LARGE VALUE WHICH REPRSENTS INFINITY); AND IT +C WILL BE FOLLOWED BY A LINE WITH THE ADJUSTED RESET TIME (0 FOR +C IVs AND COVARIATES, AND 0 + TAU(I) FOR BOLI. + +C----------------------------------------------------------------------- + +C SHIFT3.FOR 5-23-02 + +C SHIFT3 HAS MAJOR CHANGES FROM SHIFT2 TO ALLOW FOR MULTIPLE TIMELAGS, +C ONE POTENTIALLY FOR EACH BOLUS INPUT OF UP TO 7 DRUGS. + + SUBROUTINE SHIFT(TAU,ND,SIG,NDRUG,NADD,RS) + IMPLICIT REAL*8(A-H,O-Z) + DIMENSION SIG(5000),RS(5000,34),TAU(7),XIV(7,5000,2), + 1 BOL(7,5000,2),COV(20,5000,2),INDIV(7),INDBOL(7),INDCOV(20), + 2 TIMCAN(34) + +C INPUT ARE: + +C TAU(I) = THE VALUE OF THE TIMELAG FOR DRUG I. +C ND = ORIGINAL NO. OF DOSE EVENTS. +C SIG(I) = TIME FOR ITH DOSE EVENT IN THE ORIGINAL DOSAGE REGIMEN, +C I=1,ND. +C NDRUG = NO. OF DRUGS (EACH HAS AN IV, FOLLOWED BY A BOLUS COLUMN). +C NADD = NO. OF ADDITIONAL COVARIATES (EACH IS IN ITS OWN COLUMN +C FOLLOWING THE IV/BOLUS COLUMNS. +C RS(I,J) = "RATE" J FOR THE ITH DOSE EVENT IN THE ORIGINAL DOSAGE +C REGIMEN; J=1,NI, I=1,ND, WHERE NI = 2*NDRUG + NADD +C BECAUSE THE "RATES" CONTAIN, IN ORDER, 2 ENTRIES FOR +C EACH DRUG (1 FOR THE IV AND 1 FOR THE BOLUS) AND 1 EACH +C FOR THE NADD ADDITIONAL COVARIATES. + + +C OUTPUT ARE: + +C ND, SIG, RS, AS ABOVE, EXCEPT FOR THE ALTERED DOSAGE REGIMEN. + +C----------------------------------------------------------------------- + +C SHIFT2.FOR 11-16-99 + +C SHIFT2 HAS THE FOLLOWING CHANGE FROM SHIFT. AT THE END OF THE +C FORMATION OF ARRAY XMAT, ALL ROWS WHICH HAVE 0 BOLUS INPUT AND THE +C SAME OTHER DATA VALUES (EXCEPT TIME) AS THE PREVIOUS ROW ARE NOT +C USED IN THE NEW ARRAY XMAT2 WHICH HAS ONLY NON-REDUNDANT ROWS. +C THIS, THEORETICALLY, SHOULDN'T HAVE ANY EFFECT ON CALCULATIONS, BUT +C NUMERICALLY IT DOES SINCE WHEN THE DVODE ROUTINE SOLVES D.E.'S, IT +C INTEGRATES OVER DIFFERENT INTERVALS IF EXTRA DOSAGE LINES ARE +C INCLUDED. + +C EX: TIME IV BOLUS TIME IV BOLUS +C 0 100 0 0 100 0 +C 5 100 1000 2 100 1000 + +C NOTE THAT BOTH ABOVE CASES SHOULD GIVE THE SAME RESULTS IF THERE IS +C A TIME-LAG = 3 IN THE 2ND CASE. BUT, AS THE CODE IS WRITTEN IN +C SHIFT.FOR, THE 2ND CASE WOULD TRANSLATE TO THE FOLLOWING: + +C TIME IV BOLUS +C 0 100 0 +C 2 100 0 +C 5 100 1000 + +C ... AND THIS WOULD MEAN THAT THE 1ST INTEGRATION BY DVODE WOULD END +C AT T = 2, RATHER THAN 5 (OR, E.G., 3 IF 3 WAS THE +C FIRST OBSERVATION TIME). THIS CREATES NUMERICAL DIFFERENCES DUE +C TO SMALL ROUNDOFF ERRORS WHICH CAN GROW SIGNIFICANTLY. + +C----------------------------------------------------------------------- + +C SHIFT.FOR 7-27-99 + +C SHIFT.FOR IS A MODULE WHICH INCLUDES SUBROUTINE SHIFT. SHIFT WILL BE +C CALLED BY ROUTINES OF THE "BIG" NPEM AND IT2B PROGRAMS WHICH HAVE +C SUBROUTINES FUNC, FUNC1, FUNC2, OR FUNC3 IN THEM. + +C SHIFT INPUTS THE DOSAGE REGIMEN VIA THE INPUT ARGUMENTS (SEE BELOW), +C AND RETURNS AN ALTERED DOSAGE REGIMEN, WHICH HAS EACH BOLUS INPUT +C TIME INCREASED BY THE INPUT VALUE OF TAU (THE TIME LAG). NOTE THAT +C EACH ROW WITH A NON-0 BOLUS INPUT VALUE WILL RESULT IN A NEW ROW IN +C THE DOSAGE REGIMEN. + +C----------------------------------------------------------------------- + +C PROCEDURE FOR THE DOSAGE REGIMEN MODIFICATION: + +C 1. ESTABLISH TAU(I) AS THE TIMELAG FOR DRUG I'S BOLUS COLUMN. +C NO. AS OF SHIFT5.F, THIS VALUE IS INPUT AS AN ARGUMENT. + +C 2. ESTABLISH THE IV VALUES AND TIMES INTO XIV(I,J,K). IN PARTICULAR, +C XIV(I,J,2) IS THE JTH IV VALUE FOR DRUG I, AND XIV(I,J,1) IS THE +C TIME THIS IV VALUE FIRST OCCURRED. SET THE LAST TIME TO 1.D29 AS +C AN INDICATOR THAT THERE ARE NO MORE ENTRIES IN THE ARRAY. + +C 3. ESTABLISH THE COVARIATE VALUES AND TIMES INTO COV(I,J,K). IN +C PARTICULAR, COV(I,J,2) IS THE JTH VALUE FOR COVARIATE I, AND +C COV(I,J,1) IS THE TIME THIS COV VALUE FIRST OCCURRED. SET THE +C LAST TIME TO 1.D29 AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES +C IN THE ARRAY. + +C 4. ESTABLISH THE BOLUS VALUES AND TIMES INTO BOL(I,J,K). +C IN PARTICULAR, BOL(I,J,2) IS THE JTH BOLUS VALUE FOR DRUG I, AND +C BOL(I,J,1) IS THE TIME THIS BOLUS OCCURRED. THE TIMES FOR EACH +C BOLUS VALUE ARE THOSE ADJUSTED TIMES FROM THE ASSOCIATED TIMELAGS +C TAU(I),I=1,NDRUG, FROM STEP 1. SET THE LAST TIME TO 1.D29 AS AN +C INDICATOR THAT THERE ARE NO MORE ENTRIES IN THE ARRAY. + +C 5. REASSIGN THE VALUES IN IV, BOL, AND COV TO THE APPROPRIATE ENTRIES +C OF RS, KEEPING TRACK OF THE RUNNING INDEX, ND, OF DOSE EVENTS. IF +C ND EXCEEDS 5000, STOP THE PROGRAM WITH A MESSAGE TO THE USER. ALSO +C REASSIGN THE CORRESPONDING TIME VALUES TO ARRAY SIG. + + +C STEP 1. + +C NOTHING TO DO. AS OF SHIFT5.F, TAU(I), I=1,NDRUG, IS INPUT AS +C AN ARGUMENT TO THIS ROUTINE. + + +C STEP 2: + +C ESTABLISH THE IV VALUES AND TIMES INTO XIV(I,J,K). IN PARTICULAR, +C XIV(I,J,2) IS THE JTH IV VALUE FOR DRUG I, AND XIV(I,J,1) IS THE +C TIME THIS IV VALUE FIRST OCCURRED. + + DO I = 1,NDRUG + +C ESTABLISH XIV(I,J,K) FOR DRUG I'S IV. PRESET THE LAST VALUE TO +C -99 SO THAT THE FIRST VALUE WILL BE DIFFERENT AND THEREFORE ENGAGE +C THE LOGIC (WHICH ONLY WRITES A ROW INTO THE ARRAY IF THE VALUE IS +C DIFFERENT THAN THE PREVIOUS VALUE). + +C*** MODIFICATION IN SHIFT4.F: IF A TIME RESET OCCURS (I.E., A +C SIG(IDOSE) = 0, WHERE IDOSE > 1), IT WILL BE HANDLED BY ASSIGNING +C AN EXTRA TIME VALUE OF 1.D19 (I.E., A LARGE VALUE REPRESENTING +C TIME = INFINITY) TO THE IV TIME ARRAY. THEN THE REST OF THE +C THE IV TIME ARRAY WILL BE ESTABLISHED WITH THE REST OF THE VALUES +C IN SIG, STARTING, OF COURSE, WITH THE TIME RESET VALUE OF 0. + +C THE SAME LOGIC WILL APPLY TO THE COVARIATES AND THE BOLI. + +C NOTE THAT IND WILL BE THE RUNNING INDEX OF THE LATEST ENTRY INTO +C THE ARRAY. PLACE 1.D29 INTO THE LAST TIME ENTRY OF EACH SUB-ARRAY +C AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES. + + XIV(I,1,1) = 1.D29 + IND = 0 + VALAST = -99.D0 + +C FOR DRUG I, THE IV VALUE IS IN COLUMN 2*I-1 OF ARRAY RS. + + DO IDOSE = 1,ND + + RR = RS(IDOSE,2*I-1) + +C*** MODIFICATION IN SHIFT7.F: A TIME RESET IS NOW DESIGNATED BY A +C SIG(IDOSE) .LE. 0, RATHER THAN JUST .EQ. 0 (SINCE A STEADY STATE +C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). + + IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) THEN + +C THIS REPRESENTS A TIME "RESET". IN THIS CASE, AS INDICATED ABOVE, +C PUT IN AN EXTRA ROW FOR THE IV REPRESENTING A VERY LARGE TIME +C AND THE SAME IV VALUE AS THE PREVIOUS VALUE. THEN PUT IN THE +C LINE REPRESENTING THE RESET TIME OF 0. + + IND = IND + 1 + XIV(I,IND,1) = 1.D19 + XIV(I,IND,2) = XIV(I,IND-1,2) + + IND = IND + 1 + +C*** MODIFICATION IN SHIFT7.F. SET THE NEXT XIV(I,IND,1) TO BE +C SIG(IDOSE), NOT 0, SINCE SIG(IDOSE) MAY BE < 0 (SINCE A STEADY STATE +C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). + + XIV(I,IND,1) = SIG(IDOSE) + XIV(I,IND,2) = RR + XIV(I,IND+1,1) = 1.D29 + VALAST = RR + + GO TO 200 + + ENDIF + +C TO GET HERE, THIS DOSE LINE DOES NOT REPRESENT A TIME RESET. + + IF(RR .NE. VALAST) THEN + IND = IND + 1 + XIV(I,IND,1) = SIG(IDOSE) + XIV(I,IND,2) = RR + XIV(I,IND+1,1) = 1.D29 + VALAST = RR + ENDIF + + 200 CONTINUE + + END DO + +C THE ABOVE END DO IS FOR THE DO IDOSE = 1,ND LOOP. + + + END DO + +C THE ABOVE END DO IS FOR THE DO I = 1,NDRUG LOOP. + + +C STEP 3: + +C ESTABLISH THE COVARIATE VALUES AND TIMES INTO COV(I,J,K). IN +C PARTICULAR, COV(I,J,2) IS THE JTH VALUE FOR COVARIATE I, AND +C COV(I,J,1) IS THE TIME THIS COV VALUE FIRST OCCURRED. SET THE +C LAST TIME TO 1.D29 AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES +C IN THE ARRAY. + + IF(NADD .GT. 0) THEN + + DO I = 1, NADD + +C ESTABLISH COV(I,J,K) FOR COVARIATE NO. I. +C PRESET THE LAST VALUE TO -99 SO THAT THE FIRST VALUE WILL BE +C DIFFERENT AND THEREFORE ENGAGE THE LOGIC (WHICH ONLY WRITES A ROW +C INTO THE ARRAY IF THE VALUE IS DIFFERENT THAN THE PREVIOUS VALUE). +C NOTE THAT IND WILL BE THE RUNNING INDEX OF THE LATEST ENTRY INTO THE +C ARRAY. PLACE 1.D29 INTO THE LAST TIME ENTRY OF EACH SUB-ARRAY AS AN +C INDICATOR THAT THERE ARE NO MORE ENTRIES. + + COV(I,1,1) = 1.D29 + IND = 0 + VALAST = -99.D0 + +C FOR COVARIATE I, THE VALUE IS IN COLUMN 2*NDRUG+I OF ARRAY RS. + + DO IDOSE = 1,ND + + RR = RS(IDOSE,2*NDRUG+I) + +C*** MODIFICATION IN SHIFT7.F: A TIME RESET IS NOW DESIGNATED BY A +C SIG(IDOSE) .LE. 0, RATHER THAN JUST .EQ. 0 (SINCE A STEADY STATE +C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). + + IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) THEN + +C THIS REPRESENTS A TIME "RESET". IN THIS CASE, AS INDICATED ABOVE, +C PUT IN AN EXTRA ROW FOR THE COVARIATE REPRESENTING A VERY LARGE TIME +C AND THE SAME COV VALUE AS THE PREVIOUS VALUE. THEN PUT IN THE +C LINE REPRESENTING THE RESET TIME OF 0. + + IND = IND + 1 + COV(I,IND,1) = 1.D19 + COV(I,IND,2) = COV(I,IND-1,2) + + IND = IND + 1 + +C*** MODIFICATION IN SHIFT7.F. SET THE NEXT COV(I,IND,1) TO BE +C SIG(IDOSE), NOT 0, SINCE SIG(IDOSE) MAY BE < 0 (SINCE A STEADY STATE +C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). + + COV(I,IND,1) = SIG(IDOSE) + COV(I,IND,2) = RR + COV(I,IND+1,1) = 1.D29 + VALAST = RR + + GO TO 300 + + ENDIF + +C TO GET HERE, THIS DOSE LINE DOES NOT REPRESENT A TIME RESET. + + IF(RR .NE. VALAST) THEN + IND = IND + 1 + COV(I,IND,1) = SIG(IDOSE) + COV(I,IND,2) = RR + COV(I,IND+1,1) = 1.D29 + VALAST = RR + ENDIF + + 300 CONTINUE + + END DO + +C THE ABOVE END DO IS FOR THE DO IDOSE = 1,ND LOOP. + + END DO + +C THE ABOVE END DO IS FOR THE DO I = 1, NADD LOOP. + + ENDIF + +C THE ABOVE ENDIF IS FOR THE IF(NADD .GT. 0) CONDITION. + + + +C STEP 4: + +C ESTABLISH THE BOLUS VALUES AND TIMES INTO BOL(I,J,K). IN PARTICULAR, +C BOL(I,J,2) IS THE JTH BOLUS VALUE FOR DRUG I, AND BOL(I,J,1) IS THE +C ADJUSTED (USING THE ASSOCIATED TIMELAGS TAU(I),I=1,NDRUG) TIME THIS +C BOLUS OCCURRED. + + DO I = 1,NDRUG + +C ESTABLISH BOL(I,J,K) FOR DRUG I'S BOLUS. EACH ARRAY IS FILLED ONLY +C WITH NON-0 BOLUS VALUES. NOTE THAT IND WILL BE THE RUNNING INDEX OF +C THE LATEST ENTRY INTO THE ARRAY. PLACE 1.D29 INTO THE LAST TIME ENTRY +C OF EACH SUB-ARRAY AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES. + + BOL(I,1,1) = 1.D29 + IND = 0 + +C FOR DRUG I, THE BOLUS VALUE IS IN COLUMN 2*I OF ARRAY RS. + + DO IDOSE = 1,ND + + RR = RS(IDOSE,2*I) + +C*** MODIFICATION IN SHIFT7.F: A TIME RESET IS NOW DESIGNATED BY A +C SIG(IDOSE) .LE. 0, RATHER THAN JUST .EQ. 0 (SINCE A STEADY STATE +C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). + + IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) THEN + +C THIS REPRESENTS A TIME "RESET". IN THIS CASE, AS INDICATED ABOVE, +C PUT IN AN EXTRA ROW FOR THE BOLUS REPRESENTING A VERY LARGE TIME +C AND AN ACCOMPANYING BOLUS VALUE OF 0. THEN PUT IN THE +C LINE REPRESENTING THE RESET TIME OF 0 + THE TIMELAG ... IF +C RR .NE. 0. + + IND = IND + 1 + BOL(I,IND,1) = 1.D19 + BOL(I,IND,2) = 0.D0 + + IND = IND + 1 + + +C*** THE FOLLOWING CODE IS CHANGED IN SHIFT8.F. NOW BOLUS VALUES +C WORK PROPERLY EVEN WITH TIMELAGS. AND AN ADDITIONAL SUBTLE CHANGE +C WAS ADDED IN shift9.f (SEE THE COMMENTS AT THE TOP OF shift9.f), +C AND THE EXTRA COMMENTS BELOW. + + +C LOGIC IS NOW AS FOLLOWS: + +C IF SIG(IDOSE) = 0, THIS IS A TIME RESET WHICH IS NOT THE START OF +C A STEADY STATE DOSE SET. IN THIS CASE, A BOLUS WITH A TIMELAG OF +C TAU(I) WILL OCCUR AT SIG(IDOSE) + TAU(I) = TAU(I). + +C IF SIG(IDOSE) < 0, THIS IS A TIME RESET WHICH IS THE START OF A +C STEADY STATE DOSE SET. IN THIS CASE: +C THE BOLUS TIME WILL BE TAU(I) ONLY IF BOTH TAU(I) AND RR +C ARE NOT 0. OTHERWISE, IT WILL BE SIG(IDOSE). +C REASON: IF RR = 0, THERE IS NO BOLUS TO BE GIVEN, SO IT WOULD +C BE SILLY TO INCLUDE AN EXTRA LINE IN THE DOSAGE REGIMEN WITH +C A 0 BOLUS (AND IT WOULD VERY SLIGHTLY CHANGE THE RESULTS SINCE +C THE NUMERICAL INTEGRATION THEN HAS TO INTEGRATE THROUGH AN EXTRA +C TIME). IN AN EXAMPLE (REMARK 4.b IN NPAG109.EXP, THIS CHANGED THE +C VALUES IN THE LOG-LIKELIHOODS OUT IN THE 13TH DIGIT, BUT SOME +C VALUES IN THE DENSITY FILE WERE CHANGED IN THE 4TH DIGIT). + +C ALSO, IF TAU(I) = 0, THE BOLUS HAS NO TIMELAG AND THEREFORE +C OCCURS AT SIG(IDOSE). + +C THE FOLLOWING EXAMPLE SHOWS WHY A NON-0 BOLUS IN A STEADY STATE DOSE +C SET, WITH TAU(I) .NE. 0, MUST BE GIVEN AT TAU(I) AND NOT +C SIG(IDOSE) + TAU(I). + +C EX: IF SIG(IDOSE) = -12, IT MEANS THAT A STEADY STATE DOSE SET IS +C STARTING WITH AN INTERDOSE INTERVAL OF 12 HOURS. SO, IF A +C BOLUS WITH A TLAG OF 1.5 HOURS IS GIVEN, ITS TIME MUST BE +C 1.5, NOT -12 + 1.5 = -10.5. REASON: AFTER THE SIG(IDOSE) OF +C -12 IS CONVERTED IN SUBROUTINE FUNC2 TO 0, THE 1.5 WILL CORRECTLY +C INDICATE THAT THE BOLUS IS GIVEN 1.5 HOURS AFTER THE START OF THE +C STEADY STATE DOSE SET. ALSO, A TIME OF -10.5 WOULD COMPLETELY +C SCREW UP THE FUNC2 LOGIC WHICH WOULD INTERPRET IT AS THE START +C OF ANOTHER STEADY STATE DOSE SEST. + +C ON THE OTHER HAND, IF A DRUG HAS A TAU(I) = 0, IT CANNOT SHOW +C UP AS OCCURRING AT TAU(I) = 0 SINCE THIS WILL COMPLETELY SCREW +C UP FUNC2'S LOGIC, WHICH WILL INTERPRET THE TIME OF 0 AS A +C TIME RESET EVENT. IN THIS CASE, THE BOLUS OCCURS AT THE START OF +C THE STEADY STATE DOSE SET, I.E., AT SIG(IDOSE) = -12, WHICH WILL +C BE CONVERTED TO 0 BY FUNC2). + + + CALL THESAME(SIG(IDOSE),0.D0,ISAME1) + CALL THESAME(TAU(I),0.D0,ISAME2) + CALL THESAME(RR,0.D0,ISAME3) + + IF(ISAME1 .EQ. 1) BOL(I,IND,1) = TAU(I) +C NOTE THAT, TECHNICALLY, WE SHOULD SET BOL(I,IND,1) = SIG(IDOSE) = 0 +C IF RR = 0, SINCE THERE IS NO REASON TO HAVE AN EXTRA LINE IN THE +C DOSAGE REGIMEN FOR A 0 BOLUS ... BUT CHANGING THIS WOULD CHANGE +C VERY SLIGHTLY THE RESULTS IN A 0 BOLUS CASE SINCE THERE WOULD BE ONE +C LESS DOSAGE LINE FOR THE NUMERICAL INTEGRATOR TO INTEGRATE THROUGH, +C SO THE CODE WILL BE LEFT AS IS, FOR CONSISTENCY SAKE. + + + IF(ISAME1 .EQ. 0) THEN + BOL(I,IND,1) = SIG(IDOSE) + IF(ISAME2 .EQ. 0 .AND. ISAME3 .EQ. 0) BOL(I,IND,1) = TAU(I) + ENDIF + + + + BOL(I,IND,2) = RR + BOL(I,IND+1,1) = 1.D29 + VALAST = RR + + GO TO 400 + + ENDIF + +C TO GET HERE, THIS DOSE LINE DOES NOT REPRESENT A TIME RESET. + + + IF(RR .NE. 0.D0) THEN + + IND = IND + 1 + +C *** CHANGE FOR SHIFT8.F. +C NOW BOLUS VALUES CAN OCCUR IN STEADY STATE DOSES. AND IF THEY DO, +C THE FIRST ONE MUST OCCUR AT TIME TAU(I), NOT SIG(IDOSE) + TAU(I) +C AS THE FOLLOWING EXAMPLE ILLUSTRATES: +C EX: SIG(1) = -12 INDICATING THAT THE STEADY STATE DOSE SET HAS +C AN INTERDOSE INTERVAL OF 12 HOURS. TAU(1) = 1.5 --> +C DRUG 1 HAS A TIMELAG OF 1.5 HOURS. SO, IF THE FIRST BOLUS TIME IS +C SET = SIG(1) + TAU(1) = -12 + 1.5 = -10.5, THIS WILL SCREW +C UP THE FUNC2 LOGIC SINCE IN THAT CODE, THE FIRST TIME OF +C -12 WILL BE RESET TO BE 0, AND THIS WILL BE FOLLOWED BY -10.5, +C WHICH WILL LOOK LIKE THE START OF ANOTHER STEADY STATE DOSE +C SET. INSTEAD, SET FIRST BOLUS TIME = TAU(1) = 1.5, WHICH IS +C CORRECT SINCE IT OCCURS 1.5 HOURS AFTER THE STEADY STATE DOSE +C STARTS. + + IF(SIG(IDOSE) .GE. 0.D0) BOL(I,IND,1) = SIG(IDOSE) + TAU(I) + IF(SIG(IDOSE) .LT. 0.D0) BOL(I,IND,1) = TAU(I) + + BOL(I,IND,2) = RR + BOL(I,IND+1,1) = 1.D29 + ENDIF + + 400 CONTINUE + + END DO + +C THE ABOVE END DO IS FOR THE DO IDOSE = 1,ND LOOP. + + + END DO + + +C THE ABOVE END DO IS FOR THE DO I = 1,NDRUG LOOP. + + + +C STEP 5: + +C REASSIGN THE VALUES IN IV, BOL, AND COV TO THE APPROPRIATE ENTRIES +C OF RS, KEEPING TRACK OF THE RUNNING INDEX, ND, OF DOSE EVENTS. IF +C ND EXCEEDS 5000, STOP THE PROGRAM WITH A MESSAGE TO THE USER. ALSO, +C REASSIGN THE CORRESPONDING TIME VALUES TO ARRAY SIG. + + NI = 2*NDRUG + NADD + ND = 0 + +C GO THROUGH THE ARRAYS IV, BOL, AND COV TO DETERMINE THE NEXT +C LOWEST DOSE TIME. PUT THIS VALUE INTO RS, ALONG WITH THE +C CORRESPONDING VALUES FOR THE IV'S, THE BOLI, AND THE COVARIATES. + +C IN THE LOOP BELOW, IT IS NECESSARY TO KNOW TO WHAT POINT IN THE +C IV, BOL, AND COV ARRAYS THE TIMES AND VALUES HAVE ALREADY BEEN +C STORED INTO RS. THESE INDICES ARE INDIV(I), I=1,NDRUG; INDBOL(I), +C I=1,NDRUG; AND INDCOV(I), I=1,NADD, RESPECTIVELY. E.G., +C INDIV(2) = 4 MEANS THAT ALL VALUES IN THE IV, BOL, AND COV ARRAYS, +C THROUGH THE 4TH TIME FOR IV DRUG 2 (I.E., THROUGH TIME = XIV(2,4,1)) +C HAVE BEEN OR ARE ABOUT TO BE STORED INTO THE RS ARRAY. + +C SO PRESET ALL THESE INDEX INDICATORS = 1, AND INITIALIZE THE +C CURRENT DOSE TIME TO A NEGATIVE NO. SO THAT THE FIRST TIME +C THROUGH THE FOLLOWING LOOP WILL ENGAGE THE LOGIC. + + DO I = 1,NDRUG + INDIV(I) = 1 + INDBOL(I) = 1 + END DO + + IF(NADD .GT. 0) THEN + DO I = 1,NADD + INDCOV(I) = 1 + END DO + ENDIF + + TIMNXT = -9999999.D0 + + + 100 CONTINUE + +C FIND THE NEXT LOWEST TIME AMONG THE IV, BOL, AND COV ARRAYS. + +C ESTABLISH INTO TIMCAN(J) THE CANDIDATES FOR THE NEXT DOSE TIME +C (AND CORRESPONDING VALUES FOR THE IV'S, BOLI, AND COVARIATES) TO +C BE PUT INTO RS. + + + DO I = 1,NDRUG + IF(XIV(I,INDIV(I),1) .GT. TIMNXT) TIMCAN(I)=XIV(I,INDIV(I),1) + IF(XIV(I,INDIV(I),1) .EQ. TIMNXT) TIMCAN(I)=XIV(I,INDIV(I)+1,1) + END DO + + DO I = 1,NDRUG + IF(BOL(I,INDBOL(I),1) .GT. TIMNXT) TIMCAN(NDRUG+I) = + 1 BOL(I,INDBOL(I),1) + IF(BOL(I,INDBOL(I),1) .EQ. TIMNXT) TIMCAN(NDRUG+I) = + 1 BOL(I,INDBOL(I)+1,1) + END DO + + + IF(NADD .GT. 0) THEN + DO I = 1,NADD + IF(COV(I,INDCOV(I),1) .GT. TIMNXT) TIMCAN(2*NDRUG+I) = + 1 COV(I,INDCOV(I),1) + IF(COV(I,INDCOV(I),1) .EQ. TIMNXT) TIMCAN(2*NDRUG+I) = + 1 COV(I,INDCOV(I)+1,1) + END DO + ENDIF + +C FIND THE NEXT TIMNXT, THE MINIMUM VALUE AMONG THE NI ENTRIES IN +C TIMCAN. TIMNXT WILL BE THE NEXT TIME TO BE PUT INTO ARRAY RS (ALONG +C WITH ALL THE CORRESPONDING IV'S, BOLI, AND COVARIATE VALUES). IF +C TIMNXT = 1.D29, IT IS BECAUSE THERE ARE NO FURTHER VALUES TO BE PUT +C INTO RS (I.E, THE PROCESS IS FINISHED). + + TIMNXT = TIMCAN(1) + DO I = 2,NI + IF(TIMCAN(I) .LT. TIMNXT) TIMNXT = TIMCAN(I) + END DO + + IF(TIMNXT .EQ. 1.D29) RETURN + +C SINCE TIMNXT < 1.D29, THERE ARE MORE VALUES TO BE PUT INTO RS. +C GO THROUGH ALL THE SUBARRAYS AND PUT IN VALUES AS FOLLOWS. IF THE +C CURRENT TIME FOR AN IV, BOLUS, OR COVARIATE IS THE SAME AS TIMNXT, +C PUT THE CORRESPONDING IV, BOLUS, OR COVARIATE VALUE INTO RS, AND +C INCREASE THE INDEX FOR THAT SUB-ARRAY TO THE NEXT VALUE. IF THE +C CURRENT TIME FOR AN IV OR A COVARIATE IS .GT. TIMNXT, PUT THE IV OR +C COVARIATE VALUE FROM THE PREVIOUS ROW INTO RS, AND LEAVE THE INDEX +C UNCHANGED. IF THE CURRENT TIME FOR A BOLUS IS .GT. TIMNXT, PUT 0.0 +C INTO RS (I.E., BOLUS VALUES ARE INSTANTANEOUS, WHEREAS IV AND +C COVARIATE VALUES CONTINUE UNTIL CHANGED), AND LEAVE THE INDEX +C UNCHANGED. + + +C TEST FOR TIMNXT = 1.D19, WHICH INDICATES A TIME RESET. + + IF(TIMNXT .EQ. 1.D19) THEN + +C TIMNXT = 1.D19 MEANS THAT THE NEXT TIME IN EACH ARRAY IS THE +C TIME AT OR AFTER THE RESET. SO INCRASE ALL THE ARRAY INDICES BY +C 1, RESET TIMNXT TO A NEGATIVE NO. AND RETURN TO LABEL 100. + + DO I = 1,NDRUG + INDIV(I) = INDIV(I) + 1 + INDBOL(I) = INDBOL(I) + 1 + END DO + + + IF(NADD .GT. 0) THEN + DO I = 1,NADD + INDCOV(I) = INDCOV(I) + 1 + END DO + ENDIF + + TIMNXT = -9999999.D0 + + GO TO 100 + + ENDIF + + + ND = ND+1 + + IF(ND .GT. 5000) THEN + +C IF ND > 5000, STOP WITH A MESSAGE TO THE USER THAT THE +C PROGRAM ONLY ALLOWS A TOTAL OF 5000 DOSE EVENTS. + + 10 WRITE(*,1) ND + 1 FORMAT(/' THE NUMBER OF DOSE EVENTS, AFTER TAKING INTO'/ + 1' ACCOUNT DIFFERING TIMES DUE TO TIMELAGS IS ',I6,', MORE THAN'/ + 2' THE ALLOWABLE MAXIMUM OF 5000. THE PROGRAM IS STOPPING. PLEASE'/ + 3' RERUN WITH PATIENTS HAVING FEWER DOSE EVENTS, OR WITH FEWER'/ + 4' TIMELAG VALUES SELECTED AS FIXED OR RANDOM PARAMETERS.'//) + STOP + + ENDIF + +C ND .LE. 5000, SO CONTINUE. FOR THIS DOSE EVENT, PUT IN THE CURRENT +C TIME, AND THE CORRESPONDING IV, BOLUS, AND COVARIATE VALUES. + + + SIG(ND) = TIMNXT + + DO I = 1,NDRUG + + IF(TIMNXT .LT. XIV(I,INDIV(I),1)) THEN + RS(ND,2*I-1) = RS(ND-1,2*I-1) + ENDIF + + IF(TIMNXT .EQ. XIV(I,INDIV(I),1)) THEN + RS(ND,2*I-1) = XIV(I,INDIV(I),2) + INDIV(I) = INDIV(I) + 1 + ENDIF + + IF(TIMNXT .LT. BOL(I,INDBOL(I),1)) THEN + RS(ND,2*I) = 0.D0 + ENDIF + + IF(TIMNXT .EQ. BOL(I,INDBOL(I),1)) THEN + RS(ND,2*I) = BOL(I,INDBOL(I),2) + INDBOL(I) = INDBOL(I) + 1 + ENDIF + + END DO + + + IF(NADD .GT. 0) THEN + DO I = 1,NADD + IF(TIMNXT .LT. COV(I,INDCOV(I),1)) + 1 RS(ND,2*NDRUG+I) = RS(ND-1,2*NDRUG+I) + IF(TIMNXT .EQ. COV(I,INDCOV(I),1)) THEN + RS(ND,2*NDRUG+I) = COV(I,INDCOV(I),2) + INDCOV(I) = INDCOV(I) + 1 + ENDIF + END DO + ENDIF + + + GO TO 100 + + + END + + diff --git a/src/bestdose/cost.rs b/src/bestdose/cost.rs index c3ba15aa0..1b0b0ea95 100644 --- a/src/bestdose/cost.rs +++ b/src/bestdose/cost.rs @@ -510,7 +510,7 @@ pub fn calculate_cost(problem: &BestDoseProblem, candidate_doses: &[f64]) -> Res let se = (obs_val - pj).powi(2); sumsq_i += se; // Calculate population mean using PRIOR probabilities - y_bar[j] += prior_prob * pj; + y_bar[j] += post_prob * pj; } variance += post_prob * sumsq_i; // Weighted by posterior From ef44694c6a9d9254ef849112ecd5a9245716ba0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Juli=C3=A1n=20D=2E=20Ot=C3=A1lvaro?= Date: Tue, 24 Mar 2026 20:45:42 +0000 Subject: [PATCH 2/4] fix(bestdose) variance is calculated using the post_prob --- src/bestdose/bestdose.for | 29946 ------------------------------------ 1 file changed, 29946 deletions(-) delete mode 100644 src/bestdose/bestdose.for diff --git a/src/bestdose/bestdose.for b/src/bestdose/bestdose.for deleted file mode 100644 index 832091a1d..000000000 --- a/src/bestdose/bestdose.for +++ /dev/null @@ -1,29946 +0,0 @@ -C BESTDOS121.FOR 6/10/16 - -C BESTDOS121 HAS THE FOLLOWING CHANGES FROM BESTDOS120: - -C THIS PROGRAM IS NOW COMPATIBLE WITH THE NEW "DENSITY OCT_15" -C DENSITY FILE MADE BY THE NEW NPAG PROGRAM (NPAG120.FOR/npagranfix6.f) -C WHICH HAS NRANFIX PARAMETERS. - -C THE CHANGES NECESSARY ARE IN READING IN THE POTENTIAL NRANFIX -C PARAMETER NAMES AND VALUES IN THE NPAGDENFILE. THEN THESE VALUES, -C WHICH WERE ESTIMATED IN THE ORIGINAL NPAG RUN, ARE TREATED JUST THE -C SAME AS THE FIXED PARAMETER VALUES WHICH FIXED IN THE NPAG RUN. - -C----------------------------------------------------------------------- - -C BESTDOS120.FOR 2/19/16 - -C BESTDOS120 HAS ONE SMALL CHANGE FROM BESTDOS119. IN THE CODE BELOW -C FORMAT 8133 IN MAIN, THE CONTINGENCY ON IPRIOR IS REMOVED. THIS -C SHOULD HAVE BEEN DONE IN BESTDOS105.FOR, WHEN IPRIOR WAS NO LONGER -C READ IN, BUT THE EFFECT WAS THE SAME SINCE IF IPRIOR = 0 (WHICH IS -C THE DEFAULT FOR NON-INITIALIZED VARIABLES IN MOST COMPILERS), IERRMOD -C IS WRITTEN TO FILE 24 AS IT SHOULD BE. BUT BECAUSE SOME OPERATING -C SYSTEMS/COMPILERS MAY ASSIGN RANDOM NOS. TO VARIABLES WHICH ARE NOT -C INITIALIZED, IT IS POSSIBLE THAT IPRIOR COULD BE SET TO SOMETHING -C NON-0, WHICH WOULD MEAN THAT IERRMOD WOULD NOT BE WRITTEN TO FILE 24. -C SO THIS CHANGE WILL REMOVE THAT POSSIBLE BUG. NOTE THAT IPRIOR IS -C ALSO REMOVED AS A CALLING ARGUMENT TO SUBROUTINE VERIF1. - -C----------------------------------------------------------------------- - -C BESTDOS119.FOR 7/7/14 - -C BESTDOS119 HAS THE FOLLOWING CHANGES FROM BESTDOS118: - -C 1. THIS PROGRAM NOW ALLOWS STEADY STATE DOSING IN THE "PAST" (NOT -C THE FUTURE). THIS REQUIRES: - -C MODULE IDM1X14.FOR IS UPDATED TO IDM1X15.FOR, WHICH HAS JUST A -C COUPLE OF SMALL CHANGES FROM IDM1X15.F (WHICH IS ALREADY USED IN THE -C NPAG "ENGINE"). - -C MODULE IDM3X141.FOR IS UPDATED TO IDM3X151.FOR, WHICH IS -C SIMILAR TO IDM3X15.F (WHICH IS ALREADY USED IN THE NPAG "ENGINE"), -C BUT WITH THE CHANGE THAT IDM3X141.FOR MADE TO IDM3X14.FOR, -C (DIMENSIONS OF 71281 CHANGED TO 72000). - -C MODULE CALCBST14.FOR IS UPDATED TO CALCBST15.FOR. - -C MODULE NPAGFULL.FOR IS UPDATED TO BE NPAGFULLA.FOR. - -C MODULE NPAGFULL11.FOR IS UPDATED TO BE NPAGFULLA11.FOR. - -C FORMAT 1416 IS EDITED TO INDICATE THAT STEADY STATE DOSE SETS AT THE -C BEGINNING OF THE PATIENT FILE ARE ALLOWED. BUT NOT DOSE OR TIME -C RESETS. AND A NEW CHECK IS PUT IN SUBROUTINE READBLOCK2 TO DISALLOW -C IDEVENT = 4 (DOSE RESETS). - -C NOTE THAT SUBROUTINE CALCTPRED IS MODIFIED TO REALLOW STEADY STATE -C DOSE SETS (THE CODE TO ALLOW THESE SETS WAS REMOVED AS OF -C BESTDOS109.FOR). AND THE SAME IS TRUE FOR SUBROUTINE CALCTPRED2. - - -C 2. JUST BEFORE THE FIRST CALL FILRED(..) STATEMENT, SUBROUTINE -C NEWWORK1 IS CALLED TO READ THE PATIENT DATA FROM FILE 27, AND -C CONVERT IT TO PATIENT DATA ON FILE 37, WITH EACH STEADY STATE DOSE -C INDICATOR RESULTING IN AN EXTRA 100 DOSE SETS (WITH THE NEGATIVE DOSE -C TIME LEFT IN - SEE COMMENTS BELOW).NOTE THAT THIS SUBROUTINE NEWWORK1 -C IS THE SAME AS IN THE CURRENT NPAG "ENGINE" MODULE, npageng25.f, -C EXCEPT IT READS FILE 27 AND WRITES TO FILE 37, RATHER THAN READING -C FROM FILE 23 AND WRITING TO FILE 27; ARRAY TIMOBREL IS NOT -C ESTABLISHED IN NEWWORK1, AND NOT PASSED AS AN ARGUMENT (IT IS NOT -C NEEDED IN THIS PROGRAM); MAXSUB IS ALSO NOT PASSED AS AN -C ARGUMENT (IT IS NOT NEEDED); NSUB IS NOT PASSED AS AN ARGUMENT (IT -C IS NOT NEEDED); AND COMMON/DOSEOBS AND THE ARRAYS IN IT ARE DELETED -C (THEY ARE NOT NEEDED). - -C NOTE THAT THIS NEWWORK1 ROUTINE IS INCLUDED IN THE NPAGFULLA.FOR -C MODULE, AS IS SUBROUTINE ORDERDELTA. - - -C 3. SUBROUTINE MAKETMP NOW RETURNS ND42 RATHER THAN ND41. THE REASON -C IS THAT IF THE PATIENT FILE HAS STEADY STATE DOSING, ND41 WILL -C CHANGE AFTER NEW SUBROUTINE NEWWORK1 (SEE CHANGE 2. ABOVE) IS CALLED -C (I.E., THERE WILL BE A LOT MORE DOSES IN THE "PAST"), BUT ND42 WILL -C NOT (THERE ARE NO STEADY STATE DOSES IN THE "FUTURE"). -C SO ND41 AND NDD41 ARE NOW ESTABLISHED AFTER NEWWORK1 IS CALLED, -C IN THE CASE THAT INCLUDPAST = 1. - - -C 4. SUBROUTINE FILRED IS CHANGED TO READ FILE 37, RATHER THAN -C FILE 27. - - -C 5. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN -C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx -C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING -C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT -C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT -C USING COMMON/ERROR/ERRFIL. - -C NOTE THAT CODE TO READ extnum TO GET THE 4-DIGIT JOB NUMBER IS -C ADDED ALSO TO THE 'GUICMDS.INX' CODE, JUST AFTER PATH IS READ IN, -C BECAUSE ERRFIL MAY HAVE TO BE WRITTEN TO DURING THAT PART OF THE -C CODE ALSO. - - -C 6. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, -C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET -C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED -C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT -C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS -C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL -C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 -C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO -C MAXNUMEQ. - - -C 7. SUBROUTINE DETECT, AND THE ROUTINES IT CALLS, ARE REMOVED FROM -C THE CODE. NOTE IN THE COMMENTS TO BESTDOS8.FOR, DETECT AND THE -C ROUTINE IT CALLED WERE NO LONGER NEEDED, BUT WERE LEFT IN THIS FILE -C IN CASE THEY WERE NEEDED IN THE FUTURE. BUT IF THAT SHOULD OCCUR, -C THESE ROUTINES CAN BE COPIED BACK IN FROM PROGRAM BESTDOS118.FOR. - - -C 8. A BUG IS FIXED IN SUBROUTINE WSUMSQ IN NEW MODULE CALCBST15.FOR. -C IT WAS IN THE IF(ITARGET .EQ. 2) PORTION OF THE CODE. AUC IS NO -C LONGER SET BACK TO 0 IF TPRED(I) = TNEXT ... SINCE AUCs ARE -C CUMULATIVE FROM TIME 0 IN THE "PAST", AS OF BESTDOS118.FOR. THIS -C BUG EXISTED ONLY IN BESTDOS118.FOR. - - -C 9. SUBROUTINE PUTORDER2 IS REMOVED; INSTEAD SUBROUTINE CALCTPRED2 -C WILL CALL PUTORDER, WHICH HAS THE SAME CODE (AT ONE POINT, THESE -C TWO ROUTINES HAD A DIFFERENT DIMENSION FOR XX, BUT THIS IS NO -C LONGER TRUE; AND SO PUTORDER2 BECAME REDUNDANT). - - -C 10. ALL REFERENCES TO THE TEMPLATE MODEL FILE TSTMULTK.FOR ARE -C REPLACED BY TSTMULTM.FOR. - -C----------------------------------------------------------------------- - -C BESTDOS118.FOR 11/13/13 - - -C BESTDOS118 HAS THE FOLLOWING CHANGE TO BESTDOS117: - -C THE CODE IN MAIN CHANGES SO THAT THE AUCs WRITTEN TO DOSEROUTxxxx -C WILL BE CUMULATIVE AUCs FROM TIME 0 IN THE "PAST", RATHER THAN BE -C RESET TO 0 AT TNEXT (= TIME 0 IN THE "FUTURE"). BUT NOTE THAT THE -C CODE IN WSUMSQ (IN CALCBST14.FOR) IS UNCHANGED, SO THAT AUCs IN THE -C "FUTURE" ARE STILL ASSUMED TO BE RELATIVE TO THE BEGINNING OF THE -C "FUTURE", AND ARE RESET TO 0 AT TIME TNEXT. - -C----------------------------------------------------------------------- - -C BESTDOS117.FOR 11/4/13 - -C BESTDOS117 HAS THE FOLLOWING CHANGES TO BESTDOS116: - -C 1. IT HAS A BUG FIX TO BESTDOS116. BELOW THE 2ND CALL TO ELDERY, -C JUST ABOVE WHERE THE DOSEROUTxxxx FILE IS ESTABLISHED, FILE 27 IS -C REWOUND AND FILRED IS CALLED AGAIN. THIS IS DONE TO RE-ESTABLISH THE -C ORIGINAL DOSE VALUES INTO THE RS(.,.) ARRAY. THE REASON IS THAT -C ELDERY CALLS CALCS, WHICH CALLS WSUMSQ, WHICH SETS THE RS(.,.) VALUES -C TO THE CURRENT CANDIDATES SUPPLIED BY ELDERY. AND IF THESE VALUES -C HAPPEN TO BE SET = 0, THEN THE CODE TO WRITE OUT THE OPTIMAL DOSES -C IN MAIN (WHICH DEPEND ON RS(I,2*J-1) OR RS(I,2*J) BEING > 0 TO -C IDENTIFY AN IV OR A BOLUS, RESPECTIVELY) WILL NOT BE ENGAGED. AND -C THEN THE #OPTIMAL DOSES LINE WILL BE FOLLOWED BY NO DOSES AT ALL. -C IN ADDITION, THE CODE TO ESTABLISH THE BEST DOSES INTO RS(.,.) FOR -C THE PURPOSE OF WRITING THE PREDICTED VALUES FOR THESE BEST DOSES, -C FOR EACH GRID PT. IN THE PARAMETER DENSITY, WILL NOT BE ENGAGED -C EITHER. - -C 2. THE NAME "XLAM" IS CHANGED TO BIASWEIGHT TO REMOVE ANY -C CONFUSION WITH LAMBDA, WHICH IS A TERM USED IN THE ASSAY ERROR -C FUNCTION. SIMILARLY, IN THE OUTPUT FILE, "LAMDA" IS CHANGED TO -C "BIASWEIGHT". - -C 3. THE SAME "XLAM" TO "BIASWEIGHT" CHANGE IS MADE IN THE NEW -C CALCBST14.FOR (WHICH REPLACES CALCBST13.FOR). - - -C----------------------------------------------------------------------- - -C BESTDOS116.FOR 10/16/13 - -C BESTDOS116 HAS THE FOLLOWING CHANGES TO BESTDOS115: - -C IF THE USER SELECTS ITARGET = 2 (SEE BELOW), THE AUCs NOW WILL BE -C RELATIVE TO TIME 0 IN THE "FUTURE", AS OPPOSED TO TIME 0 IN THE -C "PAST". - -C THIS REQUIRES CHANGES IN THE CODE IN MAIN, AND IN SUBROUTINE -C WSUMSQ. IN EACH CASE, THE AUC AT TIME TNEXT (WHICH IS THE BEGINNING -C TIME FOR THE "FUTURE") IS RESET BACK TO 0. - -C NOTE ALSO THAT TNEXT IS NOW INCLUDED IN COMMON/TOSUMSQ, SO THAT -C IT CAN BE ADDED TO THE TIMES WHICH ARE ESTABLISHED BY ROUTINES -C CALCTPRED AND CALCTPRED2. - -C NOTE THAT THIS PROGRAM IS NOW LINKED WITH CALCBST13.FOR, WHICH IS -C UPDATED FROM CALCBST12.FOR. - -C----------------------------------------------------------------------- - -C BESTDOS115.FOR 10/6/13 - -C BESTDOS115 HAS THE FOLLOWING CHANGES TO BESTDOS114: - -C 1. IN ADDITION TO USING CONCENTRATIONS (OBSERVED VALUES) AS TARGETS, -C NOW THE USER WILL BE ABLE TO TARGET AUCs ALSO. - -C THIS WILL REQUIRE A NEW INPUT VALUE, ITARGET. IF ITARGET = 1, THE -C TARGETS WILL BE CONCENTRATIONS, AS THEY HAVE BEEN IN PREVIOUS -C PROGRAMS. IF ITARGET = 2, THE TARGETS WILL BE AUCs. NOTE THAT EVEN IF -C THE TARGETS ARE AUCs, THESE VALUES WILL STILL BE READ IN BY THE -C PROGRAM IN THE SAME LOCATIONS (AS IF THEY WERE CONCENTRATIONS IN THE -C PATIENT DATA FILE). - -C BECAUSE THE INSTRUCTION FILE WILL HAVE THE ADDITIONAL ITARGET ENTRY, -C IT WILL ALSO HAVE A NEW CODE, BESTDOS OCT_13. - -C 2. THERE WILL BE EXTENSIVE CHANGES IN SUBROUTINES CALCS AND WSUMSQ -C IN CALCBST12.FOR (UPDATED FROM CALCBST11.FOR). ALSO, THIS MODULE -C HAS NEW SUBOUTINES CALCTPRED2 AND PUTORDER2. - -C 3. NOTE THAT ARRAYS WEIGHT, PREDMIN2, DENSITY2, AND DOSEBEST2 -C HAVE BEEN REMOVED. WEIGHT WAS NOT NEEDED AFTER BESTDOS114.FOR, -C AND THE OTHER 3 ARRAYS WERE NEVER NEEDED. - -C 4. TO MAKE DIMENSIONS CONSISTENT, ALL 24000'S HAVE BEEN CHANGED TO -C 72000'S. AND ALL 71281'S HAVE BEEN CHANGED TO 72000 ALSO (THIS HAS -C ALSO BEEN DONE IN CALCBST12.FOR). SIMILARLY, ALL 7200'S HAVE BEEN -C CHANGED TO 72000'S. THE REASON TO LIMIT NUMT IN CALCTPRED TO 7200 -C WAS A HOLDOVER FROM THE npageng24.f PROGRAM, AND IS NOT APPLICABLE -C IN THIS PROGRAM. - -C 5. THIS PROGRAM IS NOW LINKED WITH IDM3X141.FOR, UPDATED FROM - -C DM3X14.FOR. THE DIFFERENCE IS THAT THE NEW MODULE HAS ALL ITS -C 71281 DIMENSIONS CHANGED TO 72000, TO BE COMPATIBLE WITH CHANGE -C 4. ABOVE. - -C 6. NOTE THAT XLAM HAS BEEN MOVED IN FRONT OF THE INTEGER ARGUMENTS -C IN COMMON/TOCALC TO AVOID A WARNING WHEN THIS PROGRAM IS COMPILED -C WITH gfortran. - -C----------------------------------------------------------------------- - -C BESTDOS114.FOR 9/27/13 - - -C BESTDOS114 HAS THE FOLLOWING CHANGES TO BESTDOS113: - -C 1. IT WILL NOW BE COMPILED WITH CALCBST11.FOR, UPDATED FROM -C CALCBST10.FOR. THE MAIN CHANGE IN SUBROUTINE CALCS IS THAT THE -C COST FUNCTION WILL NOW INVOLVE THE OLD COST FUNCTION (MEAN SQUARED -C ERROR), PLUS A NEW BIAS TERM. THESE TWO TERMS WILL BE WEIGHTED BY -C XLAM (USER SPECIFIED) WHICH WILL MULTIPLY THE BIAS TERM (AND 1-XLAM) -C WILL MULTIPLY THE MEAN SQUARED ERROR TERM. - -C NOTE THAT SINCE THE USER NOW ENTERS XLAM, THERE WILL BE A NEW -C INSTRUCTION FILE, WITH A NEW CODE, BESTDOS SEP_13. AND NOTE THAT -C XLAM IS PROVIDED TO SUBROUTINE CALCS VIA COMMON/TOCALC. - -C NOTE THAT BOTH TERMS IN THE COST FUNCTION ARE NOW ALSO WRITTEN INTO -C DOSEROUTxxxx. - -C 2. THE MEAN SQUARED ERROR TERM WILL HAVE WEIGHT(.,.) REMOVED FROM -C IT. I.E., COST FUNCTION WILL NO LONGER BE A FUNCTION OF THE ASSAY -C COEFFICIENTS. SO WEIGHT IS NOW REMOVED FROM COMMON/TOCALC. - -C 3. INSTEAD OF CALCULATING THE WEIGHTED MEAN OF THE GRID PTS. AND -C CALCULATING THE Y's AND AUC's FOR THAT SINGLE GRID PT., AS THE LAST -C PART TO BE PUT INTO DOSEROUTxxxx, NOW THE WEIGHTED MEAN OF THE -C Y's AND AUC's OVER ALL THE GRID PTS. WILL BE PUT INTO DOSEROUTxxxx. -C THIS IS MORE CONSISTENT WITH THE BIAS TERM CALCULATED IN SUBROUTINE -C CALCS. - -C----------------------------------------------------------------------- - -C BESTDOS113.FOR 8/26/13 - -C BESTDOS113 COMBINES THE CHANGE OF BESTDOS112A WITH THE ORIGINAL -C BESTDOS112. IN PARTICULAR, THIS PROGRAM WILL CALL SUBROUTINE ELDERY -C TWICE, ONCE WITH ALL THE POSTERIOR GRID PTS. HAVING EQUAL -C PROBABILITY (AS IN BESTDOS112), AND ONCE WITH THE POSTERIOR GRID PTS. -C HAVING THEIR VALUES FROM THE 0-CYCLE RUN IN NPAGFULL1. THEN, THE -C ELDERY CALL WHICH PRODUCES THE MIN SUM OF SQUARES WILL BE USED TO -C ESTABLISH THE BEST DOSES. - -C REF: SEE THE EXAMPLE WITH MODEL3.FOR (COMMENTS UNDER 9.) IN -C \ALAN3\BAYARD\SIMSTUDY\SIMSTUDY.EXP. - -C----------------------------------------------------------------------- - - -C BESTDOS112A.FOR 8/18/13 - -C BESTDOS112A HAS ONE CHANGE TO BESTDOS112. AFTER THE RETURN FROM -C SUBROUTINE NPAGFULL, CORDEN(.,NVAR+1) IS NOT RESET. IT WILL NOW -C RETAIN ITS VALUE FROM WHAT IT WAS ON RETURN FROM NPAGFULL1. THE -C REASON IS THAT THE DENSITY VALUES FROM NPAGFULL1 ACCURATELY REFLECT -C HOW IMPORTANT EACH DAUGHTER PT. SHOULD BE IN THE CALL TO ELDERY -C (THE WAY IT WAS DONE IN BESTDOS112.FOR, ALL THE GRID PTS. ENDED -C UP WITH EQUAL PROBABILITY). - -C----------------------------------------------------------------------- - -C BESTDOS112.FOR 8/6/13 - -C BESTDOS112 HAS THE FOLLOWING CHANGES TO BESTDOS111. - -C IT HAS AN EXTENDED PROCESS TO OBTAIN THE POSTERIOR DENSITY TO MAKE IT -C MORE LIKELY THAT THERE WILL BE MORE THAN 1 PT. IN IT. INSTEAD OF -C JUST CALLING NPAGFULL, WHICH ALWAYS RETURNS THE SINGLE BEST POINT -C WHICH IS COMPATIBLE WITH THE "PAST", THIS PROGRAM DOES A 2-STEP -C PROCESS: - -C 1. IT CALLS NPAGFULL11, WHICH RETURNS ALL GRID PTS. FROM THE -C ORIGINAL PRIOR DENSITY WHICH ARE ARE REASONABLY COMPATIBLE WITH THE -C "PAST" (I.E., THOSE WHOSE PROBABILITIES ARE WITHIN 1.D-100 OF THE -C BEST GRID PT.). - -C 2. FOR EACH OF THE GRID PTS. IN 1., IT CALLS NPAGFULL TO OBTAIN -C THE SINGLE DAUGHTER PT. WHICH IS BEST. - -C THE RESULT THEN WILL BE A POSTERIOR CONSISTING OF THE BEST DAUGHTER -C POINT FOR EVERY GRID PT. WHICH SHOWED UP IN STEP 1. - -C----------------------------------------------------------------------- - -C BESTDOS111.FOR 5/23/13 - -C BESTDOS111 HAS THE FOLLOWING CHANGES TO BESTDOS110: - -C 1. IT GIVES THE USER THE OPTION OF NOT CALCULATING THE BEST DOSES -C TO MINIMIZE THE EXPECTED WEIGHTED SUM OF SQUARES OF DIFFERENCES -C BETWEEN OBSERVED AND TARGET CONCENTRATIONS, AND INSTEAD SIMPLY USING -C THE DOSES INCLUDED IN THE "FUTURE" FILE. I.E., WHEN ELDERY IS CALLED, -C THE DOSES IN THE "FUTURE" FILE ARE INITIAL GUESSES FOR THE DOSES TO -C BE USED BY ELDERY IN ITS OPTIMIZATION. BUT IF THE STEP(.) VALUES ARE -C SET = 0, THERE WILL BE NO OPTIMIZATION, AND THE STARTING DOSES WILL -C BE THE DESIRED DOSES TO BE USED. - -C 2. ADDITONAL INFORMATION IS ADDED TO THE DOSEROUTxxxx OUTPUT FILE. -C THE PARAMETER VALUES FOR EACH OF THE GRID POINTS USED FOR THE -C CALCULATION OF THE OBSERVED VALUES IS NOW INCLUDED.` - -C 3. IN SUBROUTINE AFTERCOMMA, OPEN(57) IS REPLACED BY -C OPEN(57, FILE='FILE57JUNK'). THE REASON IS THAT WHEN THIS PROGRAM IS -C COMPILED/LINKED WITH gfortran, IT RANDOMLY PRODUCES AN ERROR RELATED -C TO BEING UNABLE TO OPEN FILE 57. OPENING 57 AS A NAMED FILE MAY - -C REDUCE OR ELIMINATE THIS ERROR. - - -C----------------------------------------------------------------------- - -C BESTDOS110.FOR 5/14/13 - -C BESTDOS110 HAS ONE CHANGE FROM BESTDOS109. IN BESTDOS109, THE BLOCK - -C OF PREDICTED (SIMULATED) VALUES AND AUCs INCLUDED ALL THE DOSE -C AND OBSERVATION TIMES THAT WERE IN BOTHFILES.ZPJ (IF THERE WAS A -C "PAST" HISTORY), OR THE DOSE AND OBSERVATION TIMES IN THE "FUTURE" -C IF THERE WAS NO PAST HISTORY. EITHER WAY, THE OBSERVATION TIMES OF -C THE "PAST" WERE NOT INCLUDED. IN BESTDOS110, HOWEVER, THE -C OBSERVATION TIMES FROM THE "PAST" WILL ALSO BE INCLUDED IN THE -C SIMULATED VALUES. THIS REQUIRED CHANGES IN MAIN, MAKETMP, AND -C CALCTPRED, WHERE VALUES FOR M41 (AND TIM41(.)) ARE NOW SHARED. - -C----------------------------------------------------------------------- - -C BESTDOS109.FOR 5/12/13 - -C BESTDOS109 HAS THE FOLLOWING CHANGE TO BESTDOS108: - -C IN EACH BLOCK OF PREDICTED VALUES AND AUCs WHICH ARE WRITTEN TO THE -C OUTPUT FILE, DOSEROUTxxxx, EXTRA LINES OF DATA ARE ADDED AS NEEDED TO -C MAKE SURE THAT THE TIMES INCLUDE ALL OBSERVATION TIMES AND ALL DOSE -C TIMES. LOTS OF CODE CHANGES ARE MADE IN SUBROUTINE CALCTPRED, AND -C IN MAIN WHERE THESE VALUES ARE WRITTEN TO THE OUTPUT FILE. - -C NOTE THAT ALL THE CODE RELATED TO STEADY STATE DOSE SETS, AND TIME -C RESETS HAS NOW BEEN REMOVED FROM THIS PROGRAM. - - -C----------------------------------------------------------------------- - -C BESTDOS108.FOR 4/24/13 - -C BESTDOS108 HAS THE FOLLOWING CHANGES TO BESTDOS107: - -C 1. CORDLAST IS DIMENSIONED AS AN ARRAY IN THIS MODULE. SINCE IT IS AN -C ARGUMENT TO NPAGFULL, WHERE IT IS DIMENSIONED, IT SHOULD ALSO BE -C DIMENSIONED IN THIS MODULE. SINCE NO INFORMATION IS PASSED BETWEEN -C THE TWO MODULES (IT IS ONLY PASSED AS AN ARGUMENT SO IT CAN BE -C VARIABLY DIMENSIONED0, THIS OVERSIGHT DID NOT CAUSE A PROBLEM WHEN -C THIS PROGRAM WAS COMPILED/LINKED BY LAHEY FORTRAN; BUT IT DOES CAUSE -C A PROBLEM WHEN gfortran COMPILES/LINKS THIS PROGRAM. - -C 2. TWO CALLS TO READBLOCK2 IN SUBROUTINE VERIF1 HAVE BEEN CHANGED TO -C HAVE ARGS. OF C0P,...,C3P, RATHER THAN C0,...,C3 BECAUSE THESE -C ARGUMENTS ARE SUPPOSED TO BE ARRAYS. THE ACTUAL VALUES SUPPLIED TO -C READBLOCK2 AT THIS POINT ARE UNIMPORTANT, BUT MAKING THE ARGUMENTS -C ARRAYS REMOVES A WARNING WHEN THIS PROGRAM IS COMPILED BY gfortran. - -C 3. TWO CALLS TO STACK IN MAIN USE TMPFILE AS AN ARGUMENT, BUT TMPFILE -C IS *13 RATHER THAN *20, WHICH IS THE SIZE OF THE RECEIVING ARGUMENT. - -C SO PATFIL*20 IS ADDED TO THIS MAIN MODULE, SET = TMPFILE BEFORE THE -C CALLS TO STACK, AND REPLACES TMPFILE AS THE ARGUMENT IN THE CALLS TO -C SUBROUTINE STACK. - -C----------------------------------------------------------------------- - -C BESTDOS107.FOR 4/7/13 - -C BESTDOS107 HAS THE FOLLOWING CHANGES FROM BESTDOS106: - -C THE OUTPUT FILE WILL INCLUDE MORE INFORMATION. FOR EACH GRID PT. -C IN THE PARAMETER DENSITY, NOT ONLY WILL ALL THE TARGET OBSERVATIONS -C BE WRITTEN (AS IN PREVIOUS PROGRAMS), BUT ALSO ALL OBSERVATIONS WILL -C BE WRITTEN EVERY IDELTA MINUTES (IDELTA = 15 BY DEFAULT, BUT CAN BE -C CHANGED BY THE USER); AND THE SAME APPLIES TO AUCs. AND, THESE SAME -C VALUES WILL BE WRITTEN FOR THE WEIGHTED MEAN OVER ALL THE GRID POINTS -C IN THE PARAMETER DENSITY. - -C THIS MEANS THAT idm3x14.f WILL NOW BE LINKED TO THIS PROGRAM SO THAT -C SUBROUTINE IDCALCYY AN BE CALLED JUST AS IT IS IN npageng22.f TO -C FIND PREDICTED VALUES IDELTA MINUTES APART. - -C NOTE THAT FORMAT 1416 IN MAIN IS ADDED TO WARN THE USER THAT THIS -C PROGRAM IS NOT COMPATIBLE WITH STEADY STATE DOSE SETS OR TIME -C RESETS. - -C----------------------------------------------------------------------- - -C BESTDOS106.FOR 3/26/13 - -C BESTDOS106 HAS THE FOLLOWING CHANGES FROM BESTDOS105: - -C 1. RATHER THAN BEING LINKED WITH NPAGBAY.FOR, IT WILL BE LINKED WITH -C NPAGFULL.FOR. THE DIFFERENCE IN THE TWO ROUTINES IS THAT, GIVEN THE -C INPUT DENSITY IN NPAGDENFILE, NPAGBAY CALCULATES THE 0-CYCLE -C BAYESIAN POSTERIOR OF A SUBJECT, WHEREAS NPAGFULL CALCULATES THE FULL -C POSTERIOR OF THE SUBJECT, UP TO A MAXIMUM OF MAXCYC CYCLES. - -C NOTE THAT IN ADDITION TO NPAGFULL.FOR, THIS PROGRAM WILL BE LINKED -C WITH BLASNPAG.FOR (WHICH IS NEEDED BY NPAGFULL.FOR) ... AND SEE -C OTHER MODULES BELOW. - -C 2. THIS PROGRAM HAS BEEN BROUGHT UP TO THE LEVEL OF THE OTHER -C POPULATION PROGRAMS (CURRENTLY NPAG110.FOR/npageng22.f AND -C IT2B108.FOR/it2beng22.f), EXCEPT IT STILL DOES NOT ACCOMMODATE -C STEADY STATE DOSES. - -C IN PARTICULAR THIS PROGRAM WILL BE LINKED WITH IDM1X14.FOR, RATHER -C THAN IDM1X6.FOR, SHIFT9.FOR, RATHER THAN SHIFT6.FOR; AND - -C CALCBST10.FOR, RATHER THAN CALCBST9.FOR. - - -C NOTE THAT USERS SHOULD START USING TSTMULTK.FOR RATHER THAN -C TSTMULTI.FOR. SEVERAL FORMATS IN THE PROGRAM IN MAIN AND VERIF1 -C NOW REFER TO TSTMULTK.FOR RATHER THAN TSTMULTI.FOR. - -C ALSO ALL DIMENSIONS OF 500 RELATED TO DOSES HAVE BEEN CHANGED TO -C 5000. - -C 3. A BUG IS CORRECTED IN SUBROUTINE CSVCHANGE. PREVIOUSLY, IF A .CSV -C FILE HAD AN IDEVENT = 4 WITH IADDL > 0 (I.E., REPEATED DOSES STARTING - -C WITH A DOSE RESET EVENT), CSVCHANGE WOULD IMPROPERLY WRITE IADDL -C REPEATED DOSE LINES TO FILE 66 ALL WITH IDEVENT = 4. IN FACT, THESE -C REPEATED LINES MUST, OF COURSE, HAVE IDEVENT = 1 (SINCE THEY ARE -C REGULAR DOSE LINES, NOT MORE DOSE RESET LINES). - - - -C SUMMARY: THIS PROGRAM WILL BE LINKED WITH NPAGFULL.FOR, BLASNPAG.FOR, -C CALCBST10.FOR, SHIFT9.FOR, IDM1X14.FOR, AND THE DESIRED MODEL FILE. - -C----------------------------------------------------------------------- - -C BESTDOS105.FOR 3/2/13 - -C BESTDOS105 HAS THE FOLLOWING CHANGES FROM BESTDOS104: - -C IN BESTDOS104, IPRIOR WAS 1 (WHICH MEANS THAT THE USER HAD A .MM -C FILE TO BE USED DIRECTLY AS THE DENSITY FOR THE OPTIMIZATION) OR -C IPRIOR = 0 (WHICH MEANS THAT THE USER STARTED WITH A JOINT DENSITY -C FROM A PREVIOUS NPAG RUN, DENxxxx, ALONG WITH A FILE GIVING INFO -C FROM A SUBJECT'S PAST, PASTFILEIN; AND THEN SUBROUTINE NPAGBAY WOULD -C BE CALLED TO OBTAIN THE BAYESIAN POSTERIOR OF THE NEW PATIENT, WHICH -C IS THEN THE DENSITY FOR THE OPTIMIZATION). SEE BESTDOS101.FOR NOTES. -C IN EITHER CASE, THE PROGRAM WOULD THEN OPTIMIZE THE DOSES TO GIVE -C THE OBSERVED VALUES (AS CLOSELY AS POSSIBLE) IN THE FILE, -C FUTUREFILEIN. - -C IN BESTDOS105, IPRIOR WILL NO LONGER BE USED BECAUSE THERE WILL NO -C LONGER BE AN IPRIOR = 1 OPTION (I.E., THE USER WILL NEVER START WITH -C A DENSITY READY TO USE FOR THE OPTIMIZATION; INSTEAD HE WILL ALWAYS -C START WITH A DENxxxx FILE FROM AN NPAG RUN ON A POPULATION). BUT WHAT -C WAS THE OLD IPRIOR = 0 OPTION, WILL BE CHANGED AND EXPANDED TO ALLOW -C THE FOLLOWING 3 CASES: - -C a. THE USER WILL HAVE A "PAST" FILE (PASTFILEIN) AND IT WILL CONTAIN -C DOSES AND OBSERVATIONS FROM THE PATIENT'S PAST. -C b. THE USER WILL HAVE A "PAST" FILE (PASTFILEIN) BUT IT WILL ONLY -C CONTAIN DOSES (I.E., NO OBSERVATIONS) FROM THE PATIENT'S PAST. -C c. THE USER WILL NOT HAVE A "PAST" FILE (PASTFILEIN). NOTE THAT IN -C THIS CASE, INCLUDPAST (A NEW PARAMETER) WILL BE 0. - -C IN CASE a., THE PROGRAM WILL RUN SIMILARLY TO BESTDOS104 - IT WILL -C USE SUBROUTINE NPAGBAY TO OBTAIN THE BAYESIAN POSTERIOR DENSITY FOR -C THE PATIENT BASED ON DENxxxx AND PASTFILEIN, AND THIS DENSITY WILL -C BE THE ONE USED FOR THE OPTIMIZATION. IN CASES b. AND c., DENxxxx -C WILL NOT BE UPDATED (SINCE THERE ARE NO "PAST" OBSERVATIONS FOR THE -C PATIENT), BUT WILL ITSELF BE THE DENSITY USED FOR THE OPTIMIZATION. - -C NOTE THAT IN CASE c., THE LOGIC WILL PROCEED SIMILAR TO THE - -C IPRIOR = 1 CODE IN BESTDOS104; I.E., THE DENSITY TO BE USED FOR THE -C OPTIMIZATION WILL BE READ FROM DENxxxx AND THEN THE OPTIMIZATION WILL -C TAKE PLACE OVER THE DOSES IN FUTUREFILEIN (USING THE OBSERVED VALUES -C IN FUTUREFILEIN AS TARGETS). BUT IN CASES a. AND b., THE LOGIC WILL -C BE DIFFERENT THAN THAT FOR IPRIOR = 0 IN BESTDOS104. NOW, THE FILE -C IN FUTUREFILEIN IS CONCATENATED AT THE END OF THE "PAST" FILE, -C PASTFILEIN (ACTUALLY ONLY THE DOSES, NOT THE OBSERVED VALUES OF -C PASTFILEIN ARE NEEDED), WITH ALL ITS TIMES INCREASED BY "TNEXT" HOURS -C (TNEXT IS A NEW VALUE WHICH IS INPUT TO THE RUN IN THE INSTRUCTION -C FILE OR BY KEYBOARD ENTRY). THEN THE OPTIMUM DOSES IN THE "FUTURE" -C ARE FOUND TO GIVE THE OBSERVED VALUES IN THE "FUTURE", BUT GIVEN THAT -C THE "PAST" DOSES IN PASTFILEIN OCCURRED FIRST. I.E., WITH IPRIOR = 0 -C IN BESDOS104, IT WAS ASSUMED THAT ALL THE COMPARTMENT AMOUNTS STARTED -C AT 0 (OR WERE GIVEN BY SUBROUTINE GETIX) WHEN FUTUREFILEIN WAS -C OPTIMIZED OVER TO GIVE THE BEST DOSES. NOW, THE COMP. AMOUNTS AT THE -C START OF THE "FUTURE" WILL BE WHATEVER THE PROGRAM SIMULATES THEM TO -C BE AT THE TIME, TNEXT. NOTE THAT THE PROGRAM WILL KNOW TO OPTIMIZE -C ONLY OVER THE DOSES IN THE "FUTURE" OF THE PATIENT, TO GIVE THE -C OBSERVED VALUES IN THE "FUTURE" ... USING THE DOSES WHICH WERE IN THE - -C "PAST" AS GIVEN VALUES. - -C ALSO, SINCE THE INFORMATION IN THE INSTRUCTION FILE HAS BEEN CHANGED, -C THE NEW CODE FOR A SAVED INSTRUCTION FILE WILL BE BESTDOS MAR_13, AND -C NO PREVIOUS VERSIONS OF THE INSTRUCTION FILE WILL BE ALLOWED (I.E., -C IT WILL NOW ALWAYS BE ASSUMED THAT THE USER STARTS WITH AN -C NPAGDENFILE (DENSITY FROM AN NPAG RUN), WHICH MAY OR MAY NOT BE -C UPDATED (DEPENDING ON THE VALUES OF INCLUDPAST AND IPRIOROBS) AND -C WILL NEVER HAVE A MATLAB TYPE FILE (THE OLD IPRIOR = 1 OPTION) WITH -C DENSITY VALUES. - -C NOTE THAT I HAD TO INCLUDE MAXOBDIM AS A CALLING ARGUMENT TO VERIF1 -C SINCE IT MUST PROVIDE THIS DIMENSION TO SUBROUTINE INSPECTOBS. - - - -C NOTE THAT THE FOLLOWING TWO CHANGES ARE NOT IN THIS PROGRAM, BUT WILL -C BE PUT INTO THE NEXT VERSION OF THIS PROGRAM - -C - THE OUTPUT FILE WILL INCLUDE MORE INFORMATION. FOR EACH GRID -C PT. IN THE PARAMETER DENSITY, NOT ONLY WILL ALL THE TARGET -C OBSERVATIONS BE WRITTEN (AS IN PREVIOUS PROGRAMS), BUT ALSO ALL -C OBSERVATIONS WILL BE WRITTEN EVERY IDELTA MINUTES (IDELTA = 15 BY -C DEFAULT, BUT CAN BE CHANGED BY THE USER); AND THE SAME APPLIES TO -C AUCs (SINCE TIME 0 AND SINCE THE LAST DOSE). AND, THESE SAME -C VALUES WILL BE WRITTEN FOR THE WEIGHTED MEAN OVER ALL THE GRID -C POINTS IN THE PARAMETER DENSITY. - -C - AT THE END OF THE RUN, THE USER WILL SEE WHAT THE FUTURE OPTIMUM -C DOSES ARE, AND THEN BE ABLE TO CHANGE THEM AND SEE WHAT THE - -C RESULTING OBSERVED VALUES AND AUCs IN THE FUTURE WOULD BE. - -C----------------------------------------------------------------------- - -C BESTDOS104.FOR 2/17/13 - -C BESTDOS104 HAS THE FOLLOWING CHANGES TO BESTDOS103A: - -C THIS VERSION OPTIMIZES OVER ALL DOSES, BOLUSES AS WELL AS IV'S. -C BESTDO103 ASSUMED THAT THE BOLUSES WERE FIXED AT THE VALUES IN THE -C PATIENT'S DOSAGE REGIMEN, AND THE OPTIMIZATION WAS TO TAKE PLACE ONLY -C OVER THE IV'S. BUT BESTDOS104 OPTIMIZES OVER ALL DOSES. - -C THE REQUIRED CHANGES ARE MADE IN MAIN AND FILRED (AND NOTE THAT -C SIG HAS BEEN ADDED AS A CALLING ARGUMENT TO FILRED) OF THIS MODULE, -C AND IN CALCBST8.FOR, UPDATED FROM CALCBST7.FOR. - -C AND NOTE THAT THE FORMAT OF HOW THE BEST DOSES ARE WRITTEN TO -C DOSEROUTxxxx IS CHANGED. - -C----------------------------------------------------------------------- - -C BESTDOS103A.FOR 2/10/13 - -C BESTDOS103A HAS THE FOLLOWING CHANGES FROM BESTDOS103: - -C CAUTION: THIS PROGRAM DOES ALLOW THE NEW .CSV FORMAT AS DESCRIBED -C BELOW. BUT THIS IS ONLY TO ALLOW IT TO BE RUN WITH PATIENTS WHICH -C HAVE THEIR INFO IN THIS FORMAT, BUT DO NOT ACTUALLY HAVE STEADY STATE -C DOSES. THOSE PATIENTS WHICH HAVE STEADY STATE DOSE SETS WILL NOT -C BE RUNNABLE WITH THIS PROGRAM SINCE NEWER CODE IS REQUIRED IN THE -C NPAGBAY.FOR, SHIFT6.FOR, AND IDM1X6.FOR MODULES (THESE MODULES WERE -C ALL COMPLETELY BEFORE 6/15/11, AND THE STEADY STATE DOSE SETS WERE -C PUT INTO THE POPULATION PROGRAM STARTING WITH NPAG104.FOR, WHICH -C IS DATED 1/18/12. - -C SO IF THE USER TRIES TO USE A PATIENT WITH ADDL > 0 OR -1, THE -C PROGRAM WILL PRINT A MESSAGE AND STOP (SEE FORMAT 321 IN -C SUBROUTINE CSVCHANGE). - -C 1. IT ALLOWS A NEW VERSION OF THE .csv FILE. THIS FILE WILL HAVE -C THE CODE,"POPDATA DEC_11" AT THE TOP, RATHER THAN "POPDATA APR_11". -C THIS NEW .csv FILE WILL HAVE TWO EXTRA COLUMNS, ADDL AND II, WHICH -C ALLOW THE USER TO SPECIFY THAT THE CURRENT DOSE LINE IS TO BE -C REPLICATED ADDL TIMES AT AN INTERDOSE INTERVAL OF II. IF ADDL IS -C MISSING, IT IS ASSUMED TO BE 0 (WHICH MEANS THE LINE IS NOT TO BE -C REPLICATED). IF ADDL = -1, IT INDICATES A STEADY STATE DOSE SET IS -C BEGINNING WITH THAT LINE. - -C TO HANDLE THE NEW .csv FILE, A NEW SUBROUTINE, CSVCHANGE, WILL BE -C CALLED (AFTER SUBROUTINE NEWCSV IS CALLED AND BEFORE READBLOCK IS -C CALLED) TO CHANGE THE NEW .csv FILE INTO THE CORRESPONDING ONE -C WITH THE OLD FORMAT. THIS WILL MINIMIZE THE CHANGES TO SUBROUTINE -C READBLOCK, WHICH WILL STILL NEED TO BE CHANGED TO DEAL WITH -C NEGATIVE DOSE TIMES (WHICH WILL NOW INDICATE THE BEGINNING OF A -C STEADY STATE DOSE SET) - SEE CODE IN READBLOCK. - -C ALSO NOTE THAT CSVCHANGE CONVERTS SCRATCH FILE 67 TO SCRATCH FILE -C 66, WHICH MEANS THAT ALL THE READ(67,..) STATEMENTS IN READBLOCK ARE -C NOW CHANGED TO READ(66,...) STATEMENTS. SIMILARLY, THE READ(67,...) -C IN SUBROUTINE GETMAXTIM IS CHANGED TO READ(66,...). - -C SOME NOTES REGARDING THE NEW .csv FORMAT: - -C a. THE COLUMNS WILL NOW BE: -C ID,EVID,TIME,DUR,DOSE,ADDL,II,INPUT,OUT,OUTEQ,C0,C1,C2,C3,Covs if any - -C b. ADDL AND II ARE ONLY RELEVANT FOR EVID=1 AND EVID=4. FOR EVID=0, -C (OBSERVATIONS) THEY ARE IGNORED. - -C c. ADDL CONTAINS THE NO. OF ADDITIONAL DOSES TO GIVE, AT THE -C INTERDOSE INTERVAL OF II. - -C d. If ADDL IS MISSING FOR AN EVID=1 OR EVID=4 EVENT, IT IS ASSUMED -C TO BE 0 --> NO ADDITIONAL DOSES ARE GIVE. IN THIS CASE, II IS -C IRRELEVANT. - -C e. IF ADDL > 0, THEN ADDL ADDITIONAL DOSES ARE GIVEN (I.E., A TOTAL -C OF ADDL + 1) AT INTERVAL II. A MISSING II IN THIS CASE WILL RESULT -C IN THE PROGRAM STOPPING WITH AN ERROR MESSAGE TO THE USER. - -C f. ADDL > 0 CAN OCCUR ON ANY DOSE EVENT, BUT ADDL = -1 (A STEADY -C STATE DOSE INDICATOR) CAN ONLY OCCUR AT T = 0 AT THE BEGINNING OF -C A PATIENT'S FILE, OR AT A DOSE RESET TIME. - -C 2. IN SUBROUTINE TIMESET, THE FIRST TIME IN THE DOSAGE BLOCK FOR EACH -C SUBJECT IS NO LONGER TESTED TO MAKE SURE IT IS 0. THE REASON, OF -C COURSE, IS THAT NOW THE FIRST TIME MAY BE NEGATIVE (WHICH SIGNIFIES -C THAT THE DOSAGE REGIMEN BEGINS WITH A STEADY STATE OF DOSES). - -C 3. A NEW SUBROUTINE CONVERTCSV IS CALLED BEFORE EACH CALL TO -C SUBROUTINE NEWCSV TO CONVERT, IF NECESSARY, A "EUROPEAN" VERSION OF -C A .CSV FILE TO THE FORM READBLOCK EXPECTS. IN THE "EURO" VERSION, THE -C FIELD SEPARATORS ARE SEMICOLONS, RATHER THAN COMMAS, AND THE -C CHARACTER USED TO SEPARATE THE WHOLE PART OF A NUMBER FROM THE -C FRACTIONAL PART IS A COMMA, RATHER THAN A PERIOD. TO DO THIS REQUIRES -C READING THE SECONDS LINE OF THE .CSV FILE (THE FIRST LINE HAS THE -C VERSION CODE) AND CHECKING FOR SEMICOLONS. IF THERE ARE ANY, THEN THE -C FILE IS CHANGED SO THAT, IN ORDER, ALL COMMAS ARE CHANGED TO PERIODS, -C AND THEN ALL SEMICOLONS ARE CHANGED TO COMMAS. NOTE THAT, EVEN IN THE -C "EURO" VERSION, IT WILL STILL BE ASSUMED THAT A DOT REPRESENTS -C A MISSING (OR UNNEEDED) VALUE. - -C NOTE THAT BLOCKPAT IS NOW OPENED AS SCRATCH FILE 87. THEN CONVERTCSV -C WRITES THIS FILE AS THE CORRECTED VERSION TO SCRATCH FILE 77. THEN, -C ROUTINE NEWCSV CONVERTS THIS FILE TO SCRATCH FILE 67. THEN ROUTINE -C CSVCHANGE CONVERTS THIS FILE TO SCRATCH FILE 66, WHICH IS READ BY -C ROUTINE READBLOCK. - -C----------------------------------------------------------------------- - -C BESTDOS103.FOR 8/15/11 - -C BESTDOS103 HAS THE FOLLOWING CHANGES TO BESTDOS102: - -C 1. THE ACTIVE (SALT) FRACTION, AF, WILL NOW BE A VECTOR. PREVIOUSLY, -C IT WAS ASSUMED THAT ALL DRUGS HAD THE SAME AF; NOW EACH DRUG WILL -C HAVE ITS OWN. - -C THE ABOVE CHANGE MEANS THAT THE NEW VERSION OF THE INSTRUCTION FILE -C (OR 'GUICMDS.INX' IF IT EXISTS IN THE WORKING DIRECTORY) WILL HAVE -C A NEW CODE, 'BESTDOS SEP_11', AND BE ACCOMPANIED BY A NEW ICODE = 4. -C THEN AS THE INSTRUCTIONS ARE BEING READ IN, IF ICODE = 4, THE PROGRAM -C WILL KNOW TO READ IN AF(I),I=1,NDRUG, RATHER THAN JUST AF. THIS ALSO -C REQUIRES CHANGES WHERE INSTRUCTION FILE IS BEING SAVED FOR A - -C SUBSEQUENT RUN. - -C NOTE THAT IN OLDER INSTRUCTION FILES, ALL AF(I), I=1,NDRUG, WILL -C BE SET = THE INPUT VALUE OF AF (NOW CALLED AFSCALAR). - -C NOTE THAT THE OUTPUT FILE WILL ALSO NOW HAVE AF(I),I=1,NDRUG WRITTEN -C TO IT, RATHER THAN JUST AF. - - -C NOTE THAT SUBROUTINE GETNUMEQ HAS BEEN EXPANDED TO ALSO OBTAIN THE -C NO. OF DRUGS, NDRUG, SINCE THIS VALUE IS NEEDED BEFORE -C AF(I),I=1,NDRUG ARE READ VIA THE KEYBOARD. ALSO GETNUMEQ IS NOW -C CALLED BEFORE VERIFI1 IS CALLED TO OBTAIN NDRUG SO THAT IF ONLY -C AFSCALAR WAS READ IN (I.E., IN AN OLDER INSTRUCTION FILE), ALL THE -C AF(I),I=1,NDRUG CAN BE SET = AFSCALAR. - -C 2. CODE IN SUBROUTINE STACK IS CHANGED WHERE THE RS(.,.) VALUES ARE -C MULTIPLIED (NOW) BY AF(.). - -C----------------------------------------------------------------------- - -C BESTDOS102.FOR 6/22/11 - -C BESTDOS102 HAS THE FOLLOWING CHANGES TO BESTDOS101: - -C 1. SUBROUTINE GETERRGAM IS REMOVED BECAUSE IERRMOD AND GAMLAM ARE -C NOW INPUT FROM THE USER VIA THE INSTRUCTION FILE OR KEYBOARD, ALONG -C WITH OTHER INPUT INFO. - -C NOTE THAT I CORRECTED A SUBTLE BUG IN THE CODE REGARDING GAMLAM0, -C THOUGH THIS BUG REMAINS FOR NOW IN THE NPAG100 PROGRAM (IF MAXCYC -C = 0). TECHNICALLY, WHEN THE BAYESIAN DENSITY FOR A SET OF SUBJECTS -C IS FOUND FROM A PRIOR DENSITY, AND IERRMOD .GE. 2, THE VALUE OF -C GAMLAM USED SHOULD BE THE FINAL ESTIMATE AT THE END OF THE -C PRIOR RUN, NOT THE INITIAL ESTIMATE WITH WHICH THE NPAG RUN -C STARTED. FOR EXAMPLE, IF IERRMOD = 2 AND GAMLAM0 = 1, BUT THE FINAL -C ESTIMATE FOR GAMMA = 5, IT MEANS THAT THE ASSAY C'S USED WOULD HAVE -C BEEN BETTER IF THEY HAD BEEN MULTIPLIED BY 5 FROM THEIR ORIGINAL -C VALUES. AND THIS INFORMATION SHOULD BE USED GOING FORWARD WHEN - -C GETTING THE BAYESIAN POSTERIORS FOR A NEW SET OF SUBJECTS. IN -C BESTDOS102, IT IS MADE CLEAR WHEN THE USER ENTERS GAMLAM, HE IS -C ENTERING THE FINAL ESTIMATED VALUE FROM THE ORIGINAL NPAG RUN ON THE -C ENTIRE POPULATION, NOT THE INITIAL ESTIMATE AS IS IMPLIED IN -C BESTDOS101. TO EMPHASIZE THIS, THE TERM USED IS GAMLAM, NOT GAMLAM0. - - -C 2. WHEN THE PROGRAM IS RUN, IT WILL FIRST SEARCH FOR THE FILE, -C 'GUICMDS.INX' IN THE SAME DIRECTORY AS BESTDOS102.EXE. IF IT FINDS -C THIS FILE, IT WILL OPEN IT AND READ IN ALL THE INPUT INSTRUCTIONS, -C AND RUN WITH NO USER INTERACTION AT ALL. IF THE FILE DOES NOT EXIST, -C THE PROGRAM WILL PROCEED AS BEFORE, ASKING THE USER TO INPUT -C INSTRUCTIONS VIA AN INSTRUCTION FILE OR THE KEYBOARD. - -C NOTE THAT IF 'GUICMDS.INX' EXISTS, THE FINAL ARGUMENT (WHICH IS NEW) -C TO READBLOCK2 IS 1 (SEE CODE IN SUBROUTINE READBLOCK2 REGARDING IGUI -C AND READING ICOVTYPE IN THAT CASE). - -C 3. THE PATH IS NOW ALSO INCLUDED IN THE OUTPUT FILE. - -C----------------------------------------------------------------------- - -C BESTDOS101.FOR 6/17/11 - -C BESTDOS101 IS A MAJOR REVISION TO BESTDOS100. THIS NEW PROGRAM ALLOWS -C AN ADDITIONAL LEVEL OF COMPLEXITY TO THE ANALYSIS. IN BESTDOS100, THE -C USER ALREADY HAD AVAILABLE HIS PRIOR JOINT DENSITY FILE (SEE CODE FOR -C MATFIL). - -C IN BESTDOS101, HOWEVER, THE USER MAY NOT ALREADY HAVE THIS INFO. -C INSTEAD, HE MAY START WITH A JOINT DENSITY FROM AN NPAG RUN, ALONG -C WITH A "PAST HISTORY" FOR A NEW SUBJECT (EITHER A WORKING COPY FILE -C OR A .CSV FILE). IN THIS CASE, THE PROGRAM WILL CALL A SHORTENED -C VERSION OF npagengxx.F (NPAGBAY) WHICH WILL OBTAIN THE BAYESIAN -C POSTERIOR JOINT DENSITY OF THIS NEW SUBJECT ... WHICH WILL THEN BE -C THE PRIOR JOINT DENSITY FILE FOR THE BEST DOSE CALCULATIONS. - -C NOTE THAT IN THIS LATTER CASE, THE NEW SUBJECT'S "PAST HISTORY" INFO - -C (I.E., THE DOSING REGIMEN AND OBSERVED VALUE TIMES AND LEVELS) MAY -C BE DIFFERENT THAN THE REGIMEN OVER WHICH THE BEST DOSES WILL BE -C OBTAINED IN THE FUTURE. THIS MEANS THAT THE "FUTURE" INFO FOR THIS -C NEW SUBJECT WILL HAVE TO BE ENTERED SEPARATELY FROM THE "PAST" INFO, -C AND THIS MEANS THAT THE INSTRUCTION FILE WILL BE EXPANDED TO INCLUDE -C THIS INFO. BECAUSE OF THIS, THE INSTRUCTION FILE WILL HAVE A NEW - -C CODE, BESTDOS JUL_11. - -C NOTE THAT VODTOT.FOR WILL NO LONGER BE LINKED INTO THIS PROGRAM -C SEPARATELY. INSTEAD, THE MODULE NPAGBAY WILL CONTAIN A VERSION OF -C VODTOT.FOR THAT HAS A FEW CHANGES TO BE COMPATIBLE WITH ANDREAS' -C INTEL COMPILER. - -C NOTE ALSO THAT NPAGBAY REQUIRES SUBROUTINE SUBRES WHICH CALLS -C SUBROUTINE IDPC, AND THIS MEANS THAT MODULE IDM1X6.FOR (THE SAME -C AS idm1x6.f IN npageng13.f) WILL NOW BE LINKED TO THIS PROGRAM. -C BECAUSE OF THIS, AND THE FACT THAT IDM1X6.FOR HAS ROUTINES USERANAL - -C AND JACOB, CALCBST6.FOR WILL BE REPLACED BY CALCBST7.FOR, WHICH -C DOES NOT HAVE THESE ROUTINES. - -C SO HERE ARE THE MAJOR STEPS OF THIS PROGRAM: - - - -C 1. USER ENTERS A MODEL FILE WHICH IS ALREADY LINKED WITH THIS -C PROGRAM. - -C 2. USER SELECTS WHETHER HE ALREADY HAS PRIOR DENSITY (IPRIOR = 1 -C --> YES; IPRIOR = 0 --> NO). - -C 3. IF IPRIOR = 1, THE PROGRAM USES THE SAME LOGIC AS IN -C BESTDOS100. - -C 4. IF IPRIOR = 0, USER ENTERS THE JOINT DENSITY FILE FROM A -C PREVIOUS NPAG RUN, ALONG WITH INFO WITH ANOTHER SUBJECT'S "PAST" -C DATA (VIA EITHER A WORKING COPY FILE OR .CSV FILE). - -C THEN NEW SUBROUTINE NPAGBAY (BASED ON THE CODE IN npageng13.f -C WHEN MAXCYC = 0) IS CALLED TO OBTAIN THE BAYESIAN POSTERIOR OF -C THE NEW PATIENT; THIS IS THE PRIOR DENSITY USER WOULD HAVE -C ENTERED DIRECTLY IN STEP 2 IF IPRIOR WAS = 1. - -C----------------------------------------------------------------------- - -C BESTDOS100.FOR 6/4/11 - -C BESTDOS100 HAS THE FOLLOWING CHANGES FROM BESTDOS8: - -C 1. IT IS BROUGHT TO THE LEVEL OF THE OTHER '100' PROGRAMS, NPAG100, -C IT2B100, AND MONT100.FOR. IN PARTICULAR, NEW SUBROUTINES READBLOCK2, -C ETC. ARE ADDED SO THAT THE DOSE REGIMEN, AND OBSERVED VALUE BLOCK -C CAN BE INPUT VIA A .CSV FILE, RATHER THAN A WORKING COPY FILE. THE -C FORMAT OF THIS .CSV FILE WILL BE THE UPDATED ONE REFERRED TO IN THE -C COMMENTS AT THE TOP OF THE OTHER '100' PROGRAMS SPECIFIED ABOVE. - - -C 2. WT AND CCR ARE NO LONGER TREATED AS SPECIAL COVARIATES. SO -C ALL OCCURRENCES OF 2 + NADD WILL NOW BE REPLACED BY NADD. THIS ALSO -C MEANS THAT THE MODEL FILE MUST NOW BE AN EDITED VERSION OF THE -C TEMPLATE MODEL FILE, TSTMULTI.FOR (UPDATED FROM TSTMULTH.FOR. - -C 3. SHIFT5.FOR WILL BE REPLACED BY SHIFT6.FOR (SAME AS SHIFT6.F IN -C npageng13.f PROGRAM), WHICH IS REQUIRED FOR THE CHANGES RELATED TO -C WT AND CCR NO LONGER BEING CONSIDERED SPECIAL COVARIATES. NOTE THAT -C THE OTHER MODULES, CALCBST6.FOR AND VODTOT.FOR, ARE UNCHANGED. - - -C 4. THERE WILL BE A NEW CODE FOR THE INSTRUCTION FILE, -C 'TESTDOS JUN_11', AND ALL PREVIOUS VERSIONS OF INSTRUCTION FILES WILL -C NO LONGER BE ALLOWED. THE MAIN DIFFERENCES ARE THAT MORE INFO WILL BE -C STORED (INCLUDING THE MODEL FILENAME, THE O.D.E. TOLERANCES, AND THE -C NAME OF THE FILE WHICH HAS THE APRIORI DENSITY), AND THE FILE WILL -C ALSO HAVE TEXT DESCRIBING WHAT INFO IS INPUT. - -C 5. THE OUTPUT FILE WILL NO LONGER BE HARDCODED TO BE TAR_ACH.CON. -C INSTEAD IT WILL BE DOSEROUTxxxx, WHERE xxxx WILL BE READ FROM -C FILE EXTNUM. AND THE TOP OF THE OUTPUT FILE WILL BE A RESTATEMENT -C OF ALL INSTRUCTIONS AS USUAL BEFORE THE OUTPUT VALUES WILL BE -C WRITTEN. - -C 6. A NEW FLAG, CALLED IPRINTOUT, IS HARDCODED TO BE 1, WHICH MEANS -C THAT THE OUTPUT INFO (SEE FORMAT 1234 IN SUBROUTINE ELDERY) IS -C PRINTED TO THE SCREEN AS USUAL. THIS IS DONE IN ANTICIPATION OF THIS -C PROGRAM BEING RUN AS AN "ENGINE" CALLED BY ANDREAS' GUI. IN THAT -C CASE, IPRINTOUT CAN BE RESET = 0, WHICH WILL SUPPRESS THE INFO IN - -C FORMAT 1234 FROM BEING WRITTEN TO THE SCREEN. - - -C 7. ALL THE PAUSE STATEMENTS ARE NOW CHANGED TO CALL PAUSE STATEMENTS, -C AND NEW SUBROUTINE PAUSE IS ADDED TO THE PROGRAM. THIS IS DONE SINCE -C A REGULAR PAUSE STATEMENT CAUSES WARNINGS WHEN THIS PROGRAM IS -C COMPILED AND LINKED USING gfortran (AND FORCES THE USER TO TYPE "go" -C INSTEAD OF SIMPLY HITTING THE ENTER KEY). - -C----------------------------------------------------------------------- - -C BESTDOS8.FOR 1/27/11 - -C BESTDOS8 HAS THE FOLLOWING CHANGES FROM BESTDOS7: - -C 1. FORMATS 919 AND 5001 ARE CHANGED TO EXPLAIN TO THE USER THAT HIS -C FORTRAN MODEL FILE, LINKED INTO THIS PROGRAM, MUST BE AN EDITED -C VERSION OF TSTMULTH.FOR. THE PREVIOUS LANGUAGE WAS OUTDATED (SINCE -C THE BOXES PROGRAM HAS NOT BEEN UP TO DATE FOR A LONG TIME). - - -C 2. IT IS COMPILED WITH CALCBST6.FOR, RATHER THAN CALCBST5.FOR, AND -C A MODEL FILE BASED ON TSTMULTH.FOR, RATHER THAN TSTMULTG.FOR. THE -C OTHER PERMANENT MODULES, SHIFT5.FOR, VODTOT.FOR, ARE UNCHANGED. - -C NOTE THAT IN CALCBST6.FOR, THE CHANGES ARE IN SUBROUTINE GETPRED, -C AND, IN ADDITION TO CORRECTING A COUPLE OF BUGS, MAKE THIS PROGRAM -C COMPATIBLE WITH TSTMULTH.FOR, AS INDICATED ABOVE. - -C 3. THE CALL TO SUBROUTINE DETECT IS COMMENTED OUT. THE REASON IS -C THAT IT WILL NOW BE ASSUMED THAT THE USER CREATES HIS MODEL FILE -C FROM THE TEMPLATE MODEL FILE (CURRENTLY TSTMULTH.FOR) AND SO IT -C WILL AUTOMATICALLY HAVE THE CORRECT DECLARATION STATEMENTS AT THE -C TOP OF EACH SUBROUTINE. PLUS, THIS WILL PREVENT THIS PROGRAM FROM -C STRIPPING AWAY SPECIAL DECLARATION STATEMENTS THE USER MAY NEED TO -C ADD TO THE ROUTINES FOR SPECIAL CASE ANALYSES. - -C NOTE THAT SUBROUTINE DETECT, AND THE ROUTINES IT CALLS, WILL BE LEFT -C IN THE CODE FOR NOW (IN CASE THEY, OR MODIFIED VERSIONS OF THEM ARE -C NEEDED IN A FUTURE VERSION OF THIS PROGRAM). - -C----------------------------------------------------------------------- - -C BESTDOS7.FOR 10/15/09 - -C BESTDOS7 IS A MAJOR ENHANCEMENT TO BESTDOS6, AS FOLLOWS: - -C 1. BESTDOS6 IS LIMITED TO ONE OUPUT EQUATION AND ONE DRUG; BESTDOS7 -C ALLOWS MULTIPLE OUTPUTS AND MULTIPLE DRUGS ... TO THE LEVEL OF THE -C MULTIPLE DRUG BIG NPAG PROGRAM, NPBIG15C.FOR/bigmlt4.f. - -C 2. SEVERAL SUBROUTINES IN THIS PROGRAM ARE NOW REPLACED BY THE -C CORRESPONDING VERSIONS FROM THE CURRENT BIG NPAG POPULATION PROGRAM, -C NPBIG15C.FOR, OR ARE MODIFICATIONS OF ROUTINES FROM NPBIG15C.FOR, BUT -C ADJUSTED TO FIT THE CODE OF THIS PROGRAM. THESE ROUTINES INCLUDE: -C GETPATH, FULLNAME, PUTASS, FILRED, STACK, USERPREP, CHECKLIN, -C WRITEDIF, WRITESYM, WRITEOUT, AND SKIPLINE. SOME OF THE CHANGED CODE - -C IS MINOR (E.G., *72 BECOMES *1000); OTHER IS MAJOR. - -C NOTE THAT IN SUBROUTINE PUTASS, SUBROUTINE USECS IS NO LONGER NEEDED, -C AND SO SUBROUTINE USECS IS REMOVED FROM THE PROGRAM. - -C NOTE THAT A VERSION OF SUBROUTINE GETNUMEQ FROM NPBIG15C.FOR IS - -C ADDED TO THIS PROGRAM (IT IS CALLED BY MAIN). - -C 3. NOTE THAT THIS PROGRAM WILL REQUIRE A NEW CODE FOR THE INSTRUCTION -C FILE (TESTDOS NOV_09) SINCE THE INPUT INFO WILL BE DIFFERENT FROM -C THAT OF THE PREVIOUS PROGRAM. - - -C 4. NOTE THAT THE FORMAT FOR THE PATIENT DATA FILE WILL NOW HAVE TO BE -C THE MULTIPLE DRUG WORKING COPY FORMAT. I.E., NO BLOCK FORMAT WILL BE -C ALLOWED (UNLIKE IN NPBIG15C.FOR, THE POPULATION PROGRAM). - -C 5. THIS MODULE IS LINKED WITH CALCBST5.FOR, WHICH IS AN UPDATE FROM - -C CALCBST4.FOR. - -C 6. THIS MODULE WILL BE LINKED WITH SHIFT5.F, RATHER THAN SHIFT2.F, -C SINCE THE TEMPLATE MODEL FILE IS NOW CHANGED TO BE TSTMULTG.FOR -C (SEE DETAILS IN NPBIG15C.FOR). - -C 7. THIS PROGRAM NO LONGER LINKS IN CONVRTLO.FOR. IT IS UNNEEDED. - -C----------------------------------------------------------------------- - -C BESTDOS6.FOR 3/1/08 - -C BESTDOS6 HAS THE FOLLOWING CHANGES TO BESTDOS5: - -C 1. IN SUBROUTINE PUTASS, AT LABEL 25, THE FREE FORMAT WRITING -C LINE ... 25 WRITE(27,*) 'ASSAY COEFFICIENTS FOLLOW:' -C IS REPLACED BY A FIXED FORMAT. THIS PREVENTS EXTRA COMMAS -C BEING WRITTEN TO THE LINE WITH SOME COMPILERS. - -C 2. THIS MODULE IS LINKED WITH CALCBST4 CONVRTLO SHIFT2 VODTOT - -C AND THE USER-SUPPLIED MODEL FILE. ALL THE ROUTINES ARE THE SAME -C AS IN BESTDOS5, EXCEPT CALCBST4, WHICH IS CHANGED FROM CALCBST3 -C (DOSES ARE PREVENTED FROM BEING NEGATIVE IN SUBROUTINE CALCS. - -C----------------------------------------------------------------------- - -C BESTDOS5.FOR 9-8-03 - -C BESTDOS5 HAS THE FOLLOWING CHANGE FROM BESTDOS4: - - -C THE BEST SET OF DOSES TO MINIMIZE THE EXPECTED WEIGHTED SUM OF -C SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET CONCENTRATIONS, -C AS WELL AS THE THIS SUM OF SQUARES, AS CALCULATED BY THE CALL TO - -C SUBROUTINE ELDERY, ARE ALSO PUT INTO THE OUTPUT FILE, TAR_ACH.CON -C (PREVIOUSLY THEY WERE JUST WRITTEN TO THE SCREEN). - -C----------------------------------------------------------------------- - - -C BESTDOS4.FOR 01-05-03 - -C BESTDOS4 IS A MAJOR VARIATION OF BESTDOS3. THE MAJOR CHANGE IS THAT -C THIS PROGRAM NOW ALLOWS GENERAL MODELS WHICH CAN BE DESCRIBED BY -C DIFFERENTIAL EQUATIONS AND OUTPUT EQUATION(S) CODED BY THE USER -C INTO SUBROUTINES DIFFEQ AND OUTPUT OF FILE, npemdriv.f. I.E., THE - -C MODEL IS NO LONGER LIMITED TO THE STANDARD 3-COMPARTMENT LINEAR -C MODEL. - -C BESTDOS4 WILL BE COMPILED AND LINKED WITH CALCBST3, CONVRTLO, -C SHIFT2.F, VODTOT.F, AND npemdriv.f (WHICH THE USER EDITS AND - -C COMPLETES - npemdriv.f WILL THEN BE RENAMED SOMETHING WITH A -C .FOR EXTENSION). - -C THE CODING CHANGES REQUIRED ARE AS FOLLOWS: - - -C 1. THE I/O IS CHANGED TO BE LIKE THE OTHER "BIG" PROGRAMS (BIG NPAG - -C AND BIG IT2B), WHICH DON'T HAVE MENUS. IN PARTICULAR, THIS PROGRAM -C IS ESSENTIALLY AT THE "LEVEL" OF NPBIG10B.FOR, WHICH MEANS THAT -C ONLY A SINGLE DRUG IS ALLOWED. HOWEVER, FOR NOW, ONLY ONE OUTPUT -C EQUATION IS ALLOWED (I.E., NPBIG10B ALLOWS MULTIPLE OUTPUT EQUATIONS - -C BUT THIS PROGRAM IS LIMITED TO JUST ONE). - -C 2. THIS PROGRAM IS LINKED WITH CALCBST3.FOR (UPDATED FROM -C CALCBST2.FOR). - -C 3. NEW COMMON/FROMBEST PROVIDES THE VALUES NEEDED BY CALCBST3.FOR -C WHEN IT CALLS NEW SUBROUTINE MAKEVEC. - - -C 4. SUBROUTINE GETCOVAR IS NO LONGER NEEDED SINCE THE USER CODES -C DIRECTLY INTO SUBROUTINES DIFFEQ, OUTPUT, AND SYMBOL WHICH -C DESCRIPTORS ARE TO BE USED. - -C 5. ALL DIMENSIONS OF 150 ARE CHANGED TO 594 - TO MAKE THESE -C DIMENSIONS CONSISTENT THROUGHOUT THE PROGRAM. ALSO, THE DIMENSIONS -C FOR PAR AND PARFIX ARE CHANGED TO BE THE SAME AS IN NPBIG10B.FOR. -C IDES(16), NIND(29), AND DESCR(26)*20 ARE REMOVED. IRAN(25) IS ADDED, -C AS IS FORFILE*20. - -C 6. REMOVED COMMON/TOPAR SINCE IT IS NOW NOT APPLICABLE (I.E., IT -C PASSES TO MODULE PARADP17.FOR INFO FOR MENUS 1 AND 2 IN THE -C 3-COMPARTMENT LINEAR MODEL). NOTE THAT PARADP17.FOR IS NO LONGER -C LINKED WITH THIS PROGRAM. - -C 7. NEW I/O WHICH IS SIMILAR TO THAT IN NPBIG10B.FOR IS USED. IN -C PARTICULAR, ALL REFERENCES TO MENUS, NPAR, NFIX ARE REMOVED. BUT -C I/O FOR THE O.D.E. TOLERANCES ARE INCLUDED. - -C 8. ALL REFERENCES TO SUBROUTINES PARNAM AND PARNAM2 ARE ELIMINATED. - -C 9. IN NPBIG10B.FOR, GETNUMEQ IS CALLED TO GET NUMEQT, THE NO. OF - -C OUTPUT EQS. IN THIS PROGRAM, WE WILL ASSUME FOR NOW THAT NUMEQT -C =1, SO GETNUMEQ IS NOT INCLUDED IN THIS PROGRAM. - -C 10. SUBROUTINES DETECT, CHECKLIN, SKIPLINE, WRITEDIF, WRITEOUT, AND -C WRITESYM ARE INCLUDED (FROM NPBIG10B.FOR), BUT IVERS IS HARDCODED -C = 0 (SINCE IT WILL BE ASSUMED THAT ONLY THE BETA VERSION IS -C AVAILABLE FOR NOW). - -C 11. SUBROUTINE USERPREP IS ADDED (FROM NPBIG10B.FOR). - -C 12. NBI IS REMOVED AS AN ARGUMENT TO SUBROUTINE STACK. - -C 13. SUBROUTINE FILRED IS CHANGED TO BE LIKE THAT IN MODULE, -C bignpaglap1.f (THE .f FILE WHICH IS COMPATIBLE WITH NPBIG10B.FOR). -C IN PARTICULAR, TIM AND YO DIMENSIONS WILL CHANGE TO (594) AND -C (594,6), RESPECTIVELY; COMMON/DESCR IS BE INCLUDED; AND NTLAG IS NOW -C A PART OF COMMON/CNST. ALSO, AGE, ISEX, HEIGHT, AND IETHFLG ARE -C REMOVED FROM THE ARGUMENT LIST (SINCE COMMON/TOPAR IS N/A). - -C 14. SUBROUTINES PRINTMENU, GETIND, AND PRINTCOV ARE REMOVED. - -C 15. THE IKAMS1/IKAMS2 LOGIC TO CHECK ON COMPATIBILITY BETWEEN BOLUS -C INPUTS AND KA IS REMOVED SINCE WITHOUT INDICES, THERE IS NO WAY TO -C KNOW IF KA IS A PARAMETER. - -C 16. THE CODE FOR A SAVED INSTRUCTION FILE HAS BEEN CHANGED TO -C 'TESTDOS NOV_02'. - -C 17. THE MAXIMUM NO. OF GRID POINTS WHICH CAN BE USED (I.E., THE NO. -C OF GRID POINTS READ IN FROM THE MATLAB FILE BY BESTDOS4.FOR) IS -C CURRENTLY SET = MAXGRD = 5003. - -C 18. IN SUBROUTINE ELDERY, A NEW WRITE STATEMENT (SEE FORMAT 1234) IS -C PUT IN TO GIVE USER SOME INDICATION OF HOW CLOSE TO CONVERGENCE THE -C PROGRAM IS. - -C----------------------------------------------------------------------- - -C BESTDOS3.FOR 6-19-02 - -C BESTDOS3 IS THE SAME AS BESTDOS2 EXCEPT THAT THE LIMITATION ON THE -C MAXIMUM NO. OF DOSES (SEE FORMAT 103) HAS BEEN RESET TO 500 WHICH -C IS CORRECT (I.E., THE ONLY LIMITATION IS THE SIZE OF THE START -C AND STEP VECTORS IN THIS ROUTINE, AND SIMILAR ARRAYS IN OTHER -C ROUTINES - NOT THE ARBITRARY VALUE OF 7). NOTE THAT MAXDIM = 7 -C MEANS THAT THE MAXIMUM NO. OF MODEL PARAMETER IS 7, BUT THIS IS - -C UNRELATED TO THE MAXIMUM NO. OF DOSES ALLOWED. - -C ALSO NOTE THAT A NEW PARAMETER STATEMENT IN SUBROUTINE ELDERY IS -C NEEDED TO RESET THE DIMENSIONS OF THOSE ARRAYS WHICH ARE NOT - -C CALLING ARGUMENTS AND THEREFORE CANNOT HAVE THEIR DIMENSIONS SET -C BY THE PASSED PARAMETER N. - -C----------------------------------------------------------------------- - - -C BESTDOS2.FOR 9-29-01 - -C BESTDOS2 IS A SLIGHT EXTENSION TO BESTDOSE. THE DIFFERENCE IS THAT, -C FOR EACH GRID POINT IN THE INPUT DENSITY, THE ACHIEVED CONCENTRATIONS -C FOR THE CURRENT BEST SET OF DOSES (I.E., THOSE GIVING THE MINIMUM -C EXPSUM IN SUBROUTINE CALCS, CALLED BY ELDERY) ARE STORED IN -C COMMON/PREDVAL. THESE VALUES WILL BE STORED INTO THE FILE -C TAR_ACH.CON BEFORE THIS PROGRAM CLOSES. - -C----------------------------------------------------------------------- - -C BESTDOSE.FOR 8-24-01 - -C BESTDOSE IS A MAJOR EXTENSION TO TESTDOSE. TESTDOSE CALCULATED A - -C SINGLE EXPECTED WEIGHTED SUM OF SQUARES (SEE BELOW) FOR A -C HARDCODED SET OF DOSE VALUES AND WEIGHTS (THE TARGET CONCENTRAIONS -C WERE THOSE READ AS OBSERVED VALUES FROM A PATIENT DATA FILE). -C BESTDOSE CALLS ELDERY (WHICH USES THE NELDER MEED ALGORITHM) TO FIND -C THE BEST SET OF DOSES TO MINIMIZE THIS EXPECTED WEIGHTED SUM OF -C SQUARES, GIVEN: -C 1. A PATIENT DATA FILE WITH THE REQUIRED DOSE TIMES, OBSERVATION -C TIMES, AND TARGET CONCENTRATIONS (= OBSERVED VALUES), AND - - -C 2. A PRIOR DENSITY FILE WITH PARAMETER VALUES AND CORRESPONDING -C DENSITIES. - -C BESTDOSE IS COMPILED AND LINKED WITH CALCBEST, PARADP17, CONVRTLO - -C??? ACTUALLY MAXDIM IS UNRELATED TO MAX. NO. OF DOSES. SEE COMMENTS -C AT TOP OF BESTDOS3.FOR. -C FOR NOW, BESTDOSE.FOR (AUGUST, 2001), THE MAX. NO. OF DOSES IS -C LIMITED TO 7. TO RAISE IT, WILL HAVE TO INCREASE THE DIMENSIONS IN -C SUBROUTINE ELDERY, AND INCREASE MAXDIM IN THE THREE PARAMETER -C STATEMENTS IN CALCBEST.FOR. - -C----------------------------------------------------------------------- - -C TESTDOSE.FOR 1-26-01 - - -C TESTDOSE IS A VARIATION OF TESTDRV2. TESTDRV2 CALCULATED THE -C EXPECTED VALUE OF THE FISHER INFORMATION MATRIX, GIVEN A CANDIDATE -C VECTOR OF OBSERVATION TIMES (AND A PATIENT DATA FILE WITH THE DOSAGE -C REGIMEN, AND A PRIOR DENSITY FILE). - - - -C TESTDOSE CALCULATES THE EXPECTED WEIGHTED SUM OF SQUARES OF -C DIFFERENCES BETWEEN OBSERVED AND TARGET CONCENTRATIONS, GIVEN A -C CANDIDATE VECTOR OF DOSE AMOUNTS (DOSE TIMES AND OBSERVATION TIMES -C AND TARGET CONCENTRATIONS ARE GIVEN IN A PATIENT DATA FILE; ALSO A -C PRIOR DENSITY FILE IS GIVEN). - -C THIS PROGRAM MUST BE COMPILED AND LINKED WITH CONVRTLO.FOR, -C PARADP17.FOR, AND CALCS - -C----------------------------------------------------------------------- - -C PROCEDURE: - -C 1. THIS PROGRAM WILL READ FROM THE USER, VIA THE KEYBOARD, OR AN -C INPUT FILE, (NVAR,MENU,NPAR,NOFIX,NFIX,VALFIX,IDES,NCOV). THESE -C VALUES, ALONG WITH AGE, HEIGHT, ISEX, IETHFLG FROM THE PATIENT DATA -C FILE (SEE NO. 2 BELOW) WILL BE PASSED VIA COMMON/TOPAR TO THE PARDEF -C ROUTINE (WHICH IS PART OF THE PARADP17 MODULE). - -C 2. IT WILL THEN READ IN A PATIENT DATA FILE. IF IT IS A -C USC*PACK FILE, IT WILL BE CONVERTED TO A WORKING COPY FILE WITH - -C THE DESIRED ASSAY COEFFICIENTS IN IT. THIS FILE WILL BE PUT INTO -C FILE 27. THEN BEFORE CALCS IS CALLED, SUBROUTINE FILRED - -C WILL BE CALLED. FILRED READS IN THE ASSAY COEFFICIENTS, ALONG WITH -C AGE, HEIGHT, ISEX, AND IETHFLG (SEE NO. 2 ABOVE) AND PUTS THE -C REQUIRED DOSAGE INFO INTO THE REQUIRED COMMONS (ALL THIS INFO IS -C NEEDED BY THE CALCS MODULE). - -C NOTE THAT FILRED WILL BE CALLED JUST ONCE TO ESTABLISH ALL THE VALUES -C (DOSE TIMES, OBSERVATION TIMES, ETC.) INTO THE REQUIRED COMMONS. -C THEN, EACH TIME A NEW DOSAGE CANDIDATE VECTOR IS USED, THE VALUES OF -C THESE NEW DOSES WILL BE STORED INTO THE RS VECTOR IN COMMON/OBSER -C BY SUBROUTINE WSUMSQ IN MODULE CALCS (I.E., FILRED WILL NOT HAVE -C TO BE CALLED AGAIN SINCE ALL THE VALUES ALREADY STORED INTO ITS -C COMMONS STAY THE SAME EXCEPT FOR THE RS VECTOR WHICH WILL BE STORED -C AS INDICATED ABOVE). - -C----------------------------------------------------------------------- - - PARAMETER(MAXGRD=5003, MAXDIM=25, MAXOBDIM=150, MAXSUB=1, - 1 MAXNUMEQ = 7) - - IMPLICIT REAL*8(A-H,O-Z) - - DIMENSION DENSITY(MAXGRD,MAXDIM+1),YO(MAXOBDIM,MAXNUMEQ), - 1 START(5000),STEP(5000),VALFIX(20),RS(5000,34),DOSEBEST(5000), - 2 PREDMIN(MAXGRD,594,MAXNUMEQ),IRAN(32),ATOL(20),C0P(MAXNUMEQ), - 3 C1P(MAXNUMEQ),C2P(MAXNUMEQ),C3P(MAXNUMEQ),IASS(MAXNUMEQ), - 4 C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ),C3(MAXNUMEQ), - 5 SIG(5000),WORKK(MAXGRD),WORK(MAXGRD),CORDEN(MAXGRD,MAXDIM+1), - 6 AB(30,2),VALFIXX(20),AF(7),PYJGX(MAXSUB,MAXGRD), - 7 DENSTOR(MAXGRD,4),THETA(30),PX(32),BS(5000,7),TIM(594), - 8 TPRED(72000),YOO(594,MAXNUMEQ),YYPRED(72000,MAXNUMEQ), - 9 CORDLAST(MAXGRD,MAXDIM+1),TIM41(594),CORD1(MAXGRD,MAXDIM+1), - 1 PREDMIN1(MAXGRD,594,MAXNUMEQ),DENSITY1(MAXGRD,MAXDIM+1), - 2 DOSEBEST1(5000),YBAR(72000,MAXNUMEQ),AUCBAR(72000,MAXNUMEQ), - 3 TPREDREL(72000) - - - CHARACTER PAR(30)*11,FILNFO*20, - 1 SAVFIL*20,PARFIX(20)*11,CODE*14,PATH*60,TMPFILE*13, - 2 PATHFILE*73,MATFIL*20,FORFILE*20,FUTUREFILEIN*20,OUTFIL*20, - 3 NAME*4,NPAGDENFILE*20,PASTFILEIN*20,ESTNAM*6,TMPFILE1*13, - 4 TMPFILE2*13,PATFIL*20,ERRFIL*20,PARRANFIX(20)*11 - - EXTERNAL CALCS - - COMMON/TOCALC/DENSITY,BIASWEIGHT,NOBSER,NUMEQT,NGRD,NVARR,NDD41 - COMMON/PREDVAL/PREDMIN,EEXPSUMMIN,SUMMIN,BIASMIN - COMMON/FROMBEST/NOFIX,IRAN,VALFIX - COMMON/TOUSER/NDIM,MF,RTOL,ATOL - COMMON/OBSER/ TIM,SIG,RS,YOO,BS - COMMON/TOCALCTP/M41,TIM41 - COMMON/TOSUMSQ/ITARGET,NVAR,NOFIXXX,NDIMMM,IDELTA,TNEXT - COMMON/ERROR/ERRFIL - - -C NOTE THAT COMMON/TOSUMSQ VALUES ARE PROVIDED FROM MAIN TO -C SUBROUTINE WSUMSQ (WHICH IS CALLED BY SUBROUTINE CALCS). - - -C COMMON/TOCALC IS SUPPLIED TO SUBROUTINE CALCS WHICH IS THE ROUTINE -C CALLED BY ELDERY. - -C COMMON/PREVAL CONTAINS PREDMIN WHICH CONTAINS THE PREDICTED VALUES -C FOR EACH GRID POINT FOR THE BEST SET OF DOSES SO FAR (AS DETERMINED -C BY SUBROUTINE ELDERY). ALSO, EEXPSUMMIN IS THE MINIMUM ACHIEVED -C COST FUNCTION, WHICH IS A FUNCTION OF SUMMIN AND BIASMIN. - -C COMMON/FROMBEST IS PROVIDED TO SUBROUTINE CALCS. THESE VALUES ARE -C NEEDED IN THE CALL TO MAKEVEC IN THAT ROUTINE. - - -C COMMON/TOUSER IS SUPPLIED TO SUBROUTINE USERANAL IN CALCBST_.FOR. - -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. - -C----------------------------------------------------------------------- - - 2 FORMAT(A20) - 222 FORMAT(A3) - 2222 FORMAT(A5) - 2221 FORMAT(A60) - - - 138 FORMAT(/' PLEASE ENTER ONE OF THE REQUESTED VALUES: ') - - -C ENTER ALL INSTRUCTIONS FROM 'GUICMDS.INX' WITH NO USER INTERACTION -C IF THIS FILE EXISTS IN THE WORKING DIRECTORY. OTHERWISE, PROCEED AS -C IN PREVIOUS PROGRAMS, ASKING THE USER FOR THE PATH AND THEN OBTAINING -C INPUT INFO EITHER VIA AN INPUT FILE OR THE KEYBOARD. - - - OPEN(23,FILE='GUICMDS.INX',ERR=1210,STATUS='OLD') - -C TO GET HERE, THE FILE, 'GETCMDS.INX' EXISTS IN THE WORKING -C DIRECTORY. READ ALL INPUT DATA IN THIS FILE, WHICH WAS FILLED FROM A -C GUI DRIVING THIS PROGRAM. NOTE THAT THIS FILE HAS ALL THE INFORMATION -C OF A STANDARD INSTRUCTION FILE, BUT ALSO INCLUDES THE PATH AT THE -C TOP, SINCE THE PATH CANNOT BE PROVIDED TO THE PROGRAM REAL TIME, AS -C THERE IS NO USER INTERACTION IF "GUICMDS.INX" IS READ. - -C THE 1ST LINE IN THE FILE IS THE CODE WHICH GIVES THE VERSION NO. OF -C THE PROGRAM. - - READ(23,7123) CODE - - ICODE = 0 -C IF(CODE .EQ. 'BESTDOS JUN_11') ICODE = 01 -C IF(CODE .EQ. 'BESTDOS JUL_11') ICODE = 02 -C IF(CODE .EQ. 'BESTDOS AUG_11') ICODE = 03 -C IF(CODE .EQ. 'BESTDOS SEP_11') ICODE = 04 - IF(CODE .EQ. 'BESTDOS MAR_13') ICODE = 05 - IF(CODE .EQ. 'BESTDOS APR_13') ICODE = 06 - IF(CODE .EQ. 'BESTDOS MAY_13') ICODE = 07 - IF(CODE .EQ. 'BESTDOS JUN_13') ICODE = 08 - IF(CODE .EQ. 'BESTDOS SEP_13') ICODE = 09 - IF(CODE .EQ. 'BESTDOS OCT_13') ICODE = 10 - - IF(ICODE .EQ. 0) THEN - - WRITE(*,9124) - 9124 FORMAT(/' "GUICMDS.INX" IS NOT AN UP-TO-DATE GUI FILE FOR '/ - 1' THIS PROGRAM. '/) - WRITE(*,9126) - 9126 FORMAT(/' CONSIDER TRYING ONE OF THE FOLLOWING 2 OPTIONS:'// - 3' 1. USE A SAVED INSTRUCTION FILE FROM A PREVIOUS DOS RUNNING '/ - 4' OF THIS PROGRAM. THE 1ST LINE OF THE SAVED FILE MUST HAVE '/ - 5' BESTDOS XXX_XX, WHERE XXX_XX IS MAR_13 OR A MORE RECENT DATE. - 6'// - 6' 2. ENTER DATA FROM THE KEYBOARD AS YOU RUN THE PROGRAM UNDER DOS - 7.'/) - -C CANNOT WRITE THIS ERROR MESSAGE TO ERRFIL SINCE ERRFIL CAN'T BE -C ESTABLISHED TILL THE PATH IS OBTAINED BELOW. - - - CALL PAUSE - STOP - - ENDIF - -C SKIP THIS LINE. IT CONTAINS 'PATH' - READ(23,*) - READ(23,2221) PATH - -C FIND xxxx, WHICH WILL BE THE 4-DIGIT EXTENSION ASSIGNED TO -C THE OUTPUT FILE AND ERROR FILE NAMES BELOW. NOTE THAT xxxx IS -C THE 4-CHARACTER REPRESENTATION OF THE INTEGER -C CURRENTLY IN THE FILE, EXTNUM, IN THE WORKING DIRECTORY. GET THIS -C INTEGER NOW, AND REPLACE IT BY 1 MORE (UNLESS IT IS 9999, IN WHICH -C CASE, REPLACE IT BY 1), AND THEN CLOSE EXTNUM. NOTE THAT AS OF -C BESTDOS119.FOR, THE ACTUAL OUTPUT FILE IS OPENED LATER IN THE CODE. -C FOR NOW, JUST ESTABLISH 'NAME'. - -C AS OF BESTDOS119.FOR, THE READING OF EXTNUM TO GET 'NAME' MUST BE -C DONE IN THIS PART OF THE CODE ALSO. THE REASON IS THAT 'NAME' IS -C NEEDED TO ESTABLISH ERRFIL, WHICH WILL NOW BE WRITTEN TO IF THE -C PROGRAM TERMINATES ABNORMALLY. - -C OPEN FILE EXTNUM AND READ THE NO. THERE. - - TMPFILE = ' ' - TMPFILE = 'EXTNUM' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(25,FILE=PATHFILE,STATUS='OLD') - READ(25,*) INUM - -C OBTAIN THE CHARACTER*4 EQUIVALENT TO INUM. - - CALL EQUIV(INUM,NAME) - - -C REPLACE THE NO. IN 'EXTNUM' BY INUM+1 (EXCEPT INUM=9999 IS -C TO BE REPLACED BY 1). - - JNUM=INUM+1 - IF(JNUM .EQ. 10000) JNUM=1 - BACKSPACE(25) - WRITE(25,*) JNUM - CLOSE(25) - -C ESTABLISH ERRFIL, WHICH WILL CONTAIN THE SAME MESSAGE THAT -C IS WRITTEN TO THE SCREEN IN CASE THE PROGRAM STOPS ABNORMALLY. - - ERRFIL = 'ERROR'//NAME - - -C SKIP THIS LINE. IT CONTAINS 'MODEL FILENAME ' - READ(23,*) - READ(23,2) FORFILE - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - - TMPFILE = ' ' - TMPFILE = FORFILE - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(28,FILE=PATHFILE,ERR=9050,STATUS='OLD',POSITION='APPEND') - GO TO 9030 - 9050 WRITE(*,5316) PATHFILE - WRITE(*,9126) - - OPEN(47,FILE=ERRFIL) - WRITE(47,5316) PATHFILE - WRITE(47,9126) - CLOSE(47) - - CALL PAUSE - STOP - - 9030 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,3) - - CLOSE(28) - -C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: - -C NDIM = NO. OF STATES FOR THE O.D.E. -C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. -C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). -C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. -C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE -C TO BE SET BY THE USER. -C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. -C IRAN(I) = 1 IF PARAMATER I IS RANDOM; -C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. - - -C SKIP THIS LINE. IT CONTAINS 'NPAG DENSITY FILE' - READ(23,*) - READ(23,2) NPAGDENFILE - -C NPAGDENFILE CONTAINS THE NAME OF AN NPAG DENSITY FILE; VERIFY THAT -C THIS FILE EXISTS. - - TMPFILE = ' ' - TMPFILE = NPAGDENFILE - - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - - OPEN(67,FILE=PATHFILE,ERR=9040,STATUS='OLD') - GO TO 9055 - 9040 WRITE(*,5316) PATHFILE - WRITE(*,9126) - - OPEN(47,FILE=ERRFIL) - WRITE(47,5316) PATHFILE - WRITE(47,9126) - CLOSE(47) - - - CALL PAUSE - STOP - - 9055 CLOSE(67) - - IF(ICODE .EQ. 5) MAXCYC = 500 - - IF(ICODE .GE. 6) THEN - -C SKIP THIS LINE, IT CONTAINS 'MAXCYC' - READ(23,*) - READ(23,*) MAXCYC - ENDIF - - -C SKIP THIS LINE, IT CONTAINS 'INCLUDPAST' - READ(23,*) - READ(23,*) INCLUDPAST - -C SKIP THIS LINE. IT CONTAINS 'IPASTFILE' - READ(23,*) - READ(23,*) IPASTFILE - -C SKIP THIS LINE. IT CONTAINS 'PASTFILEIN' - READ(23,*) - READ(23,2) PASTFILEIN - READ(23,*) -C THE ABOVE LINE WILL CONTAIN ICOVTYPE(.) INFO ONLY IF IPASTFILE = 1 -C AND NCOVA > 0. IF SO, IT WILL BE REREAD IN SUBROUTINE READBLOCK2. IF -C NOT, THIS LINE WILL BE UNNEEDED AND THEREFORE NOT REREAD. SEE CODE -C IN READBLOCK2 REGARDING IGUI. - -C CHECK THAT PASTFILEIN IS AN EXISTING FILE, UNLESS INCLUDPAST = 0, -C IN WHICH CASE THE USER IS NOT SUPPLYING A PAST FILE (NOTE IF -C IPASTFILE = 1, THE PAST FILE IS IN .CSV FORMAT; AND IF IPASTFILE = 0, -C THE PAST FILE IS IN WORKING COPY FORMAT. - -C NOTE THAT, STARTING WITH BESTDOS106.FOR, AN NPAG RUN WILL BE DONE -C WITH UP TO MAXCYC CYCLES WITH THE PRIOR DENSITY FILE NPAGDENFILE, ON -C THE SUBJECT WHOSE PAST INFO IS IN PASTFILEIN, IF INCLUDPAST = 1 AND -C IPRIOROBS = 1 (SEE BELOW). OTHERWISE, THE NPAG DENSITY FILE INPUT -C ABOVE IN NPAGDENFILE WILL CONTAIN THE PARAMETER DENSITY TO BE USED -C IN THE OPTIMIZATION OF DOSES. - - - IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 0) THEN - - TMPFILE = ' ' - TMPFILE = PASTFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=9060,STATUS='OLD') - GO TO 9075 - 9060 WRITE(*,5316) PATHFILE - WRITE(*,9126) - - - OPEN(47,FILE=ERRFIL) - WRITE(47,5316) PATHFILE - WRITE(47,9126) - CLOSE(47) - - - - CALL PAUSE - STOP - 9075 CONTINUE - - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - CLOSE(21) - - - ENDIF - -C ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1 .AND IPASTFILE .EQ. 0) -C CONDITION. - - - -C IF IPASTFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE -C XQZPJ001.PST IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE -C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON -C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR -C THE FIRST SUBJECT. - - IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) THEN - - TMPFILE = ' ' - TMPFILE = PASTFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,STATUS='OLD') - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - CALL CONVERTCSV - - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT - -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE -C READBLOCK2. - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - REWIND(66) - CALL READBLOCK2(PATH,C0,C1,C2,C3,1,1) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - TMPFILE = ' ' - TMPFILE = 'XQZPJ001.PST' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=9085,STATUS='OLD') - GO TO 9080 - 9085 WRITE(*,5466) PATHFILE,PASTFILEIN - WRITE(*,9126) - - OPEN(47,FILE=ERRFIL) - WRITE(47,5466) PATHFILE,PASTFILEIN - WRITE(47,9126) - CLOSE(47) - - - CALL PAUSE - STOP - - 9080 CONTINUE - - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - CLOSE(21) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) CONDITION. - - -C SKIP THIS LINE. IT CONTAINS 'ICSVFILE' - READ(23,*) - READ(23,*) ICSVFILE - -C SKIP THIS LINE. IT CONTAINS 'FUTUREFILEIN' - READ(23,*) - READ(23,2) FUTUREFILEIN - READ(23,*) -C THE ABOVE LINE WILL CONTAIN ICOVTYPE(.) INFO ONLY IF ICSVFILE = 1, -C AND NCOVA > 0. IF SO, IT WILL BE REREAD IN SUBROUTINE -C READBLOCK2. IF NOT, THIS LINE WILL BE UNNEEDED AND THEREFORE NOT -C REREAD. SEE CODE IN READBLOCK2 REGARDING IGUI. - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - IF(ICSVFILE .EQ. 0) THEN - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - - OPEN(21,FILE=PATHFILE,ERR=9140,STATUS='OLD') - GO TO 9155 - 9140 WRITE(*,5316) PATHFILE - WRITE(*,9126) - - OPEN(47,FILE=ERRFIL) - WRITE(47,5316) PATHFILE - WRITE(47,9126) - CLOSE(47) - - CALL PAUSE - STOP - 9155 CLOSE(21) - - ENDIF - - -C IF ICSVFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE -C XQZPJ001.FUT IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE -C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON -C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR -C THE FIRST SUBJECT. - - IF(ICSVFILE .EQ. 1) THEN - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,STATUS='OLD') - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - CALL CONVERTCSV - - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE -C READBLOCK2. - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - REWIND(66) - CALL READBLOCK2(PATH,C0,C1,C2,C3,2,1) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - TMPFILE = ' ' - TMPFILE = 'XQZPJ001.FUT' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=9165,STATUS='OLD') - - GO TO 9170 - - 9165 WRITE(*,5466) PATHFILE,FUTUREFILEIN - WRITE(*,9126) - - OPEN(47,FILE=ERRFIL) - WRITE(47,5466) PATHFILE,FUTUREFILEIN - WRITE(47,9126) - CLOSE(47) - - CALL PAUSE - STOP - - 9170 CLOSE(21) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. - -C SKIP THIS LINE. IT CONTAINS 'TNEXT'. - READ(23,*) - READ(23,*) TNEXT - - IF(ICODE .LE. 6) IDELTA = 15 - - IF(ICODE .GE. 7) THEN - -C SKIP THIS LINE. IT CONTAINS 'IDELTA'. - READ(23,*) - READ(23,*) IDELTA - - ENDIF - - - -C NOTE THAT NOFIX WAS OBTAINED ABOVE IN THE CALL TO USERPREP, BUT IT - -C MUST BE READ IN BELOW SO THE GUI WILL KNOW WHETHER THE -C FOLLOWING LINE CONTAINS FIXED VALUES OR NOT. - -C SKIP THIS LINE. IT CONTAINS 'NOFIX'. - READ(23,*) - READ(23,*) NOFIX - -C SKIP THIS LINE. IT CONTAINS 'VALFIX ARRAY IF NOFIX > 0'. - READ(23,*) - IF(NOFIX .GT. 0) READ(23,*) (VALFIX(I),I=1,NOFIX) - -C CHECK THAT NOFIX .LE. 20. IF NOT, PRINT MESSAGE TO USER AND STOP. - - IF(NOFIX .GT. 20) THEN - - WRITE(*,9177) NOFIX - 9177 FORMAT(/' NOFIX WAS READ IN FROM "GUICMDS.INX" TO '/ - 1' BE ', I3,'. THIS IS > 20, THE MAXIMUM ALLOWED VALUE.'// - 2' PLEASE RERUN THE PROGRAM UNDER DOS WITH KEYBOARD ENTRY, OR USE'/ - 3' AN INSTRUCTION FILE HAVING NOFIX .LE. 20.') - - OPEN(47,FILE=ERRFIL) - WRITE(47,9177) NOFIX - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - -C SKIP THIS LINE. IT CONTAINS 'TOLER'. - READ(23,*) - READ(23,*) TOLER - RTOL = TOLER - - DO I=1,NDIM - ATOL(I) = TOLER - END DO - - MF = 22 - - -C SKIP THIS LINE. IT CONTAINS 'NUMEQT'. - READ(23,*) - READ(23,*) NUMEQT - - -C SKIP THIS LINE. IT CONTAINS 'NUMEQT LINES OF ASSAY COEFFICIENTS'. - READ(23,*) - - DO IEQ=1,NUMEQT - READ(23,*) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - END DO - -C SKIP THIS LINE. IT CONTAINS 'IERRMOD'. - READ(23,*) - - READ(23,*) IERRMOD - -C SKIP THIS LINE. IT CONTAINS 'GAMLAM - READ(23,*) - READ(23,*) GAMLAM - - -C SKIP THIS LINE. IT CONTAINS 'IASS(I),I=1,NUMEQT'. - READ(23,*) - READ(23,*) (IASS(I),I=1,NUMEQT) - -C SKIP THIS LINE. IT CONTAINS 'NDRUG'. - READ(23,*) - READ(23,*) NDRUG - -C SKIP THIS LINE. IT CONTAINS 'AF(I),I=1,NDRUG'. - READ(23,*) - READ(23,*) (AF(I),I=1,NDRUG) - - IF(ICODE .LE. 7) IOPTIMIZE = 1 - - IF(ICODE .GE. 8) THEN - -C SKIP THIS LINE. IT CONTAINS 'IOPTIMIZE'. - READ(23,*) - READ(23,*) IOPTIMIZE - - ENDIF - - - IF(ICODE .LE. 8) BIASWEIGHT = 0.D0 - - IF(ICODE .GE. 9) THEN - -C SKIP THIS LINE. IT CONTAINS 'BIASWEIGHT'. - READ(23,*) - READ(23,*) BIASWEIGHT - - ENDIF - - IF(ICODE .LE. 9) ITARGET = 1 - - IF(ICODE .GE. 10) THEN - -C SKIP THIS LINE. IT CONTAINS 'ITARGET'. - READ(23,*) - READ(23,*) ITARGET - - ENDIF - - - - CLOSE(23) - -C NOW PROCEED TO LABEL 1450 WHICH WILL RUN THE PROGRAM USING ALL THE -C INFO READ IN FROM FILE 39 ... WITH NO USER INTERACTION (I.E., -C SUBROUTINE VERIF1 WILL NOT BE CALLED, AND THE USER WILL NOT BE ASKED -C IF HE WANTS TO SAVE INFORMATION INTO A DIFFERENT INSTRUCTION FILE). - - GO TO 1450 - - - 1210 CONTINUE - -C TO GET HERE MEANS THERE IS NO FILE, 'GUICMDS.INX' IN THE WORKING -C DIRECTORY, SO PROCEED AS USUAL TO OBTAIN INPUT INSTRUCTIONS FROM -C THE USER. - - -C CALL GETPATH TO GET FROM THE USER THE PATH WHERE THE INPUT FILES ARE -C LOCATED (AND WHERE THE OUTPUT FILES WILL GO). NOTE THAT PATH IS THE -C PATH WITH A TRAILING BACKSLASH, AND NOB IS THE NO. OF THE ENTRY WITH -C THE LAST NON-BLANK ENTRY. - - CALL GETPATH(PATH,NOB) - -C FIND xxxx, WHICH WILL BE THE 4-DIGIT EXTENSION ASSIGNED TO -C THE OUTPUT FILE AND ERROR FILE NAMES BELOW. NOTE THAT xxxx IS -C THE 4-CHARACTER REPRESENTATION OF THE INTEGER -C CURRENTLY IN THE FILE, EXTNUM, IN THE WORKING DIRECTORY. GET THIS -C INTEGER NOW, AND REPLACE IT BY 1 MORE (UNLESS IT IS 9999, IN WHICH -C CASE, REPLACE IT BY 1), AND THEN CLOSE EXTNUM. NOTE THAT AS OF -C BESTDOS119.FOR, THE ACTUAL OUTPUT FILE IS OPENED LATER IN THE CODE. -C FOR NOW, JUST ESTABLISH 'NAME'. - -C AS OF BESTDOS119.FOR, THE READING OF EXTNUM TO GET 'NAME' IS MOVED -C HERE, TO THE TOP OF THE CODE. THE REASON IS THAT 'NAME' IS NEEDED -C TO ESTABLISH ERRFIL, WHICH WILL NOW BE WRITTEN TO IF THE PROGRAM -C TERMINATES ABNORMALLY. - - -C OPEN FILE EXTNUM AND READ THE NO. THERE. - - TMPFILE = ' ' - TMPFILE = 'EXTNUM' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(25,FILE=PATHFILE,STATUS='OLD') - READ(25,*) INUM - -C OBTAIN THE CHARACTER*4 EQUIVALENT TO INUM. - - CALL EQUIV(INUM,NAME) - - -C REPLACE THE NO. IN 'EXTNUM' BY INUM+1 (EXCEPT INUM=9999 IS -C TO BE REPLACED BY 1). - - JNUM=INUM+1 - IF(JNUM .EQ. 10000) JNUM=1 - BACKSPACE(25) - WRITE(25,*) JNUM - CLOSE(25) - -C ESTABLISH ERRFIL, WHICH WILL CONTAIN THE SAME MESSAGE THAT -C IS WRITTEN TO THE SCREEN IN CASE THE PROGRAM STOPS ABNORMALLY. - - ERRFIL = 'ERROR'//NAME - - -C AS OF BESTDOS119.FOR, FORMAT 1416 INDICATES THAT STEADY STATE DOSES -C MAY OCCUR IN THE "PAST", BUT ONLY AT THE BEGINNING OF A PATIENT -C FILE; I.E., DOSE RESETS ARE STILL NOT ALLOWED. - - WRITE(*,1416) - 1416 FORMAT(//' ******* WARNING *******'/ - 1' STEADY STATE DOSE SETS AT THE BEGINNING OF THE PATIENT FILE'/ - 2' ARE ALLOWED. BUT IF YOUR PATIENT INFORMATION INCLUDES DOSE '/ - 3' RESETS, PLEASE STOP NOW. IF YOU CONTINUE, YOUR RESULTS WILL BE'/ - 4' UNPREDICTABLE.'/ - 5' ******* WARNING *******'//) - - - - 145 WRITE(*,38) - 38 FORMAT(/' ENTER 0 IF INPUT IS TO BE FROM THE KEYBOARD; '/ - 1' ENTER 1 IF INPUT IS TO BE FROM A FILE: ') - READ(*,*,ERR=145) INOPT - IF(INOPT .NE. 0 .AND. INOPT .NE. 1) GO TO 145 - - - IF(INOPT .EQ. 1) THEN - - WRITE(*,39) - 39 FORMAT(/' ENTER THE NAME OF THE INSTRUCTION FILE; '/ - 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - - READ(*,2) FILNFO - IF(FILNFO(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FILNFO) - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = FILNFO - - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(23,FILE=PATHFILE,ERR=6330,STATUS='OLD') - GO TO 6335 - 6330 WRITE(*,5316) PATHFILE - 5316 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ - 1' ',A73) - GO TO 145 - 6335 CONTINUE - - -C READ ALL INPUT DATA FROM FILE FILNFO, WHICH WAS FILLED FROM A -C PREVIOUS RUNNING OF THIS PROGRAM. - -C THE 1ST LINE IN FILNFO IS THE CODE WHICH GIVES THE VERSION NO. OF -C THE PROGRAM. - - - READ(23,7123) CODE - - - 7123 FORMAT(A14) - - - ICODE = 0 -C IF(CODE .EQ. 'BESTDOS JUN_11') ICODE = 01 -C IF(CODE .EQ. 'BESTDOS JUL_11') ICODE = 02 -C IF(CODE .EQ. 'BESTDOS AUG_11') ICODE = 03 -C IF(CODE .EQ. 'BESTDOS SEP_11') ICODE = 04 - IF(CODE .EQ. 'BESTDOS MAR_13') ICODE = 05 - IF(CODE .EQ. 'BESTDOS APR_13') ICODE = 06 - IF(CODE .EQ. 'BESTDOS MAY_13') ICODE = 07 - IF(CODE .EQ. 'BESTDOS JUN_13') ICODE = 08 - IF(CODE .EQ. 'BESTDOS SEP_13') ICODE = 09 - IF(CODE .EQ. 'BESTDOS OCT_13') ICODE = 10 - - IF(ICODE .EQ. 0) THEN - WRITE(*,7124) - 7124 FORMAT(/' THIS FILE IS NOT AN UP-TO-DATE INSTRUCTION FILE'/ - 1' FOR THIS PROGRAM. '// - 2' YOU HAVE THE FOLLOWING 2 OPTIONS:'// - 3' YOU MAY USE A SAVED INSTRUCTION FILE FROM A PREVIOUS RUNNING '/ - 4' OF THIS PROGRAM. THE 1ST LINE OF THE SAVED FILE MUST HAVE '/ - 5' BESTDOS XXX_XX, WHERE XXX_XX IS MAR_13 OR A MORE RECENT DATE.'// - 6' OR YOU MAY SIMPLY ENTER DATA FROM THE KEYBOARD.'/) - CALL PAUSE - GO TO 145 - ENDIF - -C SKIP THIS LINE. IT CONTAINS 'MODEL FILENAME ' - READ(23,*) - READ(23,2) FORFILE - WRITE(*,1919) FORFILE - 1919 FORMAT(/' HAVE YOU ALREADY LINKED FILE ',A20,' WITH THIS '/ - 1' PROGRAM, AND IS THIS FILE AN EDITED VERSION OF TSTMULTM.FOR?'// - 2' IF NOT, STOP NOW, AND RERUN THE PROGRAM AFTER VERIFYING BOTH '/ - 3' ITEMS ABOVE.'/) - CALL PAUSE - - - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - - 7010 TMPFILE = ' ' - TMPFILE = FORFILE - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(28,FILE=PATHFILE,ERR=7050,STATUS='OLD',POSITION='APPEND') - GO TO 7030 - 7050 WRITE(*,4406) FORFILE - READ(*,2) FORFILE - IF(FORFILE(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FORFILE) - GO TO 7010 - - 7030 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,INOPT) - - - CLOSE(28) - -C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: - -C NDIM = NO. OF STATES FOR THE O.D.E. -C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. -C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). -C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. -C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE -C TO BE SET BY THE USER. -C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. -C IRAN(I) = 1 IF PARAMATER I IS RANDOM; -C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. - -C SKIP THIS LINE. IT CONTAINS 'NPAG DENSITY FILE' - READ(23,*) - READ(23,2) NPAGDENFILE - -C NPAGDENFILE CONTAINS THE NAME OF AN NPAG DENSITY FILE; VERIFY THAT -C THIS FILE EXISTS. - - TMPFILE = ' ' - TMPFILE = NPAGDENFILE - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(67,FILE=PATHFILE,ERR=9440,STATUS='OLD') - GO TO 9455 - 9440 WRITE(*,5316) PATHFILE - - OPEN(47,FILE=ERRFIL) - WRITE(47,5316) PATHFILE - CLOSE(47) - - CALL PAUSE - STOP - 9455 CLOSE(67) - - - IF(ICODE .EQ. 5) MAXCYC = 500 - - IF(ICODE .GE. 6) THEN - -C SKIP THIS LINE, IT CONTAINS 'MAXCYC' - READ(23,*) - READ(23,*) MAXCYC - - ENDIF - - -C SKIP THIS LINE, IT CONTAINS 'INCLUDPAST' - READ(23,*) - READ(23,*) INCLUDPAST - -C SKIP THIS LINE. IT CONTAINS 'IPASTFILE' - READ(23,*) - - READ(23,*) IPASTFILE - -C SKIP THIS LINE. IT CONTAINS 'PASTFILEIN' - READ(23,*) - READ(23,2) PASTFILEIN - -C CHECK THAT PASTFILEIN IS AN EXISTING FILE, UNLESS INCLUDPAST = 0, -C IN WHICH CASE THE USER IS NOT SUPPLYING A PAST FILE (NOTE IF -C IPASTFILE = 1, THE PAST FILE IS IN .CSV FORMAT; AND IF IPASTFILE = 0, -C THE PAST FILE IS IN WORKING COPY FORMAT. - - -C NOTE THAT, STARTING WITH BESTDOS106.FOR, AN NPAG RUN WILL BE DONE -C WITH UP TO MAXCYC CYCLES WITH THE PRIOR DENSITY FILE NPAGDENFILE, ON -C THE SUBJECT WHOSE PAST INFO IS IN PASTFILEIN, IF INCLUDPAST = 1 AND -C IPRIOROBS = 1 (SEE BELOW). OTHERWISE, THE NPAG DENSITY FILE INPUT -C ABOVE IN NPAGDENFILE WILL CONTAIN THE PARAMETER DENSITY TO BE USED - -C IN THE OPTIMIZATION OF DOSES. - - IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 0) THEN - - TMPFILE = ' ' - TMPFILE = PASTFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - - OPEN(21,FILE=PATHFILE,ERR=8460,STATUS='OLD') - GO TO 8475 -8460 WRITE(*,5316) PATHFILE - - OPEN(47,FILE=ERRFIL) - WRITE(47,5316) PATHFILE - CLOSE(47) - - CALL PAUSE - STOP - - 8475 CONTINUE - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE - -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - CLOSE(21) - - ENDIF - -C ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1 .AND IPASTFILE .EQ. 0) -C CONDITION. - - -C IF IPASTFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE -C XQZPJ001.PST IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE -C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON - -C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR -C THE FIRST SUBJECT. - - IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) THEN - - TMPFILE = ' ' - TMPFILE = PASTFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,STATUS='OLD') - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - CALL CONVERTCSV - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO - -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE -C READBLOCK2. - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - REWIND(66) - CALL READBLOCK2(PATH,C0,C1,C2,C3,1,0) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - TMPFILE = ' ' - TMPFILE = 'XQZPJ001.PST' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8485,STATUS='OLD') - GO TO 8480 - 8485 WRITE(*,5466) PATHFILE,PASTFILEIN - - OPEN(47,FILE=ERRFIL) - WRITE(47,5466) PATHFILE,PASTFILEIN - CLOSE(47) - - - CALL PAUSE - STOP - - 8480 CONTINUE - - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR - -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - CLOSE(21) - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE -C IF(INCLUDPAST .EQ. 1 .AND. IPASTFILE .EQ. 1) CONDITION. - -C SKIP THIS LINE. IT CONTAINS 'ICSVFILE' - READ(23,*) - READ(23,*) ICSVFILE - -C SKIP THIS LINE. IT CONTAINS 'FUTUREFILEIN' - READ(23,*) - READ(23,2) FUTUREFILEIN - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - IF(ICSVFILE .EQ. 0) THEN - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8440,STATUS='OLD') - GO TO 8455 - 8440 WRITE(*,5316) PATHFILE - - OPEN(47,FILE=ERRFIL) - WRITE(47,5316) PATHFILE - CLOSE(47) - - - CALL PAUSE - STOP - - 8455 CLOSE(21) - - ENDIF - - -C IF ICSVFILE = 1, CREATE THE MULTIPLE DRUG WORKING COPY FILE -C XQZPJ001.FUT IN THE WORKING COPY DIRECTORY FROM THE DATA OF THE -C FIRST SUBJECT IN PATHFILE. NOTE THAT READBLOCK2 BELOW IS BASED ON -C READBLOCK IN NPBG15E1.FOR, BUT ONLY CREATES A WORKING COPY FILE FOR -C THE FIRST SUBJECT. - - IF(ICSVFILE .EQ. 1) THEN - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,STATUS='OLD') - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - CALL CONVERTCSV - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE -C READBLOCK2. - - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - REWIND(66) - CALL READBLOCK2(PATH,C0,C1,C2,C3,2,0) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - TMPFILE = ' ' - TMPFILE = 'XQZPJ001.FUT' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8465,STATUS='OLD') - - GO TO 8470 - 8465 WRITE(*,5466) PATHFILE,FUTUREFILEIN - - OPEN(47,FILE=ERRFIL) - WRITE(47,5466) PATHFILE,FUTUREFILEIN - CLOSE(47) - - CALL PAUSE - STOP - - 8470 CLOSE(21) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. - - -C SKIP THIS LINE. IT CONTAINS 'TNEXT'. - READ(23,*) - READ(23,*) TNEXT - - - IF(ICODE .LE. 6) IDELTA = 15 - - IF(ICODE .GE. 7) THEN - -C SKIP THIS LINE. IT CONTAINS 'IDELTA'. - READ(23,*) - READ(23,*) IDELTA - - ENDIF - - -C NOTE THAT NOFIX WAS OBTAINED ABOVE IN THE CALL TO USERPREP, BUT IT -C MUST BE READ IN BELOW SO THE GUI WILL KNOW WHETHER THE -C FOLLOWING LINE CONTAINS FIXED VALUES OR NOT. - -C SKIP THIS LINE. IT CONTAINS 'NOFIX'. - READ(23,*) - - - READ(23,*) NOFIX - -C SKIP THIS LINE. IT CONTAINS 'VALFIX ARRAY IF NOFIX > 0'. - READ(23,*) - IF(NOFIX .GT. 0) READ(23,*) (VALFIX(I),I=1,NOFIX) - -C CHECK THAT NOFIX .LE. 20. IF NOT, PRINT MESSAGE TO USER AND STOP. - - IF(NOFIX .GT. 20) THEN - - WRITE(*,3177) NOFIX - 3177 FORMAT(/' NOFIX WAS READ IN FROM THE INSTRUCTION FILE TO '/ - 1' BE ', I3,'. THIS IS > 20, THE MAXIMUM ALLOWED VALUE.'// - - - 2' PLEASE RERUN THE PROGRAM WITH KEYBOARD ENTRY, OR USE AN '/ - 3' INSTRUCTION FILE HAVING NOFIX .LE. 20.') - - OPEN(47,FILE=ERRFIL) - WRITE(47,3177) NOFIX - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - -C SKIP THIS LINE. IT CONTAINS 'TOLER'. - READ(23,*) - READ(23,*) TOLER - RTOL = TOLER - - DO I=1,NDIM - ATOL(I) = TOLER - - - END DO - - MF = 22 - -C SKIP THIS LINE. IT CONTAINS 'NUMEQT'. - READ(23,*) - READ(23,*) NUMEQT - -C SKIP THIS LINE. IT CONTAINS 'NUMEQT LINES OF ASSAY COEFFICIENTS'. - READ(23,*) - - DO IEQ=1,NUMEQT - READ(23,*) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - END DO - -C SKIP THIS LINE. IT CONTAINS 'IERRMOD'. - READ(23,*) - READ(23,*) IERRMOD - -C SKIP THIS LINE. IT CONTAINS 'GAMLAM - READ(23,*) - READ(23,*) GAMLAM - - -C SKIP THIS LINE. IT CONTAINS 'IASS(I),I=1,NUMEQT'. - READ(23,*) - READ(23,*) (IASS(I),I=1,NUMEQT) - -C SKIP THIS LINE. IT CONTAINS 'NDRUG'. - READ(23,*) - READ(23,*) NDRUG - -C SKIP THIS LINE. IT CONTAINS 'AF(I),I=1,NDRUG'. - READ(23,*) - READ(23,*) (AF(I),I=1,NDRUG) - - - IF(ICODE .LE. 7) IOPTIMIZE = 1 - - IF(ICODE .GE. 8) THEN - -C SKIP THIS LINE. IT CONTAINS 'IOPTIMIZE'. - READ(23,*) - READ(23,*) IOPTIMIZE - - ENDIF - - - - IF(ICODE .LE. 8) BIASWEIGHT = 0.D0 - - IF(ICODE .GE. 9) THEN - -C SKIP THIS LINE. IT CONTAINS 'BIASWEIGHT'. - READ(23,*) - READ(23,*) BIASWEIGHT - - ENDIF - - - IF(ICODE .LE. 9) ITARGET = 1 - - IF(ICODE .GE. 10) THEN - -C SKIP THIS LINE. IT CONTAINS 'ITARGET'. - READ(23,*) - READ(23,*) ITARGET - - ENDIF - - - CLOSE(23) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 1) CONDITION. - - - IF(INOPT .EQ. 0) THEN - - - WRITE(*,919) - 919 FORMAT(/' HAVE YOU ALREADY MADE YOUR FORTRAN MODEL FILE AS AN'/ - 1' EDITED VERSION OF THE TEMPLATE MODEL FILE, TSTMULTM.FOR, AND'/ - 2' HAVE YOU COMPILED AND LINKED THIS FILE INTO THIS PROGRAM?'// - 4' IF NOT, STOP NOW, AND THEN RERUN THIS PROGRAM AFTER DOING SO.'/) - - CALL PAUSE - - -C INPUT THE NAME OF THE FORTRAN FILE BASED ON THE TEMPLATE MODEL -C FILE, TSTMULTM.FOR (AS OF BESTDOS119.FOR), WHICH IDENTIFIES THE -C MODEL AND THE PARAMETERS FOR THE USER'S ANALYSIS. THEN CALL -C SUBROUTINE USERPREP TO INPUT VALUES FROM THIS FILE. - - - WRITE(*,5001) - - - 5001 FORMAT(/' ENTER THE NAME OF THE FORTRAN FILE (EDITED FROM '/ - 1' TEMPLATE MODEL FILE, TSTMULTM.FOR, WHICH YOU LINKED TO THIS'/ - 2' PROGRAM, AND WHICH CONTAINS THE CODE FOR THE MODEL YOU WOULD'/ - 3' LIKE TO ANALYZE: ') - READ(*,2) FORFILE - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - 5010 TMPFILE = ' ' - TMPFILE = FORFILE - - - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(28,FILE=PATHFILE,ERR=50,STATUS='OLD',POSITION='APPEND') - GO TO 30 - 50 WRITE(*,4406) FORFILE - 4406 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ - 1' ',A73/ - 2' ENTER THE CORRECT FILENAME OR ... '/ - 2' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,2) FORFILE - - - IF(FORFILE(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FORFILE) - GO TO 5010 - - 30 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,INOPT) - - - CLOSE(28) - -C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: - -C NDIM = NO. OF STATES FOR THE O.D.E. -C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. -C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). - -C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. -C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE -C TO BE SET BY THE USER. -C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. -C IRAN(I) = 1 IF PARAMATER I IS RANDOM; -C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. - - - 8010 WRITE(*,8013) - 8013 FORMAT(/' THIS PROGRAM REQUIRES AN NPAG DENSITY FROM A PREVIOUS'/ - 1' ANALYSIS OF A POPULATION. THIS NPAG DENSITY WILL BE USED AS'/ - 2' THE PARAMETER DENSITY FOR THE OPTIMIZATION OVER THE DOSES IN'/ - 3' THE "FUTURE" OF THE SUBJECT BEING CONSIDERED IN THIS RUN IF'/ - 4' THERE IS NO "PAST" HISTORY FOR THE SUBJECT, OR IF THE "PAST"'/ - 5' HISTORY INCLUDES NO OBSERVED VALUES.'// - 6' BUT IF THERE IS A "PAST" HISTORY FOR THE SUBJECT, AND IT '/ - 7' INCLUDES OBSERVATIONS, THEN THE NPAG DENSITY WILL BE USED AS'/ - 8' AS A PRIOR DENSITY FOR ANOTHER NPAG RUN WHICH WILL OBTAIN A'/ - 9' POSTERIOR DENSITY FOR THE SUBJECT, AND THIS NEW DENSITY WILL'/ - 1' THEN BE THE DENSITY FOR THE OPTIMIZATION. '// - 1' ENTER THE NAME OF THE FILE WHICH CONTAINS THE NPAG DENSITY'/ - 2' FROM A PREVIOUS ANALYSIS OF A POPULATION (IT WILL PROBABLY'/ - 3' BE DENxxxx, WHERE xxxx WAS THE JOB NUMBER): '// - 4' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,2) NPAGDENFILE - IF(NPAGDENFILE(1:3) .EQ. '-99') - 1 CALL SEEDIR(PATH,NOB,NPAGDENFILE) - - - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = NPAGDENFILE - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8020,STATUS='OLD') - GO TO 8025 - 8020 WRITE(*,5316) PATHFILE - GO TO 8010 - 8025 CLOSE(21) - - - 8030 WRITE(*,8031) - 8031 FORMAT(/' ENTER 1 IF THE CALCULATIONS ARE TO INCLUDE THE "PAST" '/ - 1' HISTORY FOR THE SUBJECT OF THIS RUN;'/ - 2' ENTER 0 OTHERWISE: ') - READ(*,*,ERR=8030) INCLUDPAST - IF(INCLUDPAST .NE. 1 .AND. INCLUDPAST .NE. 0) GO TO 8030 - - IF(INCLUDPAST .EQ. 0) THEN - IPASTFILE = -1 - PASTFILEIN = 'NOT USED' - ENDIF - -8035 IF(INCLUDPAST .EQ. 1) THEN - - WRITE(*,8003) -8003 FORMAT(/' ENTER 1 IF THE FILE WHICH HAS THE "PAST" INFO FOR'/ - 1' THE SUBJECT OF THIS RUN IS A .CSV FILE (IN THIS CASE,'/ - 2' THE INFO FOR THE FIRST SUBJECT IN THE .CSV FILE WILL'/ - 3' BE USED); '/ - 4' ENTER 0 IF THE FILE WHICH HAS THE "PAST" INFO FOR THE SUBJECT'/ - 5' OF THIS RUN IS A WORKING COPY FILE: ') - READ(*,*,ERR=8035) IPASTFILE - IF(IPASTFILE .NE. 1 .AND. IPASTFILE .NE. 0) GO TO 8035 - - IF(IPASTFILE .EQ. 0) THEN - - WRITE(*,1021) - READ(*,2) PASTFILEIN - IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = PASTFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8050,STATUS='OLD') - GO TO 8045 - - 8050 WRITE(*,5316) PATHFILE - GO TO 8030 - - 8045 CONTINUE - - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - CLOSE(21) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 0) CONDITION. - - - IF(IPASTFILE .EQ. 1) THEN - - WRITE(*,8021) - 8021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ - 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ - 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// - 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,2) PASTFILEIN - IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = PASTFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,ERR=8060,STATUS='OLD') - - GO TO 8055 - 8060 WRITE(*,5316) PATHFILE - GO TO 8030 - 8055 CONTINUE - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - - CALL CONVERTCSV - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE - -C READBLOCK2. - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - -C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.PST IN THE -C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN -C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. - - REWIND(66) - - CALL READBLOCK2(PATH,C0,C1,C2,C3,1,0) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - TMPFILE = ' ' - TMPFILE = 'XQZPJ001.PST' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8065,STATUS='OLD') - GO TO 8070 - 8065 WRITE(*,5466) PATHFILE,PASTFILEIN - GO TO 8030 - - 8070 CONTINUE - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - CLOSE(21) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 1) CONDITION. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1) CONDITION. - - - IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN - - - 8080 WRITE(*,8077) - 8077 FORMAT(/' FOR THE NPAG ANALYSIS WHICH WILL OBTAIN THE POSTERIOR'/ - 1' DENSITY (WHICH WILL THEN BE THE DENSITY FOR THE OPTIMIZATION)'/ - 2' SELECT THE MAXIMUM NO. OF CYCLES IT SHOULD RUN. THE DEFAULT'/ - 3' IS A MAXIMUM OF 500 CYCLES. '// - 4' SELECT 1 FOR 500 CYCLE;'/ - 5' SELECT 0 FOR A DIFFERERENT NO. OF MAXIMUM CYCLES: ') - READ(*,*,ERR=8080) MAXCYC - IF(MAXCYC .NE. 1 .AND. MAXCYC .NE. 0) GO TO 8080 - - IF(MAXCYC .EQ. 1) MAXCYC = 500 - - IF(MAXCYC .EQ. 0) THEN - 8090 WRITE(*,8091) - 8091 FORMAT(/' ENTER A POSITIVE NO. FOR THE MAXIMUM NO. OF CYCLES'/ - 1' THE NPAG ANALYSIS SHOULD RUN: ') - READ(*,*,ERR=8090) MAXCYC - IF(MAXCYC .LT. 1) GO TO 8090 - ENDIF - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. - - - - 5020 WRITE(*,5002) - 5002 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN CAN BE INPUT VIA'/ - 1' A (MULTIPLE DRUG) WORKING COPY PATIENT DATA FILE OR A BLOCK '/ - 2' MATRIX .CSV FILE (THE INFO WILL COME FROM THE DATA OF THE'/ - 3' FIRST SUBJECT IN THIS CASE).'// - 5' ENTER 1 TO ENTER INFO USING A .CSV FILE; '/ - 6' ENTER 0 TO ENTER INFO USING A WORKING COPY PATIENT DATA FILE: ') - READ(*,*,ERR=5020) ICSVFILE - IF(ICSVFILE .NE. 1 .AND. ICSVFILE .NE. 0) GO TO 5020 - - - IF(ICSVFILE .EQ. 0) THEN - - WRITE(*,1021) - 1021 FORMAT(/' ENTER THE NAME OF THE WORKING COPY PATIENT DATA FILE.' - 1// - 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,2) FUTUREFILEIN - IF(FUTUREFILEIN(1:3) .EQ. '-99') - 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE - -C CURRENT DIRECTORY). - - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=6440,STATUS='OLD') - GO TO 6455 - 6440 WRITE(*,5316) PATHFILE - GO TO 5020 - 6455 CONTINUE - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 0) CONDITION. - - - IF(ICSVFILE .EQ. 1) THEN - - WRITE(*,3021) - 3021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ - 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ - 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// - 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,2) FUTUREFILEIN - IF(FUTUREFILEIN(1:3) .EQ. '-99') - 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,ERR=5440,STATUS='OLD') - - GO TO 5455 - 5440 WRITE(*,5316) PATHFILE - GO TO 5020 - 5455 CONTINUE - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, - - -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - CALL CONVERTCSV - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF - - -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE -C READBLOCK2. - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - -C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.FUT IN THE -C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN -C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. - - REWIND(66) - - CALL READBLOCK2(PATH,C0,C1,C2,C3,2,0) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - - TMPFILE = ' ' - TMPFILE = 'XQZPJ001.FUT' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=5465,STATUS='OLD') - GO TO 5470 - 5465 WRITE(*,5466) PATHFILE,FUTUREFILEIN - 5466 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ - 1' ',A73/ - 2' WHICH MEANS THAT YOUR .CSV FILE, ',A20,' WAS NOT READ '/ - 3' PROPERLY. PLEASE CHECK THIS FILE TO MAKE SURE IT IS CORRECT.'//) - GO TO 5020 - - - 5470 CONTINUE - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. - -C AT THIS POINT, FILE 21 CONTAINS THE WORKING COPY FILE TO BE USED -C FOR THIS RUN (VIA EITHER THE ICSVFILE .EQ. 0 OR THE ICSVFILE .EQ. 1 -C BLOCK). CALL GETNUMEQ WHICH WILL READ THIS FILE 21 AND OBTAIN -C NUMEQT AND NDRUG. - - CALL GETNUMEQ(NUMEQT,NDRUG) - CLOSE(21) - -C IF INCLUDPAST = 0, IT MEANS THAT THE USER IS PROVIDING NO "PAST" -C HISTORY FOR THE SUBJECT. IN THIS CASE, SET TNEXT = 0.0. OTHERWISE, -C HAVE THE USER ENTER TNEXT. - - IF(INCLUDPAST .EQ. 0) TNEXT = 0.D0 - - IF(INCLUDPAST .EQ. 1) THEN - 8040 WRITE(*,8041) PASTFILEIN,FUTUREFILEIN - 8041 FORMAT(/' YOUR ANALYSIS INCLUDES THE "PAST" HISTORY FOR THE'/ - 1' SUBJECT IN FILE ',A20,' AND THE "FUTURE" IN FILE ',A20/ - 2' IT WILL BE ASSUMED THAT THE "PAST" BEGINS AT TIME = 0, AND THE'/ - 3' "FUTURE" BEGINS AT TIME = TNEXT. IN OTHER WORDS, THE "FUTURE"'/ - 4' FILE SHOULD START AS USUAL WITH TIME = 0, BUT ALL THE TIMES IN'/ - 5' THIS FILE WILL BE INCREASED BY TNEXT HOURS, AND THEN THIS FILE'/ - 6' WILL BE CONCATENATED TO THE "PAST" TO PROVIDE A COMPLETE'/ - 7' DOSING/OBSERVED VALUE PROFILE OF THE SUBJECT.'// - 8' BUT NOTE THAT OPTIMUM DOSES WILL BE FOUND ONLY IN THE "FUTURE"'/ - 9' TO BEST ACHIEVE THE OBSERVED VALUES IN THE "FUTURE" ... BASED'/ - 1' ON THE "PAST" HISTORY. '// - 2' ENTER TNEXT, A POSTIVE NO. OF HOURS, NOW: ') - READ(*,*,ERR=8040) TNEXT - IF(TNEXT .LE. 0.D0) GO TO 8040 - ENDIF - - 8170 WRITE(*,8172) - 8172 FORMAT(/' THE OUTPUT FILE WILL INCLUDE, FOR EACH GRID POINT IN '/ - 1' THE PARAMETER DENSITY (AND THE WEIGHTED MEAN OF THESE GRID'/ - 2' POINTS), SIMULATED OBSERVED VALUES, BASED ON THE OPTIMAL DOSES'/ - 3' WHICH THE PROGRAM CALCULATES.'// - 4' ENTER 1 IF THESE VALUES SHOULD BE SIMULATED EVERY 15 MINUTES'/ - 5' 0 FOR A DIFFERENT NO. OF MINUTES BETWEEN SIMULATED VALUES: - 6 ') - - READ(*,*,ERR=8170) IDELTA - IF(IDELTA .NE. 1 .AND. IDELTA .NE. 0) GO TO 8170 - - IF(IDELTA .EQ. 1) IDELTA = 15 - - - IF(IDELTA .EQ. 0) THEN - - WRITE(*,8173) - 8173 FORMAT(/' ENTER THE NO. OF MINUTES BETWEEN SIMULATED VALUES: ') - READ(*,*,ERR=8170) IDELTA - IF(IDELTA .LE. 0) GO TO 8170 - ENDIF - - -C ENTER THE FIXED VALUES FOR THE PARAMETERS. - - IF(NOFIX .GT. 0) THEN - WRITE(*,4836) - 4836 FORMAT(/' ENTER THE VALUE FOR EACH FIXED PARAMETER: ') - DO I = 1,NOFIX - 4845 WRITE(*,34) PARFIX(I) - 34 FORMAT(/' ',A11,' : ') - 4840 READ(*,*,ERR=4845) VALFIX(I) - END DO - ENDIF - - -C READ IN VALUES FOR MF, RTOL, AND ATOL, WHICH ARE NEEDED FOR THE -C O.D.E. SOLVER USED BY ROUTINE USERANAL. - -C MF = Method flag. Standard values are.. -C 10 for nonstiff (Adams) method, no Jacobian used. -C 21 for stiff (BDF) method, user-supplied full Jacobian. -C 22 for stiff method, internally generated full Jacobian. - -C FOR NOW MF = 22 WILL BE HARDCODED (SINCE THERE IS NO -C JACOBIAN SUBROUTINE (JACOB HAS BEEN TAKEN OUT FOR NOW). - -C 24 for stiff method, user-supplied banded Jacobian. -C 25 for stiff method, internally generated banded Jacobian. -C RTOL = Relative tolerance parameter (scalar). -C ATOL = Absolute tolerance parameter. -C The estimated local error in X(i) will be controlled so as -C to be roughly less (in magnitude) than -C EWT(i) = RTOL*abs(X(i)) + ATOL(i) SINCE ITOL = 2. - -C Thus the local error test passes if, in each component, -C either the absolute error is less than ATOL (or ATOL(i)), -C or the relative error is less than RTOL. -C Use RTOL = 0.0 for pure absolute error control, and -C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error -C control. Caution.. Actual (global) errors may exceed these -C local tolerances, so choose them conservatively. - - - - 915 WRITE(*,913) - 913 FORMAT(/' ENTER 1 TO SET ALL TOLERANCES (FOR THE O.D.E. '/ - 1' SOLVER) TO THE DEFAULT VALUE ... 1.D-4.'/ - 2' ENTER 0 TO SELECT A DIFFERENT VALUE FOR THE TOLERANCES: ') - READ(*,*,ERR=915) ITOL - IF(ITOL .NE. 0 .AND. ITOL .NE. 1) GO TO 915 - - TOLER = 1.D-4 - - - IF(ITOL .EQ. 0) THEN - - 910 WRITE(*,914) - 914 FORMAT(/' ENTER A POSITIVE VALUE FOR THE TOLERANCE PARAMETERS: ') - READ(*,*,ERR=910) TOLER - IF(TOLER .LE. 0.D0) GO TO 910 - - ENDIF - - - RTOL = TOLER - DO I=1,NDIM - ATOL(I) = TOLER - END DO - - MF = 22 - -C ENTER IERRMOD AND GAMLAM HERE. - - CALL SYSTEM('CLS') - - 1110 WRITE(*,118) NPAGDENFILE - 118 FORMAT(//' SELECT HOW YOU MODELED THE ASSAY ERROR FUNCTION IN '/ - 1' THE NPAG RUN YOU DID WHICH PRODUCED THE DENSITY FILE, ',A20// - 1' RECALL THAT SD1 = C0+C1*Y+C2*Y**2+C3*Y**3; THEN ...'// - 2' ENTER 1 IF S.D. = SD1;'/ - 3' ENTER 2 IF S.D. = GAMMA*SD1, WITH GAMMA TO BE ESTIMATED;'/ - 4' ENTER 3 IF S.D. = SQRT(SD1**2 + LAMBDA**2), WITH LAMBDA TO BE ES - 5TIMATED;'/ - 6' ENTER 4 IF S.D. = GAMMA, WITH GAMMA TO BE ESTIMATED: ') - READ(*,*,ERR=1110) IERRMOD - IF(IERRMOD .LT. 1 .OR. IERRMOD .GT. 4) GO TO 1110 - - - IF(IERRMOD .GE. 2) THEN - - ESTNAM = ' GAMMA' - IF(IERRMOD .EQ. 3) ESTNAM = 'LAMBDA' - 225 WRITE(*,223) ESTNAM - 223 FORMAT(/' ENTER THE FINAL ESTIMATE FOR ',A6,' IN THE NPAG RUN: - 1 ') - READ(*,*,ERR=225) GAMLAM - - IF(GAMLAM .LE. 0.D0) THEN - WRITE(*,1223) - 1223 FORMAT(/' THIS VALUE MUST BE POSITIVE. '/) - GO TO 225 - ENDIF - - ENDIF - - - CALL SYSTEM('CLS') - - WRITE(*,119) - 119 FORMAT(//' FOR EACH OUTPUT EQUATION(S), SELECT ONE OF THE FOLLOWIN - 1G'/ - 5' OPTIONS FOR THE ASSAY COEFFICIENTS [C0,C1,C2,C3]: '// - 4' ENTER 1 FOR THE DEFAULT OPTION ...'/ - 5' IF THE PATIENT DATA FILE ALREADY INCLUDES '/ - 6' ASSAY COEFFICIENTS, THOSE COEFFICIENTS WILL BE USED. '/ - 7' OTHERWISE THE COEFFICIENTS YOU ENTER BELOW WILL BE '/ - 8' USED;'/ - 7' ENTER 0 IF YOU WOULD LIKE THE ASSAY COEFFICIENTS TO BE THOSE'/ - 1' YOU ENTER BELOW (WHETHER OR NOT YOUR PATIENT FILE HAS'/ - 2' ASSAY COEFFICIENTS ALREADY: ') - - CALL PAUSE - -C FOR EACH OUTPUT, INPUT IASS AND [C0P,...,C3P]. - - DO 2200 IEQ = 1,NUMEQT - - 1120 WRITE(*,221) IEQ - 221 FORMAT(/' FOR OUTPUT EQUATION ',I1,':'// - 4' ENTER 1 FOR THE DEFAULT OPTION;'// - 7' ENTER 0 TO BE PROMPTED FOR ASSAY COEFFICIENTS: ') - READ(*,*,ERR=1120) IAS - IF(IAS .NE. 0 .AND. IAS .NE. 1) GO TO 1120 - IASS(IEQ) = IAS - - WRITE(*,1119) IEQ - 1119 FORMAT(/' ENTER THE GENERAL VALUES FOR [C0,C1,C2,C3] FOR '/ - 1' OUTPUT EQUATION ',I1,'. THESE ') - IF(IAS .EQ. 1) WRITE(*,1121) - IF(IAS .EQ. 0) WRITE(*,1123) - 1121 FORMAT(' WILL BE USED IF YOUR PATIENT DATA FILE DOES NOT'/ - 1' ALREADY INCLUDE ASSAY COEFFICIENTS: ') - 1123 FORMAT(' WILL BE USED EVEN IF YOUR PATIENT DATA FILE ALREADY'/ - 1' INCLUDES ASSAY COEFFICIENTS: ') - 4140 READ(*,*,ERR=4145) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - GO TO 2200 - 4145 WRITE(*,4146) - 4146 FORMAT(/' SEE ABOVE; PLEASE ENTER FOUR REAL NUMBERS: ') - GO TO 4140 - - - 2200 CONTINUE - - - WRITE(*,2119) - 2119 FORMAT(//' NOTE: DURING THIS PROGRAM, THE PATIENT DATA FILE'/ - - 1' WILL HAVE ITS COEFFICIENTS WRITTEN TO THE END OF THE '/ - 2' WORKING COPY FILE. IF COEFFICIENTS ARE ALREADY THERE'/ - 3' FROM A PREVIOUS RUN, THEY WILL BE OVERWRITTEN.'//) - CALL PAUSE - - -4150 WRITE(*,129) - 129 FORMAT(//' ENTER THE ACTIVE (SALT) FRACTION OF EACH DRUG. AS '/ - - 1' AN EXAMPLE, THE A.F. OF THEOPHYLLINE IS 1.0, WHILE THAT OF'/ - 2' AMINOPHYLLINE IS TYPICALLY BETWEEN .79 AND .85, DEPENDING ON'/ - 3' THE PREPARATION. '// - 4' EACH AF MUST BE A POSITIVE NUMBER LESS THAN OR EQUAL TO 1.0.'/) - - DO I = 1,NDRUG - WRITE(*,1129) I - 1129 FORMAT(' AF FOR DRUG ',I1,': ') - READ(*,*,ERR=4150) AF(I) - IF(AF(I) .LE. 0.0 .OR. AF(I) .GT. 1.0) GO TO 4150 - END DO - - - 3130 WRITE(*,3129) - 3129 FORMAT(/' THE COMMENTS ABOVE HAVE ALL BEEN BASED ON THE '/ - 1' ASSUMPTION THAT YOU WANT TO FIND THE OPTIMUM DOSES TO HIT THE'/ - 2' TARGET CONCENTRATIONS IN THE "FUTURE" FILE.'// - 3' ENTER 1 IF THIS IS TRUE; '/ - 4' ENTER 0 IF, INSTEAD, YOU WANT THE OUTPUT FILE TO SHOW '/ - 5' PREDICTED CONCENTRATIONS AND AUCs FOR THE DOSES IN '/ - 6' THE "FUTURE" FILE (I.E., NO OPTIMIZATION WILL BE DONE'/ - 7' IN THIS CASE): ') - READ(*,*,ERR=3130) IOPTIMIZE - IF(IOPTIMIZE .NE. 1 .AND. IOPTIMIZE .NE. 0) GO TO 3130 - -C IF IOPTIMIZE = 0, NO OPTIMIZATION IS TO BE DONE, WHICH RENDERS THE -C QUESTION ABOUT BIASWEIGHT BELOW MOOT. IN THIS CASE, SIMPLY SET -C BIASWEIGHT = 0. BUT IF IOPTIMIZE = 1, THEN QUESTION THE USER ABOUT -C HOW THE COST FUNCTION (WHICH ESTABLISHES THE BEST DOSES) SHOULD BE -C CALCULATED. SIMILARLY FOR ITARGET. IT IS IRRELEVANT IF NO -C OPTIMIZATION IS TO BE DONE. SO SET IT = 1 IF IOPTIMIZE = 0. - - ITARGET = 1 - - BIASWEIGHT = 0.D0 - - - IF(IOPTIMIZE .EQ. 1) THEN - - 3140 WRITE(*,3139) - 3139 FORMAT(/' THE COST FUNCTION TO BE MINIMIZED IN FINDING THE'/ - 1' "BEST" DOSES IS (1 - BIASWEIGHT)*V(U) + BIASWEIGHT*B(U), WHERE'/ - 2' V(U) IS THE MEAN SQUARED ERROR ASSOCIATED WITH ALL THE '/ - 3' GRID PTS. IN THE PARAMETER DENSITY; AND B(U) IS THE MEAN '/ - 4' SQUARED ERROR DUE TO BIAS ABOUT THE MEAN RESPONSE.'// - 5' ENTER THE VALUE FOR BIASWEIGHT BETWEEN 0 AND 1, INCLUSIVE: ') - READ(*,*,ERR=3140) BIASWEIGHT - IF(BIASWEIGHT .LT. 0.D0 .OR. BIASWEIGHT .GT. 1.D0) GO TO 3140 - -3150 WRITE(*,3149) - 3149 FORMAT(/' ENTER 1 IF THE OBSERVED VALUES IN THE FUTURE PATIENT'/ - 1' FILE ARE TARGET CONCENTRATIONS; '/ - 2' ENTER 2 IF THE OBSERVED VALUES ARE TARGET AUCs: ') - READ(*,*,ERR=3150) ITARGET - IF(ITARGET .NE. 1 .AND. ITARGET .NE. 2) GO TO 3150 - - - ENDIF -C THE ABOVE ENDIF IS FOR THE IF(IOPTIMIZE .EQ. 1) CONDITION. - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 0) CONDITION. - - -C AS OF BESTDOS105.FOR, THE IF(IAF .EQ. 0) CODE IS REMOVED SINCE -C IAF IS ALWAYS 1 ... IN FACT, ALL CODE FOR IAF IS REMOVED SINCE IT IS -C NO LONGER NEEDED. - - -C PRINT TO THE SCREEN ALL INPUT INFO FOR VERIFICATION. - - CALL VERIF1(FORFILE,ICSVFILE,FUTUREFILEIN,PATH,NOB,C0P,C1P,C2P, - 1 C3P,NUMEQT,NOFIX,VALFIX,PARFIX,TOLER,ATOL,IASS,AF,MATFIL, - 2 NPAGDENFILE,INCLUDPAST,IPASTFILE,PASTFILEIN,IERRMOD, - 3 GAMLAM,NDRUG,IPRIOROBS,TNEXT,IDELTA,MAXOBDIM,MAXCYC,IOPTIMIZE, - 4 BIASWEIGHT,ITARGET) - - -C GIVE USER OPTION TO SAVE INPUT DATA TO AN INPUT FILE (FOR ANOTHER -C RUNNING OF THE PROGRAM). - - 4610 WRITE(*,4601) - 4601 FORMAT(//' ENTER 1 TO SAVE THE INFORMATION FOR THIS RUN INTO'/ - 1' A FILE;'/ - 1' ENTER 0 OTHERWISE: ') - READ(*,*,ERR=4610) ISAVFL - - IF (ISAVFL .NE. 0 .AND. ISAVFL .NE. 1) GO TO 4610 - - - IF(ISAVFL .EQ. 1) THEN - - 1960 WRITE(*,4616) - 4616 FORMAT(/' ENTER THE DESIRED FILENAME: ') - READ(*,2) SAVFIL - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE - -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = SAVFIL - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(24,FILE=PATHFILE,ERR=1970,STATUS='NEW') - GO TO 1975 - - 1970 WRITE(*,9826) PATHFILE - 9826 FORMAT(/' THE FOLLOWING FILE ALREADY EXISTS ....'/ - 1' ',A73/ - 1' ENTER 0 TO ENTER A NEW FILENAME;'/ - 2' ENTER 1 TO OVERWRITE THIS FILE: ') - READ(*,*,ERR=1970) IFILE - IF(IFILE .NE. 0 .AND. IFILE .NE. 1) GO TO 1970 - IF(IFILE .EQ. 0) GO TO 1960 - IF(IFILE .EQ. 1) OPEN(24,FILE=PATHFILE) - - 1975 WRITE(24,7123) 'BESTDOS OCT_13' - - WRITE(24,8111) - 8111 FORMAT(' MODEL FILENAME') - WRITE(24,2) FORFILE - - - WRITE(24,8112) - 8112 FORMAT(' IRAN INDICES') - WRITE(24,*) (IRAN(I),I=1,NP) - - WRITE(24,9006) - 9006 FORMAT(' NPAG DENSITY FILE') - WRITE(24,2) NPAGDENFILE - - - WRITE(24,9017) - 9017 FORMAT(' MAXCYC') - WRITE(24,*) MAXCYC - - WRITE(24,9004) - 9004 FORMAT(' INCLUDPAST') - WRITE(24,*) INCLUDPAST - - WRITE(24,9008) - 9008 FORMAT(' IPASTFILE') - WRITE(24,*) IPASTFILE - - WRITE(24,9011) - 9011 FORMAT(' PASTFILEIN') - WRITE(24,2) PASTFILEIN - - WRITE(24,8116) - 8116 FORMAT(' ICSVFILE') - WRITE(24,*) ICSVFILE - - WRITE(24,8117) - 8117 FORMAT(' FUTUREFILEIN') - WRITE(24,2) FUTUREFILEIN - - WRITE(24,8118) - 8118 FORMAT(' TNEXT') - WRITE(24,*) TNEXT - - - WRITE(24,8171) - 8171 FORMAT(' IDELTA') - WRITE(24,*) IDELTA - - WRITE(24,8119) - 8119 FORMAT(' NOFIX') - WRITE(24,*) NOFIX - - WRITE(24,8121) - 8121 FORMAT(' VALFIX ARRAY IF NOFIX > 0') - - - IF(NOFIX .GT. 0) WRITE(24,2416) (VALFIX(I),I=1,NOFIX) - 2416 FORMAT(30(G14.7,1X)) - - WRITE(24,8122) - 8122 FORMAT(' TOLER') - WRITE(24,*) TOLER - - WRITE(24,8123) - 8123 FORMAT(' NUMEQT') - WRITE(24,*) NUMEQT - - WRITE(24,8124) - 8124 FORMAT(' NUMEQT LINES OF ASSAY COEFFICIENTS') - DO IEQ=1,NUMEQT - WRITE(24,2416) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - END DO - - WRITE(24,8133) - 8133 FORMAT(' IERRMOD') - WRITE(24,*) IERRMOD - - WRITE(24,8134) - - 8134 FORMAT(' GAMLAM') - IF(IERRMOD .EQ. 1) WRITE(24,*)' -99' - IF(IERRMOD .GE. 2) WRITE(24,*) GAMLAM - - - WRITE(24,8127) - 8127 FORMAT(' IASS(I),I=1,NUMEQT') - WRITE(24,*) (IASS(I),I=1,NUMEQT) - - WRITE(24,9131) - - 9131 FORMAT(' NDRUG') - WRITE(24,*) NDRUG - - WRITE(24,8131) - 8131 FORMAT(' AF(I),I=1,NDRUG') - WRITE(24,*) (AF(I),I=1,NDRUG) - - WRITE(24,8132) - - 8132 FORMAT(' IOPTIMIZE') - WRITE(24,*) IOPTIMIZE - - WRITE(24,8136) - 8136 FORMAT(' BIASWEIGHT') - WRITE(24,*) BIASWEIGHT - - WRITE(24,8138) - 8138 FORMAT(' ITARGET') - WRITE(24,*) ITARGET - - - CLOSE(24) - - - ENDIF - -C ABOVE ENDIF IS FOR THE IF(ISAVFL .EQ. 1) CONDITION. - - -C IF THE FILE 'GUICMDS.INX' EXISTS IN THE WORKING DIRECTORY, CONTROL -C IS TRANSFERRED TO LABEL 1450 IMMEDIATELY AFTER THAT FILE HAS -C BEEN READ ABOVE. - - 1450 CONTINUE - - -C SET NOFIXXX TO NOFIX, AND NDIMMM TO NDIM. THEY ARE SUPPLIED IN -C DIFFERENT COMMON STATEMENTS, AND THEREFORE MUST HAVE DIFFERENT NAMES. - - - NOFIXXX = NOFIX - NDIMMM = NDIM - - -C OPEN AND READ NPAGDENFILE. IF INCLUDPAST = 1 (WHICH MEANS THE USER -C HAS PROVIDED A "PAST" HISTORY FILE (PASTFILEIN) FOR THE SUBJECT OF -C THIS RUN, AND IF IPRIOROBS = 1 (WHICH MEANS THAT THIS FILE HAS -C NON-MISSING OBSERVED VALUES), THEN THE FOLLOWING CODE WILL BE USED -C TO CALL ROUTINE NPAGFULL TO GET THE POSTERIOR DENSITY FOR THE -C SUBJECT, WHICH WILL BE STORED INTO THE ARRAY, DENSITY. OTHERWISE, THE -C ARRAY, DENSITY, IS GOTTEN DIRECTLY FROM NPAGDENFILE. - - TMPFILE = ' ' - TMPFILE = NPAGDENFILE - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(34,FILE=PATHFILE) - READ(34,7123) CODE - - IVER = 0 - IF(CODE .EQ. 'DENSITY APR_10') IVER = 1 - IF(CODE .EQ. 'DENSITY OCT_15') IVER = 2 - - IF(IVER .EQ. 0) THEN - - WRITE(*,7126) NPAGDENFILE - 7126 FORMAT(/' YOUR DENSITY FILE, ',A20,' IS NOT AN UP-TO-DATE'/ - 1' DENSITY FILE.'// - 2' PLEASE RERUN THE PROGRAM AFTER ENSURING THAT YOUR DENSITY '/ - 3' FILE HAS "DENSITY APR_10" OR "DENSITY OCT_15" ON THE FIRST'/ - 4' LINE.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,7126) NPAGDENFILE - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - -C AS THE INFO OF THE DENSITY FILE IS BEING READ, VERIFY THAT IT -C MATCHES THE INFO READ IN ABOVE. IF NOT, STOP THE PROGRAM, AND TELL -C THE USER THE REASON. - - READ(34,*) NDIMM - IF(NDIM .NE. NDIMM) THEN - - WRITE(*,7127) NPAGDENFILE,NDIMM,NDIM,FORFILE - 7127 FORMAT(/' NDIM READ IN FROM YOUR DENSITY FILE, ',A20/ - 1' IS ',I3,' WHICH DOES NOT MATCH THE VALUE OF ',I3,' READ IN '/ - 2' FROM YOUR MODEL FILE, ',A20 // - - 3' PLEASE RERUN THE PROGRAM AFTER ENSURING COMPATIBILITY BETWEEN'/ - 4' THESE TWO FILES. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,7127) NPAGDENFILE,NDIMM,NDIM,FORFILE - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - READ(34,*) INDPTS - IF(INDPTS .EQ. 1) NGRID=2129 - IF(INDPTS .EQ. 2) NGRID=5003 - IF(INDPTS .EQ. 3) NGRID=10007 - IF(INDPTS .EQ. 4) NGRID=20011 - IF(INDPTS .EQ. 5) NGRID=40009 - IF(INDPTS .EQ. 6) NGRID=80021 - IF(INDPTS .GT. 6) NGRID = 80021*(INDPTS - 100) - - READ(34,*) NACTVE - - IF(NACTVE .GT. MAXGRD) THEN - - WRITE(*,7128) NPAGDENFILE,NACTVE,MAXGRD,MAXGRD - 7128 FORMAT(//' THE NO. OF ACTIVE GRID POINTS IN YOUR DENSITY'/ - 1' FILE, ',A20,' IS ',I7,' WHICH IS MORE THAN THE MAXIMUM ALLOWED'/ - 2' FOR THIS PROGRAM (',I7,'). PLEASE RERUN THE PROGRAM WITH A'/ - 3' DENSITY FILE HAVING NO MORE THAN ',I7,' ACTIVE GRID POINTS. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,7128) NPAGDENFILE,NACTVE,MAXGRD,MAXGRD - CLOSE(47) - - CALL PAUSE - STOP - - - ENDIF - - READ(34,*) NVARR - - IF(NVAR .NE. NVARR) THEN - - WRITE(*,7129) NPAGDENFILE,NVARR,NVAR,FORFILE - 7129 FORMAT(/' NVAR READ IN FROM YOUR DENSITY FILE, ',A20/ - 1' IS ',I3,' WHICH DOES NOT MATCH THE VALUE OF ',I3,' READ IN '/ - 2' FROM YOUR MODEL FILE, ',A20 // - 3' PLEASE RERUN THE PROGRAM AFTER ENSURING COMPATIBILITY BETWEEN'/ - 4' THESE TWO FILES. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,7129) NPAGDENFILE,NVARR,NVAR,FORFILE - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - -C AS OF BESTDOS121.FOR, THE DENSITY FILE CAN BE EITHER HAVE CODE -C "DENSITY APR_10" OR "DENSITY OCT_15". IN THE FORMER CASE, THERE ARE -C NO RANFIX PARAMETERS. IN THE LATTER CASE, THERE MAY BE RANFIX -C PARAMETERS (I.E., THOSE WHICH WERE FIXED BUT UNKNOWN, AND THEREFORE -C ESTIMATED IN THE NPAG RUN WHICH PRODUCED THIS DENSITY FILE). IN -C THIS LATTER CASE, THESE RANFIX PARAMETERS WERE ESTIMATED AND NOW -C WILL BE TREATED AS IF THEY WERE FIXED AND KNOWN, I.E., THEY WILL -C BE TREATED AS FIXED PARAMETERS. SO THEY WILL BE COMBINED WITH THE -C OTHER FIXED PARAMETERS. - -C READ IN PAR, NOFIX, AND PARFIX. NOTE THAT NOFIX SHOULD MATCH NOFIX -C READ IN ABOVE FROM THE MODEL FILE, BUT THAT IT IS POSSIBLE THE USER -C HAS USED SLIGHTLY DIFFERENT NAMES FOR PAR AND PARFIX IN THE MODEL -C FILE AND IN THE DENSITY FILE, SO THESE WILL NOT BE CHECKED FOR -C CONSISTENCY. - - READ(34,1717) (PAR(I),I=1,NVAR) - 1717 FORMAT(A11) - - READ(34,*) NOFIXX1 - READ(34,1717) (PARFIX(I),I=1,NOFIXX1) - - IF(IVER .EQ. 2) THEN - READ(34,*) NRANFIX - READ(34,1717) (PARRANFIX(I),I=1,NRANFIX) - ENDIF - -C AS INDICATED ABOVE, SET THE NEW NO. OF FIXED PARAMETERS TO BE THE -C NO. THAT WERE ORIGINALLY FIXED AND KNOWN (NOFIXX1) + THE NO. THAT -C WERE ORIGINALLY FIXED AND UNKNOWN (NRANFIX) SINCE RANFIX -C PARAMETERS ARE TREATED THE SAME AS FIXED PARAMETERS IN THIS PROGRAM. - - NOFIXX = NOFIXX1 + NRANFIX - - IF(NOFIXX .NE. NOFIX) THEN - - WRITE(*,7131) NPAGDENFILE,NOFIXX,NOFIX - 7131 FORMAT(/' THE NO. OF FIXED PARAMETERS (WHICH INCLUDES THOSE'/ - 1' WHICH WERE ORIGINALLY FIXED AND KNOWN AS WELL AS THOSE WHICH'/ - 2' WERE ORIGINALLY FIXED AND UNKNOWN IN THE NPAG RUN) WHICH WERE'/ - 3' READ IN FROM YOUR DENSITY FILE, ',A20/ - 4' IS ',I3,' WHICH DOES NOT MATCH THE VALUE OF ',I3,' READ IN '/ - 2' ABOVE FROM AN INSTRUCTION FILE OR THE KEYBOARD.' // - 3' PLEASE RERUN THE PROGRAM AFTER ENSURING COMPATIBILITY BETWEEN'/ - 4' THESE TWO FILES. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,7131) NPAGDENFILE,NOFIXX,NOFIX,FORFILE - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - DO I=1,NVAR - READ(34,*) (AB(I,J),J=1,2) - END DO - - READ(34,*) (VALFIXX(I),I=1,NOFIXX1) - IF(IVER .EQ. 2) READ(34,*) (VALFIXX(I+NOFIXX1),I=1,NRANFIX) - -C VERIFY THAT ALL THE VALFIXX VALUES ARE THE SAME AS THOSE READ IN -C ABOVE FOR VALFIX. NOTE THAT ISAME RETURNED FROM CALL TO THESAME -C IS 1 IF THE TWO PRECEEDING ARGUMENTS ARE WITHIN 1.D-10 OF EACH -C OTHER (I.E., VIRTUALLY THE SAME VALUE); OTHERWISE IT RETURNS AS 0. - - DO I = 1,NOFIX - - CALL THESAME(VALFIXX(I),VALFIX(I),ISAME) - - IF(ISAME .EQ. 0 .AND. I .LE. NOFIXX1) THEN - - WRITE(*,7132) I,NPAGDENFILE,VALFIXX(I),VALFIX(I),VALFIXX(I) - 7132 FORMAT(/' FIXED VALUE NO. ',I2,' FROM YOUR DENSITY '/ - 1' FILE, ',A20,' IS ',G14.7,' WHICH DOES NOT MATCH THE VALUE '/ - 2' OF ',G14.7,' READ IN ABOVE.'// - 3' THE VALUE USED IN THIS RUN WILL BE ',G14.7/) - - CALL PAUSE - - ENDIF - - CALL THESAME(VALFIXX(I),VALFIX(I),ISAME) - - IF(ISAME .EQ. 0 .AND. I .GT. NOFIXX1) THEN - - WRITE(*,7133) I,I-NOFIXX1,NPAGDENFILE,VALFIXX(I),VALFIX(I), - 1 VALFIXX(I) - 7133 FORMAT(/' FIXED VALUE NO. ',I2,' WHICH WAS RANFIX VALUE'/ - 1' NO. ',I2,' IN THE NPAG RUN WHICH PRODUCED YOUR DENSITY '/ - 2' FILE, ',A20,' IS ',G14.7,' WHICH DOES NOT MATCH THE VALUE '/ - 2' OF ',G14.7,' READ IN ABOVE.'// - 3' THE VALUE USED IN THIS RUN WILL BE ',G14.7/) - - - CALL PAUSE - - ENDIF - - - END DO -C??? THE ABOVE END DO IS FOR THE DO I = 1,NOFIX LOOP. - - - - READ(34,*) - READ(34,*) - READ(34,*) - - DO I=1,NACTVE - READ(34,*) (CORDEN(I,J),J=1,NVAR+1) - END DO - - CLOSE(34) - - - IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN - - -C SINCE INCLUDPAST = 1 (WHICH MEANS THE USER HAS PROVIDED A "PAST" -C HISTORY FILE (PASTFILEIN) FOR THE SUBJECT OF THIS RUN, AND -C IPRIOROBS = 1 (WHICH MEANS THAT THIS FILE HAS NON-MISSING OBSERVED -C VALUES), THE FOLLOWING CODE WILL BE USED TO CALL ROUTINE NPAGFULL TO -C GET THE POSTERIOR DENSITY FOR THE SUBJECT, WHICH WILL BE -C STORED INTO THE ARRAY, DENSITY. - -C BEFORE CALLING NPAGFULL, PUT ("STACK") THE "PAST" SUBJECT FILE INTO -C FILE 27, SO IT WILL BE READY TO GO IN SUBROUTINE NPAGFULL. - - -C FIRST, ESTABLISH THIS "PAST" SUBJECT IN WORKING COPY FORMAT. -C TMPFILE WILL BE PASTFILEIN IF IPASTFILE = 0, AND IT WILL BE -C 'XQZPJ001.PST' IF IPASTFILE = 1. - - TMPFILE = ' ' - IF(IPASTFILE .EQ. 0) TMPFILE = PASTFILEIN - IF(IPASTFILE .EQ. 1) TMPFILE = 'XQZPJ001.PST' - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - -C CALL SUBROUTINE PUTASS TO MAKE SURE THAT THE WORKING COPY PATIENT -C FILE HAS THE DESIRED ASSAY COEFFICIENTS WRITTEN AT THE END OF IT. - - CALL PUTASS(PATHFILE,IASS,C0P,C1P,C2P,C3P,NUMEQT) - -C OPEN THE PATIENT DATA FILE AND PUT IT INTO FILE (27). - - OPEN(27) - -C CALL SUBROUTINE STACK TO OPEN THE SUBJECT'S DATA FILE AND PUT THE -C INFO INTO FILE 27. NOTE THAT THERE WILL BE ONLY ONE FILE READ IN -C AND "STACKED" INTO FILE 27, BUT THE STRUCTURE OF DOING SO IS -C MAINTAINED SO THAT OTHER CODE DOES NOT HAVE TO BE CHANGED. - -C AS OF BESTDOS108, USE PATFIL INSTEAD OF TMPFILE AS THE 3RD ARGUMENT -C TO STACK (SEE REASON IN THE COMMENTS AT THE TOP OF BESTDOS108.FOR). - - PATFIL = TMPFILE - CALL STACK(PATH,MAXOBDIM,PATFIL,AF) - -C NOW FILE 27 HAS THE PATIENT DATA INFO IN IT - -C REWIND FILE 27, WHICH HAS THE PATIENT DATA FILE ON IT. - - REWIND(27) - - WRITE(*,437) - 437 FORMAT(/' NPAG IS NOW OBTAINING THE POSTERIOR DENSITY ...') - - -C AS OF BESTDOSTEMP.FOR (TO BE RENAMED BESTDOS112.FOR), TO OBTAIN THE -C POSTERIOR DENSITY, DO AN EXTENDED PROCESS TO MAKE IT MORE LIKELY -C THAT THERE WILL BE MORE THAN 1 PT. IN IT. INSTEAD OF JUST CALLING -C NPAGFULL, WHICH ALWAYS RETURNS THE SINGLE BEST POINT WHICH IS -C COMPATIBLE WITH THE "PAST", THIS PROGRAM DOES A 2-STEP PROCESS: - -C 1. IT CALLS NPAGFULL11, WHICH RETURNS ALL GRID PTS. FROM THE -C ORIGINAL PRIOR DENSITY WHICH ARE ARE REASONABLY COMPATIBLE WITH THE -C "PAST" (I.E., THOSE WHOSE PROBABILITIES ARE WITHIN 1.D-100 OF THE -C BEST GRID PT.). THIS IS THE BAYESIAN POSTERIOR OF THE PRIOR DENSITY, -C BASED ON THE "PAST" OF THE SUBJECT. - -C 2. FOR EACH OF THE GRID PTS. IN 1., IT CALLS NPAGFULL TO OBTAIN -C THE SINGLE DAUGHTER PT. WHICH IS BEST. - -C THE RESULT THEN WILL BE A POSTERIOR CONSISTING OF THE BEST DAUGHTER -C POINT FOR EVERY GRID PT. WHICH SHOWED UP IN STEP 1. - - CALL NPAGFULL11(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK, - 1 CORDEN,NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM, - 2 NGRID,NACTVE,PYJGX,DENSTOR,CORDLAST) - -C THE BAYESIAN POSTERIOR = CORDEN(I,J),J=1,NVAR+1; I = 1,NACTVE. -C FOR EACH OF THESE NACTVE GRID PTS., CALL NPAGFULL TO GET THE BEST -C DAUGHTER POINT (VIS-A-VIS THIS SUBJECT'S "PAST"). - - - DO IACTIVE = 1,NACTVE - -C REWIND FILE 27, WHICH HAS THE PATIENT DATA FILE ON IT. - - REWIND(27) - -C STORE INTO CORD1 GRID PT. NO. IACTIVE. NOTE BELOW IN THE CALL TO -C NPAGFULL, THE 20TH ARGUMENT IS 1, INDICATING THAT THERE IS JUST THIS -C ONE GRID PT. IN THIS PRIOR. -C NO! THE 20TH ARGUMENT CANNOT BE A CONSTANT SINCE THE DUMMY ARGUMENT -C IN NPAGFULL IS NACTVE, WHICH IS RESET A COUPLE OF TIMES IN THE -C NPAGFULL CODE. THIS IS FINE IF THE PROGRAM IS RUN UNDER LAHEY -C FORTRAN, BUT CAUSES THE PROGRAM TO BOMB IF THE PROGRAM IS RUN UNDER -C gfortran. SO, INSTEAD SET NACTVE1 = 1, AND SUPPLY NACTVE1 AS THE -C 2OTH ARGUMENT. - - NACTVE1 = 1 - - DO J = 1,NVAR+1 - CORD1(1,J) = CORDEN(IACTIVE,J) - END DO - - - CALL NPAGFULL(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK,CORD1, - 1 NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM,NGRID, - 2 NACTVE1,PYJGX,DENSTOR,CORDLAST,MAXCYC) - - -C ON INPUT TO NPAGFULL, CORD1 (IN ROW 1) CONTAINED THE SINGLE GRID -C POINT IN THE PRIOR DENSITY. NOW, ON RETURN FROM NPAGFULL, ITS -C FIRST ROW CONTAINS THE POSTERIOR DENSITY OF THE SUBJECT, GIVEN THIS -C PRIOR. UPDATE ROW NO. IACTIVE OF CORDEN WITH THESE VALUES. - -C FOR BESTDOS112A.FOR, DO NOT SET CORDEN(IACTIVE,NVAR+1) = -C CORD1(1,NVAR+1). I.E., JUST RUN THE LOOP BELOW FROM 1 TO NVAR, -C NOT TO NVAR+1. THE REASON IS THAT THE DENSITY VALUES FROM NPAGFULL11 -C SHOULD BE THE ONES USED BELOW IN THE CALL TO ELDERY. OTHERWISE, -C THEY ALL GET SET = THE SAME VALUE, AS IF ALL OF THE ORIGINA GRID -C PTS. FROM NPAGFULL ARE EQUALLY LIKELY. - - DO J = 1,NVAR - CORDEN(IACTIVE,J) = CORD1(1,J) - END DO - - END DO -C THE ABOVE END DO IS FOR THE DO IACTIVE = 1,NACTVE LOOP. - - -C NOW CORDEN HAS NACTVE GRID PTS. WHICH CONSTITUTES THE POSTERIOR -C FOR THIS RUN, IN THIS NEW 2-STEP ALGORITHM. IT WILL BE USED TO -C ESTABLISH THE ARRAY DENSITY BELOW, WHICH WILL SUPPLIED IN -C COMMON/TOCALC TO SUBROUTINE CALCS, WHICH IS CALLED BY ELDERY. - - - CLOSE(27) - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. - - - -C NOTE THAT THE DENSITY VALUES MUST BE SET = CORDEN(.,.). - - -C IF(INCLUDPAST .EQ. 0 .OR. IPRIOROBS .EQ. 0) THIS CORDEN COMES -C DIRECTLY FROM NPAGDENFILE SINCE THE USER HAS NOT PROVIDED A "PAST" - -C HISTORY FILE (PASTFILEIN), OR IF HE HAS, THIS FILE HAS NO NON-MISSING -C OBSERVATIONS. IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1), THIS -C CORDEN COMES FROM THE CALL TO NPAGFULL ABOVE. - -C EITHER WAY, NOTE THAT CORDEN(I,NVAR+1) IS THE DENSITY FOR GRID POINT -C I, AND THESE MUST BE NORMALIZED SO THAT THEY ALL SUM TO 0.0. - - - SUMD = 0.D0 - DO I = 1,NACTVE - SUMD = SUMD + CORDEN(I,NVAR+1) - DO J = 1,NVAR - DENSITY(I,J) = CORDEN(I,J) - END DO - END DO - - DO I = 1,NACTVE - DENSITY(I,NVAR+1) = CORDEN(I,NVAR+1)/SUMD - - - END DO - - -C MUST SET NGRD = NACTVE SINCE IT MUST BE SUPPLIED IN COMMON/TOCALC. - - NGRD = NACTVE - - -C THE ARRAY, DENSITY, HAS BEEN ESTABLISHED ABOVE. NOW ESTABLISH THIS -C SUBJECT'S COMPLETE PROFILE FOR THE OPTIMIZATION, AND PUT IT INTO THE -C WORKING COPY FILE, TMPFILE. IT WILL CONSIST OF THE DOSES (BUT NOT THE - -C OBSERVATIONS) IN THE "PAST" ALONG WITH THE DOSES AND OBSERVATIONS IN -C THE "FUTURE" (WITH ALL TIMES IN THE "FUTURE" INCREASED BY TNEXT). - -C IF INCLUDPAST = 0, TNEXT WILL = 0, AND THE COMPLETE PROFILE WILL -C CONSIST ONLY OF JUST THE "FUTURE" FILE. - - IF(INCLUDPAST .EQ. 0) THEN - - TNEXT = 0 - - TMPFILE = ' ' - IF(ICSVFILE .EQ. 0) TMPFILE = FUTUREFILEIN - IF(ICSVFILE .EQ. 1) TMPFILE = 'XQZPJ001.FUT' - -C SET ND41 = 0. IT WILL BE USED BELOW (AND PUT INTO COMMON/TOCALC). IT -C IS THE NO. OF DOSES IN THE "PAST" HISTORY OF THE SUBJECT, AND SO IN -C THIS CASE WHERE THERE IS NO "PAST" HISTORY, IT WILL BE 0. ALSO, -C SET THIS VALUE TO NDD41 SINCE IT WILL BE PASSED IN COMMON/TOCALC, -C AND MUST THEREFORE HAVE A DIFFERENT NAME. - - ND41 = 0 - - NDD41 = ND41 - -C ALSO, AS OF BESTDOS110, SET M41 = 0. THIS IS PASSED IN -C COMMON/TOCALCTP TO SUBROUTINE CALCTPRED SO THAT IT WILL KNOW THAT -C THERE ARE NO OBSERVATION TIMES FROM THE "PAST". - - M41 = 0 - - ENDIF - - - IF(INCLUDPAST .EQ. 1) THEN - - TMPFILE1 = ' ' - IF(ICSVFILE .EQ. 0) TMPFILE1 = PASTFILEIN - IF(ICSVFILE .EQ. 1) TMPFILE1 = 'XQZPJ001.PST' - - TMPFILE2 = ' ' - IF(ICSVFILE .EQ. 0) TMPFILE2 = FUTUREFILEIN - IF(ICSVFILE .EQ. 1) TMPFILE2 = 'XQZPJ001.FUT' - -C SINCE THE FUTURE FILE AND THE PAST FILE HAVE TO OPEN AT THE SAME -C TIME (IN ORDER TO COMBINE THEM INTO TMPFILE BELOW), THEY CANNOT -C BE THE SAME FILE. IF THEY ARE, THE PROGRAM WILL STOP WITH A MESSAGE -C TO THE USER THAT THESE FILES HAVE TO BE DIFFERENT. - - IF(ICSVFILE .EQ. 0 .AND. TMPFILE1 .EQ. TMPFILE2) THEN - - WRITE(*,317) TMPFILE1 - 317 FORMAT(/' YOU HAVE CHOSEN THE "PAST" AND THE "FUTURE" FILES'/ - 1' TO BE THE SAME FILE ... ',A20// - 2' THIS IS NOT ALLOWED. IF YOU REALLY WANT THE INFORMATION TO BE'/ - 3' THE SAME IN THE "PAST" AS IN THE "FUTURE", YOU WILL HAVE TO'/ - 4' COPY THE PATIENT FILE TO ANOTHER FILE, AND THEN USE ONE OF'/ - 5' THESE FILES AS THE "PAST" AND ONE AS THE "FUTURE".'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,317) TMPFILE1 - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - TMPFILE = ' ' - TMPFILE = 'BOTHFILES.ZPJ' - -C??? DEBUG: -C THIS FILE WILL BE LEFT IN THE WORKING DIRECTORY FOR NOW, SO THAT -C IT CAN BE EXAMINED TO VERIFY THAT THE COMPLETE PATIENT PROFILE IS -C WHAT WAS INTENDED. AT SOME POINT IN THE FUTURE, IF DESIRED, IT CAN -C BE DELETED AT THE END OF THE RUN. - - OPEN(41,FILE=TMPFILE1) - OPEN(42,FILE=TMPFILE2) - OPEN(43,FILE=TMPFILE) - -C NOW CALL MAKETMP TO COMBINE TMPFILE1 AND TMPFILE2 INTO TMPFILE, -C WHICH WILL CONSIST OF THE DOSES (BUT NOT THE OBSERVATIONS) IN -C TMPFILE1 (THE "PAST") ALONG WITH THE DOSES AND OBSERVATIONS IN -C TMPFILE2(THE "FUTURE"), WITH ALL TIMES IN TMPFILE2 INCREASED BY -C TNEXT. - -C AS OF BESTDOS119.FOR, ND42 IS RETURNED, RATHER THAN ND41 IN -C THE CALL TO MAKETMP. - - - CALL MAKETMP(TNEXT,MAXOBDIM,ND42) - -C NOTE THAT TMPFILE = 'BOTHFILES.ZPJ' HAS A TOTAL OF ND DOSES, BUT -C THE OPTIMIZATION BELOW WILL BE OVER ONLY THE LAST ND42 OF THEM. -C THE FIRST ND41 WILL BE FIXED TO THEIR VALUES IN THE FILE. -C IF THERE ARE NO STEADY STATE DOSE SETS IN THE "PAST", COULD SET -C ND41 = ND - ND42 NOW. BUT SINCE THERE MAY BE STEADY STATE DOSE SETS -C AS OF BESTDOS119.FOR, MUST WAIT TO ESTABLISH ND41 UNTIL AFTER -C SUBROUTINE NEWWORK1 IS CALLED BELOW. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1) CONDITION. - - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - - -C CALL SUBROUTINE PUTASS TO MAKE SURE THAT THE WORKING COPY PATIENT - - -C FILE HAS THE DESIRED ASSAY COEFFICIENTS WRITTEN AT THE END OF IT. - - CALL PUTASS(PATHFILE,IASS,C0P,C1P,C2P,C3P,NUMEQT) - - -C OPEN THE PATIENT DATA FILE AND PUT IT INTO FILE (27). - - OPEN(27) - -C CALL SUBROUTINE STACK TO OPEN THE SUBJECT'S DATA FILE AND PUT THE -C INFO INTO FILE 27. NOTE THAT THERE WILL BE ONLY ONE FILE READ IN -C AND "STACKED" INTO FILE 27, BUT THE STRUCTURE OF DOING SO IS -C MAINTAINED SO THAT OTHER CODE DOES NOT HAVE TO BE CHANGED. - - -C AS OF BESTDOS108, USE PATFIL INSTEAD OF TMPFILE AS THE 3RD ARGUMENT -C TO STACK (SEE REASON IN THE COMMENTS AT THE TOP OF BESTDOS108.FOR). - - PATFIL = TMPFILE - CALL STACK(PATH,MAXOBDIM,PATFIL,AF) - - -C NOW FILE 27 HAS THE PATIENT DATA INFO IN IT -C REWIND FILE 27, WHICH HAS THE PATIENT DATA FILE ON IT. - - REWIND(27) - - -C AS OF BESTDOS119.FOR, FILE 27 DATA MUST BE CONVERTED TO FILE 37 -C DATA AS FOLLOWS: - -C PUT THE SUBJECT'S DATA ONTO FILE 37 BY CALLING SUBROUTINE NEWWORK1 -C (SIMILAR ROUTINE TO THE ONE IN npageng25.f, EXCEPT IT READS FILE 27 -C AND WRITES TO FILE 37, RATHER THAN READING FROM FILE 23 AND WRITING -C TO FILE 27). NOTE THAT IT HAS NO ARGUMENTS; NONE ARE NEEDED IN THIS -C PROGRAM. - -C NOTE THAT IF THE SUBJECT FILE HAS NO STEADY STATE DOSE INDICATORS, IT -C WILL NOT BE CHANGED; IF IT DOES, IT WILL BE ALTERED TO INCLUDE AN -C EXTRA 100 DOSES SETS FOR EACH STEADY STATE DOSE INDICATOR. NOTE THAT -C SUBROUTINE NEWWORK1 WILL LEAVE IN THE NEGATIVE DOSE TIME (WHICH IS -C THE STEADY STATE DOSE INDICATOR) BECAUSE THE ID ROUTINES NEED TO SEE -C THIS INDICATOR TO KNOW THAT A STEADY STATE DOSE SET IS COMING. - - - OPEN(37,FILE='FILE37') -C???DEBUG. MAKE THIS TEMPORARY FILE PERMANENT WHILE DEBUGGING. - - CALL NEWWORK1 - REWIND(37) - - - CALL FILRED(NOBSER,ND,NDRUG,RS,SIG,YO,C0,C1,C2,C3,MAXOBDIM) - -C YO(I),I=1,NOBSER; J=1,NUMEQT, ARE THE TARGET OBSERVED VALUES FOR -C THIS SUBJECT. FIND THE ASSAY STANDARD DEVIATIONS. FOR EACH -C OBSERVED VALUE, SI = (C0+C1*Y+C2*Y**2+C3*Y**3). THEN THE WEIGHT -C ASSOCIATED WITH OBSERVATION I WILL BE 1/SI**2. -C NO! WEIGHT(.,.) ARE NO LONGER USED IN SUBROUTINE WSUMSQ. SO -C COMMENT OUT THIS CODE. - -C DO I=1,NOBSER - -C DO J = 1,NUMEQT -C Y=YO(I,J) -C WEIGHT(I,J) = -C 1 1.D0/(C0(J) + C1(J)*Y + C2(J)*Y*Y + C3(J)*Y**3)**2.D0 -C END DO -C END DO - -C BEFORE CALL TO ELDERY, SET NVARR = NVAR (NVAR IS ALREADY IN A COMMON -C STATEMENT, AND NVARR MUST BE SUPPLIED TO SUBROUTINE CALCS, CALLED -C BY ELDERY).` - - NVARR = NVAR - -C AS OF BESTDOS113, ELDERY WILL BE CALLED TWICE, ONCE WITH THE DENSITY -C AS IT NOW STANDS (I.E., THE WITH THE SAME VALUES AS CALCULATED -C ORIGINALLY FROM NPAGFULL1), AS WAS DONE IN BESTDOS112A.FOR; AND ONCE -C WITH THE DENSITY OF ALL THE GRID PTS. BEING THE SAME, AS WAS DONE IN -C BESTDOS112.FOR. - - -C NOTE THAT IF INCLUDPAST = 0, ND41 AND NDD41 WERE ALREADY SET = 0 -C ABOVE. BUT IF INCLUDPAST = 1, THEY HAVE NOT BEEN ESTABLISHED YET -C FROM ND42 WHICH RETURNS FROM THE CALL TO MAKETMP, AND FROM ND WHICH -C RETURNS FROM THE CALL TO FILRED ABOVE. - - IF(INCLUDPAST .EQ. 1) THEN - - ND41 = ND - ND42 - -C MUST SET ND41 TO BE NDD41 SINCE IT WILL BE PASSED IN COMMON/TOCALC, -C AND MUST THEREFORE HAVE A DIFFERENT NAME. - - NDD41 = ND41 - - ENDIF - - - -C *************** FIRST CALL TO ELDERY BELOW ************************* - -C THE FIRST CALL TO ELDERY WILL BE WITH THE DENSITY VALUES AS -C CALCULATED ORIGINALLY FROM NPAGFULL1 (AS WAS DONE IN -C BESTDOS112A.FOR). THESE VALUES ARE ALREADY IN DENSITY(.,.). - -C CALL SUBROUTINE ELDERY TO FIND THE BEST SET OF NDOS DOSES (AT THE -C TIMES READ IN FROM THE PATIENT DATA FILE BY SUBROUTINE FILRED - -C THESE TIMES ARE PUT INTO COMMON BY FILRED) TO MINIMIZE THE EXPECTED -C WEIGHTED SUM OF SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET -C CONCENTRATIONS (THE OBSERVATION TIMES AND TARGET CONCENTRATIONS ARE -C ALSO READ IN BY FILRED AND PUT INTO COMMONS TO BE USED BY SUBROUTINE -C CALCS WHICH IS CALLED BY SUBROUTINE ELDERY). THE EXPECTED VALUE IS -C OVER THE PRIOR DENSITY (HAVING PARAMETER VALUES AND CORRESPONDING -C DENSITIES) READ IN ABOVE. - -C IN PARTICULAR, ELDERY MINIMIZES EXPSUM = SUM, OVER I=1,NGRD, OF -C DENSITY(I,NVAR+1)*SUMSQ(I), WHERE SUMSQ(I) IS THE WEIGHTED SUM OF -C SQUARES OF DIFFERENCES W(k,l)*(O(I,k,l) -T(k,l))**2, WHERE O(I,k,l) -C IS THE CONCENTRATION AT TIME (k,l) ASSUMING THE ITH GRID POINT; -C T(k,l) IS THE TARGET CONCENTRAIION OF THE lth EQUATION AT TIME k, AND -C W(k,l) IS THE CORRESPONDING WEIGHT CALCULATED ABOVE. - - -C PREPARE TO CALL ELDERY. - -C THE IV DOSE VALUES IN THE PATIENT DATA FILE ARE IN RS(I,2*J-1), -C I=1,ND; J=1,NDRUG; AND THE BOLUS VALUES IN THE PATIENT DATA FILE -C ARE IN RS(I,2*J), ALL RETURNED FROM THE CALL TO FILRED ABOVE. BUT -C NOTE THAT ONLY THE NON-0 IVs AND BOLUSES FROM DOSE EVENTS ND41+1 -C TO ND WILL BE THE DOSES OVER WHICH THE OPTIMIZATION WILL TAKE PLACE -C BELOW. THE REASON IS THAT THE FIRST ND41 DOSE EVENTS WERE IN THE -C "PAST", WHILE THE DOSES STARTING WITH NO. ND41+1 ARE IN THE "FUTURE" -C (SEE SUBROUTINE MAKETMP). THESE VALUES ARE TO BE USED AS THE INITIAL -C GUESSES TO INITIATE THE NELDER MEED ALGORITHM. - - - -C AS OF BESTDOS111.FOR, IF IOPTIMIZE = 0, IT MEANS THAT THE USER DOES -C NOT WANT TO FIND THE BEST DOSES TO HIT THE TARGETS. INSTEAD HE -C SIMPLY WANTS TO USE THE DOSES SPECIFIED IN THE "FUTURE" FILE. THIS -C CAN BE ACHIEVED BY SETTING STEP(.) VALUUES BELOW TO 0. THAT WAY, -C ELDERY WILL SIMPLY SETTLE FOR THE INITIAL VALUES, AS DESIRED. - - IDOS = 0 - - DO I = ND41+1,ND - - DO J = 1,NDRUG - IF(RS(I,2*J-1) .GT. 0.D0) THEN - IDOS = IDOS + 1 - START(IDOS) = RS(I,2*J-1) - STEP(IDOS)= -.2D0*START(IDOS) - IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 - ENDIF - - IF(RS(I,2*J) .GT. 0.D0) THEN - IDOS = IDOS + 1 - START(IDOS) = RS(I,2*J) - STEP(IDOS)= -.2D0*START(IDOS) - IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 - ENDIF - END DO - END DO - - -C NOTE THAT THE TOTAL NO. OF DOSES OVER WHICH THE MINIMIZATION WILL -C BE DONE IS NDOS = IDOS FROM THE ABOVE LOOP. THIS VALUE MUST - -C BE .LE. 5000. - - NDOS = IDOS - - IF(NDOS .GT. 5000) THEN - - WRITE(*,103) NDOS - 103 FORMAT(/' THE MAXIMUM NO. OF DOSES OVER WHICH THE'/ - 1' MINIMIZATION CAN BE RUN IS 5000. IN YOUR PATIENT DATA FILE,'/ - 2' THE NO. OF NON-ZERO DOSES (IV OR BOLUS) OVER WHICH THE '/ - 3' OPTIMIZATION TAKES PLACE IS ',I8,' WHICH IS MORE THAN 5000. '/ - 4' SO THE PROGRAM STOPS.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,103) NDOS - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - -C HARDCODE IPRINTOUT = 1 FOR NOW, SO THAT THE CONVERGENCE INFO WILL -C PRINT TO THE SCREEN IN SUBROUTINE ELDERY. IF THIS INFO SHOULD BE -C SUPPRESSED IPRINTOUT WILL BE CHANGED TO 0. - - IPRINTOUT = 1 - - - IF(IOPTIMIZE .EQ. 0) IPRINTOUT = 0 - - CALL ELDERY(NDOS,START,DOSEBEST,VALMIN,1.D-10,STEP,1000,CALCS, - 1 0,ICONV,NITER,ICNT,IPRINTOUT) - - -C NOTE THAT ELDERY CALLS CALCS TO WHICH THE FOLLOWING VALUES ARE -C SUPPLIED VIA COMMON TOCALC (NDOS AND THE CANDIDATE OF DOSES ARE -C SUPPLIED AS CALLING ARGUMENTS FROM SUBROUTINE ELDERY). - -C 1. NOBSER = NO. OF OBSERVED VALUES IN THE PATIENT DATA FILE. -C 2. NUMEQT = NO. OF OUTPUT EQUATIONS IN THE PATIENT DATA FILE. -C 3. NGRD = NO. OF GRID POINTS OVER WHICH THE ABOVE EXPECTED VALUE -C IS TO BE CALCULATED. -C 4. NVAR = NO. OF DIMENSIONS IN THE RANDOM PARAMETER VECTOR. -C 5. DENSITY(I,J) = VALUE OF THE JTH RANDOM VARIABLE FOR GRID POINT I, -C J=1,NVAR; I=1,NGRD. -C DENSITY(I,NVAR+1) = DISCRETE DENSITY ASSOCIATED WITH GRID PT. I. -C 6. NDD41 IS NO. OF DOSE EVENTS IN THE "PAST" -C 7. BIASWEIGHT = WEIGHT FOR THE BIAS TERM IN THE CALCULATION OF THE -C COST FUNCTION; (1-BIASWEIGHT) = WEIGHT FOR THE MEAN SQUARE -C ERROR TERM. - - -C RETURNING FROM ELDERY ARE: - -C DOSEBEST(I),I=1,NDOS = THE DOSES WHICH MINIMIZE THE EXPECTED -C WEIGHTED SUM OF SQUARES DESCRIBED ABOVE. - -C VALMIN = MIN. VALUE OF THE FUNCTION ACHIEVED. - -C ICONV = 1 IF THE CONVERGED; 0 OTHERWISE. - -C NOTE THAT PREDMIN, PASSED TO THIS ROUTINE VIA COMMON/PREDVAL, WHERE -C IT WAS STORED BY SUBROUTINE CALCS (THE ROUTINE CALLED BY ELDERY), -C CONTAINS, FOR EACH GRID POINT, THE PREDICTED VALUES. THESE VALUES -C WILL BE WRITTEN, ALONG WITH THE TARGET CONCENTRATIONS, THE BEST SET -C OF DOSES, AND THE ASSOCIATED VALMIN, INTO DOSEROUTxxxx BELOW ... IF -C THIS CALL TO ELDERY PRODUCES A VALMIN WHICH IS LOWER THAN THE NEXT -C CALL. STORE THESE VALUES FOR NOW. - -C STORE PREDMIN, VALMIN, DOSEBEST, DENSITY FROM THIS RUN. - - VALMIN1 = VALMIN - - DO IGRD = 1,NGRD - DO I = 1,NOBSER - DO J = 1,NUMEQT - PREDMIN1(IGRD,I,J) = PREDMIN(IGRD,I,J) - END DO - END DO - END DO - - DO I = 1,NACTVE - DO J = 1,NVAR+1 - DENSITY1(I,J) = DENSITY(I,J) - END DO - END DO - - DO I = 1,NDOS - DOSEBEST1(I) = DOSEBEST(I) - END DO - - - -C *************** FIRST CALL TO ELDERY ABOVE ************************* - - -C *************** SECOND CALL TO ELDERY BELOW ************************ - -C THE SECOND CALL TO ELDERY WILL BE WITH DENSITY VALUES WHICH ARE -C ALL THE SAME (AS WAS DONE IN BESTDOS112.FOR). THESE VALUES WILL -C BE ESTABLISHED NOW. - - DO I = 1,NACTVE - DENSITY(I,NVAR+1) = 1.D0/NACTVE - END DO - -C CALL SUBROUTINE ELDERY TO FIND THE BEST SET OF NDOS DOSES (AT THE -C TIMES READ IN FROM THE PATIENT DATA FILE BY SUBROUTINE FILRED - -C THESE TIMES ARE PUT INTO COMMON BY FILRED) TO MINIMIZE THE EXPECTED -C WEIGHTED SUM OF SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET -C CONCENTRATIONS (THE OBSERVATION TIMES AND TARGET CONCENTRATIONS ARE -C ALSO READ IN BY FILRED AND PUT INTO COMMONS TO BE USED BY SUBROUTINE -C CALCS WHICH IS CALLED BY SUBROUTINE ELDERY). THE EXPECTED VALUE IS -C OVER THE PRIOR DENSITY (HAVING PARAMETER VALUES AND CORRESPONDING -C DENSITIES) READ IN ABOVE. - -C IN PARTICULAR, ELDERY MINIMIZES EXPSUM = SUM, OVER I=1,NGRD, OF -C DENSITY(I,NVAR+1)*SUMSQ(I), WHERE SUMSQ(I) IS THE WEIGHTED SUM OF -C SQUARES OF DIFFERENCES W(k,l)*(O(I,k,l) -T(k,l))**2, WHERE O(I,k,l) -C IS THE CONCENTRATION AT TIME (k,l) ASSUMING THE ITH GRID POINT; -C T(k,l) IS THE TARGET CONCENTRAIION OF THE lth EQUATION AT TIME k, AND -C W(k,l) IS THE CORRESPONDING WEIGHT CALCULATED ABOVE. - - -C PREPARE TO CALL ELDERY. - -C THE IV DOSE VALUES IN THE PATIENT DATA FILE ARE IN RS(I,2*J-1), -C I=1,ND; J=1,NDRUG; AND THE BOLUS VALUES IN THE PATIENT DATA FILE -C ARE IN RS(I,2*J), ALL RETURNED FROM THE CALL TO FILRED ABOVE. BUT - - -C NOTE THAT ONLY THE NON-0 IVs AND BOLUSES FROM DOSE EVENTS ND41+1 -C TO ND WILL BE THE DOSES OVER WHICH THE OPTIMIZATION WILL TAKE PLACE -C BELOW. THE REASON IS THAT THE FIRST ND41 DOSE EVENTS WERE IN THE -C "PAST", WHILE THE DOSES STARTING WITH NO. ND41+1 ARE IN THE "FUTURE" -C (SEE SUBROUTINE MAKETMP). THESE VALUES ARE TO BE USED AS THE INITIAL -C GUESSES TO INITIATE THE NELDER MEED ALGORITHM. - -C AS OF BESTDOS111.FOR, IF IOPTIMIZE = 0, IT MEANS THAT THE USER DOES -C NOT WANT TO FIND THE BEST DOSES TO HIT THE TARGETS. INSTEAD HE -C SIMPLY WANTS TO USE THE DOSES SPECIFIED IN THE "FUTURE" FILE. THIS -C CAN BE ACHIEVED BY SETTING STEP(.) VALUUES BELOW TO 0. THAT WAY, -C ELDERY WILL SIMPLY SETTLE FOR THE INITIAL VALUES, AS DESIRED. - -C NOTE THAT THE RS(.,.) VALUES HAVE CHANGED FROM THEIR READ IN VALUES -C FROM SUBROUTINE FILRED (IN THE FIRST CALL TO ELDERY ABOVE). SO, -C RESET THESE VALUES BEFORE ESTABLISHING START(.) AND STEP(.) FOR THE -C 2ND CALL TO ELDERY BELOW. DO THIS BY CALLING FILRED AGAIN. - - -C AS OF BESTDOS119.FOR, THE PATIENT DATA ARE ON FILE 37 INSTEAD OF -C FILE 27 (SEE NOTES ABOVE WHERE SUBROUTINE NEWWORK1 IS CALLED). - -C REWIND FILE 37, WHICH HAS THE PATIENT DATA FILE ON IT. - - REWIND(37) - - CALL FILRED(NOBSER,ND,NDRUG,RS,SIG,YO,C0,C1,C2,C3,MAXOBDIM) - - - IDOS = 0 - - DO I = ND41+1,ND - DO J = 1,NDRUG - IF(RS(I,2*J-1) .GT. 0.D0) THEN - IDOS = IDOS + 1 - START(IDOS) = RS(I,2*J-1) - STEP(IDOS)= -.2D0*START(IDOS) - IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 - ENDIF - IF(RS(I,2*J) .GT. 0.D0) THEN - IDOS = IDOS + 1 - START(IDOS) = RS(I,2*J) - STEP(IDOS)= -.2D0*START(IDOS) - IF(IOPTIMIZE .EQ. 0) STEP(IDOS) = 0.D0 - - ENDIF - END DO - END DO - - -C NOTE THAT THE TOTAL NO. OF DOSES OVER WHICH THE MINIMIZATION WILL -C BE DONE IS NDOS = IDOS FROM THE ABOVE LOOP. THIS VALUE MUST -C BE .LE. 5000. - - NDOS = IDOS - - - IF(NDOS .GT. 5000) THEN - - WRITE(*,103) NDOS - - OPEN(47,FILE=ERRFIL) - WRITE(47,103) NDOS - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - -C HARDCODE IPRINTOUT = 1 FOR NOW, SO THAT THE CONVERGENCE INFO WILL -C PRINT TO THE SCREEN IN SUBROUTINE ELDERY. IF THIS INFO SHOULD BE -C SUPPRESSED IPRINTOUT WILL BE CHANGED TO 0. - - IPRINTOUT = 1 - IF(IOPTIMIZE .EQ. 0) IPRINTOUT = 0 - - CALL ELDERY(NDOS,START,DOSEBEST,VALMIN,1.D-10,STEP,1000,CALCS, - 1 0,ICONV,NITER,ICNT,IPRINTOUT) - -C NOTE THAT ELDERY CALLS CALCS TO WHICH THE FOLLOWING VALUES ARE -C SUPPLIED VIA COMMON TOCALC (NDOS AND THE CANDIDATE OF DOSES ARE -C SUPPLIED AS CALLING ARGUMENTS FROM SUBROUTINE ELDERY). - -C 1. NOBSER = NO. OF OBSERVED VALUES IN THE PATIENT DATA FILE. -C 2. NUMEQT = NO. OF OUTPUT EQUATIONS IN THE PATIENT DATA FILE. -C 3. NGRD = NO. OF GRID POINTS OVER WHICH THE ABOVE EXPECTED VALUE -C IS TO BE CALCULATED. -C 4. NVAR = NO. OF DIMENSIONS IN THE RANDOM PARAMETER VECTOR. -C 5. DENSITY(I,J) = VALUE OF THE JTH RANDOM VARIABLE FOR GRID POINT I, -C J=1,NVAR; I=1,NGRD. -C DENSITY(I,NVAR+1) = DISCRETE DENSITY ASSOCIATED WITH GRID PT. I. -C 6. NDD41 IS NO. OF DOSE EVENTS IN THE "PAST" -C 7. BIASWEIGHT = WEIGHT FOR THE BIAS TERM IN THE CALCULATION OF THE -C COST FUNCTION; (1-BIASWEIGHT) = WEIGHT FOR THE MEAN SQUARE -C ERROR TERM. - -C RETURNING FROM ELDERY ARE: - -C DOSEBEST(I),I=1,NDOS = THE DOSES WHICH MINIMIZE THE EXPECTED -C WEIGHTED SUM OF SQUARES DESCRIBED ABOVE. - -C VALMIN = MIN. VALUE OF THE FUNCTION ACHIEVED. - -C ICONV = 1 IF THE CONVERGED; 0 OTHERWISE. - -C NOTE THAT PREDMIN, PASSED TO THIS ROUTINE VIA COMMON/PREDVAL, WHERE - -C IT WAS STORED BY SUBROUTINE CALCS (THE ROUTINE CALLED BY ELDERY), -C CONTAINS, FOR EACH GRID POINT, THE PREDICTED VALUES. THESE VALUES -C WILL BE WRITTEN, ALONG WITH THE TARGET CONCENTRATIONS, THE BEST SET -C OF DOSES, AND THE ASSOCIATED VALMIN, INTO DOSEROUTxxxx BELOW ... IF -C THIS CALL TO ELDERY PRODUCES A VALMIN WHICH IS LOWER THAN THE -C PREVIOUS CALL. STORE THESE VALUES FOR NOW. - -C STORE PREDMIN, VALMIN, DOSEBEST, DENSITY FROM THIS RUN. - - VALMIN2 = VALMIN - - -C *************** SECOND CALL TO ELDERY ABOVE *********************** - -C IF VALMIN2 .LE. VALMIN1, THEN THE VALUES IN PREDMIN, DENSITY, -C AND DOSEBEST ARE CORRECT. OTHERWISE, THE FIRST CALL TO ELDERY -C RESULTED IN THE MINIMUM SUM OF SQUARES. IN THIS CASE, RESET THESE -C VALUES TO WHAT THEY WERE AFTER THAT FIRST CALL TO ELDERY. - - IF(VALMIN2 .GT. VALMIN1) THEN - - VALMIN = VALMIN1 - - DO IGRD = 1,NGRD - DO I = 1,NOBSER - DO J = 1,NUMEQT - PREDMIN(IGRD,I,J) = PREDMIN1(IGRD,I,J) - END DO - END DO - END DO - - DO I = 1,NACTVE - DO J = 1,NVAR+1 - DENSITY(I,J) = DENSITY1(I,J) - END DO - END DO - - DO I = 1,NDOS - DOSEBEST(I) = DOSEBEST1(I) - END DO - - - ENDIF -C ABOVE ENDIF IS FOR THE IF(VALMIN2 .GT. VALMIN1) CONDITION. - -C REWIND FILE 27, AND CALL FILRED AGAIN. THIS IS DONE TO RE-ESTABLISH -C THE ORIGINAL DOSE VALUES INTO THE RS(.,.) ARRAY. THE REASON IS THAT -C ELDERY CALLS CALCS, WHICH CALLS WSUMSQ, WHICH SETS THE RS(.,.) VALUES -C TO THE CURRENT CANDIDATES SUPPLIED BY ELDERY. AND IF THESE VALUES -C HAPPEN TO BE SET = 0, THEN THE CODE TO WRITE OUT THE OPTIMAL DOSES -C BELOW (WHICH DEPEND ON RS(I,2*J-1) OR RS(I,2*J) BEING > 0 TO -C IDENTIFY AN IV OR A BOLUS, RESPECTIVELY) WILL NOT BE ENGAGED. AND -C THEN THE #OPTIMAL DOSES LINE WILL BE FOLLOWED BY NO DOSES AT ALL. -C IN ADDITION, THE CODE TO ESTABLISH THE BEST DOSES INTO RS(.,.) FOR -C THE PURPOSE OF WRITING THE PREDICTED VALUES FOR THESE BEST DOSES, -C FOR EACH GRID PT. IN THE PARAMETER DENSITY, WILL NOT BE ENGAGED -C EITHER. - - -C AS OF BESTDOS119.FOR, THE PATIENT DATA ARE ON FILE 37 INSTEAD OF -C FILE 27 (SEE NOTES ABOVE WHERE SUBROUTINE NEWWORK1 IS CALLED). - -C REWIND FILE 37, WHICH HAS THE PATIENT DATA FILE ON IT. - - REWIND(37) - CALL FILRED(NOBSER,ND,NDRUG,RS,SIG,YO,C0,C1,C2,C3,MAXOBDIM) - -C CREATE OUTPUT FILE WHICH HAS 'DOSEROUT' AS ITS 1ST 8 CHARACTERS AND -C NAME AS ITS LAST 4. NOTE THAT NAME WAS ESTABLISHED ABOVE WHEN -C FILE 'EXTNUM' WAS READ. - - OUTFIL = 'DOSEROUT'//NAME - TMPFILE = ' ' - TMPFILE = OUTFIL - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(56,FILE=PATHFILE) - -C FIRST, WRITE ALL INPUT INSTRUCTIONS TO THE OUTPUT FILE. - - WRITE(56,8151) - 8151 FORMAT(/' INSTRUCTIONS FOR THIS RUN WERE AS FOLLOWS: '/) - - WRITE(56,8137) - 8137 FORMAT(/' THE PATH FOR THE WORKING DIRECTORY WAS ') - WRITE(56,2221) PATH - - - WRITE(56,8111) - WRITE(56,2) FORFILE - - WRITE(56,8112) - WRITE(56,*) (IRAN(I),I=1,NP) - - WRITE(56,9006) - WRITE(56,2) NPAGDENFILE - - WRITE(56,9017) - WRITE(56,*) MAXCYC - - WRITE(56,9008) - WRITE(56,*) IPASTFILE - - WRITE(56,9011) - IF(INCLUDPAST .EQ. 0) WRITE(56,9007) - 9007 FORMAT(' N/A') - IF(INCLUDPAST .EQ. 1) WRITE(56,2) PASTFILEIN - - WRITE(56,8116) - WRITE(56,*) ICSVFILE - - WRITE(56,8117) - WRITE(56,2) FUTUREFILEIN - - WRITE(56,8118) - WRITE(56,*) TNEXT - - WRITE(56,8119) - WRITE(56,*) NOFIX - - WRITE(56,8121) - IF(NOFIX .GT. 0) WRITE(56,2416) (VALFIX(I),I=1,NOFIX) - - WRITE(56,8122) - WRITE(56,*) TOLER - - WRITE(56,8123) - WRITE(56,*) NUMEQT - - WRITE(56,8124) - DO IEQ=1,NUMEQT - WRITE(56,2416) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - END DO - - WRITE(56,8127) - WRITE(56,*) (IASS(I),I=1,NUMEQT) - - WRITE(56,9131) - WRITE(56,*) NDRUG - - - WRITE(56,8131) - WRITE(56,*) (AF(I),I=1,NDRUG) - - WRITE(56,8132) - WRITE(56,*) IOPTIMIZE - - WRITE(56,8136) - WRITE(56,*) BIASWEIGHT - - WRITE(56,8138) - WRITE(56,*) ITARGET - - - WRITE(56,8152) - 8152 FORMAT(/'-----------------------------------------------------') - - -C NOW, WRITE THE RESULTS TO THE OUTPUT FILE. - - WRITE(56,206) EEXPSUMMIN,BIASWEIGHT,SUMMIN,BIASMIN - - WRITE(*,206) EEXPSUMMIN,BIASWEIGHT,SUMMIN,BIASMIN - 206 FORMAT(/' THE MIMIMUM ACHIEVED COST FUNCTION IS ',G14.6// - 1' WHICH = (1 - BIASWEIGHT)*SUMMIN + BIASWEIGHT*BIASMIN, WHERE '// - - - 2' BIASWEIGHT = ',G14.6/ - 3' SUMMIN = ',G14.6/ - 4' BIASMIN = ',G14.6) - - WRITE(56,201) NOBSER,NUMEQT - 201 FORMAT(//' THE NEXT ',I4,' LINES GIVE THE TARGET VALUES, EACH'/ - 1' LINE HAVING THE VALUES FOR EACH OF THE ',I2,' OUTPUT EQUATION(S) - 2.') - - DO I = 1,NOBSER - WRITE(56,1212) (YO(I,J),J=1,NUMEQT) - END DO - 1212 FORMAT(1X,6(G12.5,1X)) - - - WRITE(56,717) NVAR,NACTVE - 717 FORMAT(//' FOR THE DENSITY USED IN THE CALCULATIONS OF THE '/ - 1' SIMULATED VALUES BELOW (AND USED TO ESTABLISH THE OPTIMAL'/ - 2' DOSES IF THAT WAS REQUESTED) ...'/ - 3' THE NO. OF RANDOM PARAMETERS IS ',I8/ - 4' THE NO. OF GRID POINTS IS ',I8/ - 5' THE DENSITY ARRAY ITSELF NOW FOLLOWS, ONE LINE (PERHAPS '/ - 6' WRAPPED) FOR EACH GRID PT. WITH THE PARAMETER VALUES FOLLOWED'/ - 7' BY THE PROB. FOR EACH POINT') - - DO I = 1,NACTVE - WRITE(56,*) (DENSITY(I,J),J=1,NVAR+1) - END DO - - WRITE(56,202) NGRD,NGRD,NOBSER,NUMEQT - 202 FORMAT(//' THE FOLLOWING ',I5,' SET(S) OF LINES GIVE THE'/ - 1' ACHIEVED OBSERVED VALUES FOR EACH OF THE ',I5,' GRID PT(S).'/ - - 2' EACH SET HAS ',I4,' ROW(S), (ONE ROW FOR EACH OBSERVATION TIME)' - 3/ - 4' AND ',I2,' COLUMN(S) (EACH COLUMN RESPRESENTS AN OUTPUT EQ.)'/) - - DO IGRD = 1,NGRD - DO I = 1,NOBSER - WRITE(56,1212) (PREDMIN(IGRD,I,J),J=1,NUMEQT) - END DO - END DO - - IF(ICONV .EQ. 0) WRITE(*,7134) - IF(ICONV .EQ. 0) WRITE(56,7134) - 7134 FORMAT(//' THE NELDER MEED ESTIMATE FOR THE BEST SET OF DOSES'/ - 1' DID NOT CONVERGE. '/) - - - WRITE(56,101) - 101 FORMAT(//' THE FOLLOWING MATRIX GIVES THE OPTIMAL DOSES. EACH'/ - 1' HAS, IN ORDER, TIME, DURATION, TOTAL DOSE, AND DRUG NO.') - -C BUT NOTE THAT ALL TIMES IN THE "FUTURE" HAD TNEXT ADDED TO THEM WHEN -C THE "FUTURE" WAS CONCATENATED TO THE "PAST". SO NOW, DECREASE ALL -C THESE "FUTURE" TIMES BY TNEXT BEFORE WRITING THEM TO THE OUTPUT FILE. - - WRITE(56,102) - 102 FORMAT(/'#OPTIMAL DOSES') - - IDOS = 0 - - DO I = ND41+1,ND - DO J = 1,NDRUG - - IF(RS(I,2*J-1) .GT. 0.D0) THEN - - IDOS = IDOS + 1 - -C SINCE RS(I,2*J-1) > 0, IT MEANS THAT THE IV FOR DRUG J DURING TIME -C INTERVAL SIG(I+1) - SIG(I) WAS OPTIMIZED AND FOUND TO BE -C DOSEBEST(IDOS). WRITE OUT FOR THIS DOSE, THE START TIME, THE DURATION -C OF THE IV, THE TOTAL DOSE AMOUNT, AND THE DRUG NO. - - -C NOTE THAT, FOR NOW, IT IS ASSUMED -C THAT I .NE. ND, BECAUSE IF IT IS, IT MEANS THAT AN IV STARTED AT -C THE LAST DOSE EVENT AND CONTINUED FOREVER (I.E., IT WILL BE ASSUMED -C THE USER ALWAYS INCLUDED A FINAL DOSE EVENT IN HIS PATIENT'S FILE -C THAT TURNED OFF ALL IVs). IF THIS IS NOT THE CASE, SET DURATION(.) -C TO -1 AND WRITE A MESSAGE TO THE USER. - - TSTART = SIG(I) - TNEXT - -C AS OF BESTDOS119.FOR, THERE MAY BE A STEADY STATE DOSE SET AT THE -C BEGINNING OF THE PATIENT'S REGIMEN. IN THIS CASE SIG(1) < 0. FOR -C EXAMPLE, SIG(1) = -2 --> THERE IS A STEADY STATE DOSE SET UNTIL -C 100*2 = TIME = 200. IN THIS CASE, SIG(I) ABOVE IS THE ACTUAL -C TIME OF THE BEGINNING OF THE DOSE, NOT THE RELATIVE TIME (RELATIVE -C TO THE END OF THE STEADY STATE DOSE SET). SINCE ALL THE TIMES -C WRITTEN BELOW FOR THE PREDICTED Y'S AND THE AUC'S ARE RELATIVE -C TIMES, THE OPTIMUM DOSE TIMES SHOULD BE ALSO. SO ADJUST TSTART -C HERE: - - IF(SIG(1) .LT. 0.D0) TSTART = TSTART + 100.D0*SIG(1) - - - IF(I .LT. ND) DURIV = SIG(I+1) - SIG(I) - - - IF(I .EQ. ND) THEN - DURIV = -1 - WRITE(56,1053) J - - WRITE(*,1053) J - 1053 FORMAT(/' DRUG ',I3,' HAS AN IV WHICH IS NEVER TURNED OFF.'/ - 1' AS A RESULT, ITS DURATION WILL BE ARBIRTRARILY SET = -1 SO'/ - 2' IT WILL BE CLEAR IN THE OUTPUT FILE THAT THE TOTAL DOSE IS'/ - 3' NOT AVAILABLE. INSTEAD THE IV RATE IS THE ABS. VALUE OF THE'/ - 4' VALUE IN THE OUTPUT FILE.'/) - CALL PAUSE - ENDIF - - DOSTOT = DOSEBEST(IDOS)*DURIV - - WRITE(56,104) TSTART,DURIV,DOSTOT,J - 104 FORMAT(1X,G14.4,2X,G14.4,2X,G18.6,2X,I3) - - - ENDIF -C THE ABOVE ENDIF IS FOR THE IF(RS(I,2*J-1) .GT. 0.D0) CONDITION. - - - IF(RS(I,2*J) .GT. 0.D0) THEN - - IDOS = IDOS + 1 - -C SINCE RS(I,2*J) > 0, IT MEANS THAT THE BOLUS FOR DRUG J AT TIME -C SIG(I) WAS OPTIMIZED AND FOUND TO BE DOSEBEST(IDOS).WRITE OUT FOR -C THIS DOSE, THE START TIME, THE DURATION (WHICH IS 0.0), THE TOTAL -C DOSE AMOUNT (WHICH IS JUST THE BOLUS), AND THE DRUG NO. ALSO, -C AS OF BESTDOS119.FOR, ADJUST TSTART TO BE A RELATIVE TIME, RATHER -C THAN AN ACTUAL TIME (SEE COMMENTS ABOVE). - - TSTART = SIG(I) - TNEXT - IF(SIG(1) .LT. 0.D0) TSTART = TSTART + 100.D0*SIG(1) - DURIV = 0.D0 - DOSTOT = DOSEBEST(IDOS) - - WRITE(56,104) TSTART,DURIV,DOSTOT,J - - - ENDIF -C THE ABOVE ENDIF IS FOR THE IF(RS(I,2*J) .GT. 0.D0) CONDITION. - - - END DO -C THE ABOVE END DO IS FOR THE DO J = 1,NDRUG LOOP. - - END DO -C THE ABOVE END DO IS FOR THE DO I = ND41+1,ND LOOP. - - - -C NOW, FOR EACH GRID POINT IN THE PARAMETER DENSITY, MUST FIND THE -C PREDICTED OBSERVED VALUES EVERY IDELTA MINUTES, GIVEN THE BEST DOSES -C THIS PROGRAM OBTAINED ABOVE. - -C FIRST RESTORE INTO THE RS ARRAY THE BEST DOSES FOUND BY THE CALL TO -C ELDERY ABOVE. AND THEN ESTABLISH THE BOLUS VALUES SINCE THEY WILL -C ALSO BE PASSED TO SUBROUTINE IDCALCYY/FUNC3 BELOW, VIA COMMON/OBSER. - - IDOS = 0 - - DO I = ND41+1,ND - DO J = 1,NDRUG - IF(RS(I,2*J-1) .GT. 0.D0) THEN - IDOS = IDOS + 1 - RS(I,2*J-1) = DOSEBEST(IDOS) - ENDIF - IF(RS(I,2*J) .GT. 0.D0) THEN - IDOS = IDOS + 1 - RS(I,2*J) = DOSEBEST(IDOS) - ENDIF - END DO - END DO - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - -C CALL CALCTPRED TO CALCULATE THE NUMT TIMES TO BE IN TPRED. - - CALL CALCTPRED(IDELTA,NOBSER,TNEXT,NUMT,TPRED,TPREDREL) - - -C AS OF BESTDOS109.FOR, TPREDREL AND OTHER ARRAYS RELATED TO TIME - -C RESETS AND STEADY STATE DOSE SETS ARE REMOVED FROM THIS PROGRAM, -C ... SINCE THIS PROGRAM DOES NOT ALLOW TIME RESETS/STEADY STATE -C DOSING. - -C NOTE THAT TPRED NOW CONTAINS THE NUMT PREDICTED TIMES, IDELTA -C MINUTES APART, ALONG WITH THE OBSERVATION AND DOSE TIMES (BUT -C DUPLICATE TIMES HAVE BEEN REMOVED). - - -C FOR EACH GRID PT. IN THE PARAMETER DENSITY, CALCULATE AND WRITE -C TO THE OUTPUT FILE, SIMULATED OBSERVED VALUES AT THE TIMES IN -C TPRED (SEE CALCTPRED ABOVE), ASSUMING THE OPTIMAL DOSES CALCULATED -C BY ELDERY ABOVE. - - WRITE(56,2133) NGRD,NUMT,IDELTA -2133 FORMAT(//'# SIMULATED OBSERVED VALUES AND AUCs FOLLOW, ONE TABLE'/ - 1' FOR EACH GRID POINT, AND A FINAL TABLE WITH THE WEIGHTED '/ - 2' OBSERVED VALUES AND AUCs, FOR EACH OUTPUT EQUATION. NOTE THAT'/ - 3' THERE ARE:'/ - 2I6,' NO. OF GRID POINTS'/ - 3I6,' NO. OF SIMULATED OBSERVED VALUES AND AUCs FOR EACH TABLE'/ - 4I6,' NO. OF MINS BETWEEN SIMULATED VALUES, EXCEPT FOR EXTRA OBS/ - 5DOSE TIMES') - -C INITIALIZE THE MEAN OBSERVATION AT EACH OF THE NUMT TIMES, FOR EACH -C OUTPUT EQ. TO BE 0. AT THE END OF THE DO IGRD LOOP, YBAR(J,IEQ) -C WIL BE THE MEAN OBSERVATION OVER ALL THE GRID PTS. FOR TIME J -C AND OUTPUT EQ. IEQ. SIMILARLY FOR AUCBAR(J,IEQ), WHICH WILL BE THE -C MEAN AUC OVER ALL THE GRID PTS. FOR TIME J AND OUTPUT EQ. IEQ. - - DO J = 1,NUMT - DO IEQ = 1,NUMEQT - YBAR(J,IEQ) = 0.D0 - AUCBAR(J,IEQ) = 0.D0 - END DO - END DO - - - DO IGRD = 1,NGRD - - -C STORE INTO THETA THE PARAMETER VALUES FOR GRID POINT IGRD. - - DO J=1,NVAR - THETA(J) = DENSITY(IGRD,J) - END DO - -C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO -C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL -C MAKEVEC TO DO THIS. - - CALL MAKEVEC(NVAR,NOFIX,IRAN,THETA,VALFIX,PX) - -C CALL SUBROUTINE IDCALCYY FOR THIS GRID PT. IN THE PARAMETER DENSITY. -C THIS IS A VERSION OF THE ID PROGRAM WHICH CALCULATES THE PREDICTED -C VALUES OF Y(I,J) (OUTPUT CONCENTRATION OF THE JTH OUTPUT EQ. AT TIME -C TPRED(I),I=1,NUMT), ASSUMING THE GIVEN GRID PT. NOTE THAT IN -C IDCALCYY, THE PREDICTED VALUES ARE SUPPLIED IN TPRED, RATHER THAN -C INPUT VIA COMMON/OBSER FROM THE PATIENT'S DATA FILE. ALSO, THE NO. -C OF OBSERVED TIMES IS NUMT, RATHER THAN M WHICH IS SUPPLIED VIA -C COMMON/SUM2. AND NOTE THAT NUMT AND TPRED(.) ARE FOUND FROM THE CALL -C TO CALCTPRED ABOVE. - - CALL IDCALCYY(NVAR+NOFIX,NDIM,PX,TPRED,NUMT,YYPRED,NUMEQT) - - - DO IEQ = 1,NUMEQT - -C FOR GRID PT. IGRD, AND OUTPUT EQ. IEQ, WRITE THE TABLE OF PREDICTED -C VALUES AND AUCs AT THE END OF EACH OF THE NUMT TIME PERIODS. - -C FIRST WRITE THE HEADER FOR THE TABLE. - - WRITE(56,2131) IGRD,DENSITY(IGRD,NVAR+1),IEQ - 2131 FORMAT(//'# GRID PT., ASSOCIATED PROB., AND OUTPUT EQ. NO. ARE: '/ - 1 I5,2X,G16.10,2X,I2/) - - -C THE AUC STARTS AT 0 AT TPREDREL(1), WHICH WILL BE 0. THEN IT WILL -C BE UPDATED FOR EACH INTERVAL, USING THE TRAPEZOIDAL RULE. - - DO J = 1,NUMT - - IF(J .EQ. 1) AUC = 0.D0 - -C AS OF BESTDOS116.FOR, AUCs IN THE "FUTURE" ARE RELATIVE TO THE -C BEGINNING OF THE "FUTURE", WHICH OCCURS AT TNEXT. SO SET AUC BACK -C TO 0 AT TIME TNEXT. - -C NO! AS OF BESTDOS118.FOR, EVEN THOUGH THE CODE IN WSUMSQ (IN -C CALCBST14.FOR) IS UNCHANGED, SO THAT AUCs IN THE "FUTURE" ARE -C RELATIVE TO THE BEGINNING OF THE "FUTURE", AND ARE RESET TO 0 AT -C TIME TNEXT, THE AUCs IN THE DOSEROUTxxxx FILE WILL BE CUMULATIVE -C FROM TIME 0 IN THE "PAST". SO COMMENT OUT THE CODE BELOW TO CALL -C THESAME, AND COMMENT OUT THE RESETTING OF AUC IF ISAME = 1. - -C CALL THESAME(TPREDREL(J),TNEXT,ISAME) - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TPREDREL(I) = TNEXT, -C OR AT LEAST, THEY ARE WITHIN 1.D-10 OF EACH OTHER. IN THIS CASE, -C SET AUC BACK TO 0. - - IF(J .GT. 1) THEN - DELTA = TPREDREL(J) - TPREDREL(J-1) - AUC = AUC + (YYPRED(J,IEQ) + YYPRED(J-1,IEQ))/2.D0 * DELTA -C IF(ISAME .EQ. 1) AUC = 0 - ENDIF - - WRITE(56,*) TPREDREL(J),YYPRED(J,IEQ),AUC - -C ADD THIS YYPRED(J,IEQ) TO THE OVERALL WEIGHTED OBSERVATION. SIMILARLY -C FOR THE OVERALL WEIGHTED AUC. - - YBAR(J,IEQ) = YBAR(J,IEQ) + DENSITY(IGRD,NVAR+1)*YYPRED(J,IEQ) - AUCBAR(J,IEQ) = AUCBAR(J,IEQ) + DENSITY(IGRD,NVAR+1)*AUC - - END DO -C THE ABOVE END DO IS FOR THE DO J = 1,NUMT LOOP. - - END DO -C THE ABOVE END DO IS FOR THE DO IEQ = 1,NUMEQT LOOP. - - END DO -C THE ABOVE END DO IS FOR THE DO IGRD = 1,NGRD LOOP. - - -C NOW ADD THE TABLE FOR THE WEIGHTED MEANS OF THE OBSERVATIONS AND -C AUCs. - - DO IEQ = 1,NUMEQT - -C FOR THIS WEIGHTED MEAN GRID PT., AND OUTPUT EQ. IEQ, WRITE THE TABLE -C OF PREDICTED VALUES AND AUCs AT THE END OF EACH OF THE NUMT TIME -C PERIODS. - -C FIRST WRITE THE HEADER FOR THE TABLE. - - WRITE(56,2134) IEQ - 2134 FORMAT(//'# WEIGHTED OBSERVED VALUES AND AUCs; OUTPUT EQ ',I2/) - - DO J = 1,NUMT - WRITE(56,*) TPREDREL(J),YBAR(J,IEQ),AUCBAR(J,IEQ) - END DO - - END DO - -C THE ABOVE END DO IS FOR THE DO IEQ = 1,NUMEQT LOOP. - - -C NOTE THAT FOR BESTDOS107.FOR, THE PREDICTED TIMES AND AUCs ARE -C CALCULATED FOR THE ENTIRE PATIENT PROFILE (UP TO 24 HOURS AFTER THE -C MAXIMUM OBSERVED TIME). I.E., THESE VALUES START WITH TIME 0 IN THE -C "PAST" HISTORY IF THERE IS A "PAST". THIS MAY CHANGE IN A SUBSEQUENT -C PROGRAM SO THAT THESE VALUES ARE ONLY WRITTEN STARTING IN THE -C "FUTURE" OF THE PATIENT. - - - CLOSE(56) - - - - STOP - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE GETPATH(PATH,NOB) - -C THIS ROUTINE OBTAINS FROM THE USER THE PATH WHERE THE INPUT FILES -C ARE LOCATED (AND WHERE THE OUTPUT FILES WILL BE SENT). NOTE THAT - -C PATH RETURNS AS THE PATH WITH A TRAILING BACKSLASH. - -C NOB RETURNS AS THE NO. OF THE LAST NON-BLANK ENTRY IN PATH. - - CHARACTER PATH*60 - - 10 WRITE(*,1) - 1 FORMAT(/' ENTER 1 IF THE FILES FOR THIS RUN ARE IN THE CURRENT D - 1IRECTORY; '/ - 1' ENTER 0 OTHERWISE: ') - READ(*,*,ERR=10) IPATH - IF(IPATH .NE. 0 .AND. IPATH .NE. 1) GO TO 10 - - IF(IPATH .EQ. 1) PATH = ' ' - NOB = 0 - -C IF THE USER ENTERS A NON-NULL PATH BELOW, NOB WILL BE THE NO. OF -C CHARACTERS IN THE PATH. IF HE ENTERS NOTHING, NOB STAYS 0, WHICH IS - -C THE CORRECT NO. OF CHARACTERS IN A NULL PATH. - - IF(IPATH .EQ. 0) THEN - - WRITE(*,3) - 3 FORMAT(/' ENTER THE LOCATION (PATH) OF YOUR INPUT FILES. NOTE'/ - 1' THAT THE PATH IS LIMITED TO 60 CHARACTERS AND THAT EACH SUB-DIRE - 2CTORY'/ - 3' CAN HAVE AT MOST 8 CHARACTERS (E.G, INSTEAD OF " \DIRECTORY ", U - 4SE '/ - 5' THE DOS-EQUIVALENT NAME, WHICH MIGHT BE " \DIRECT~1 "). '// - 6' ENTER THE PATH NOW: ') - READ(*,2) PATH - - 2 FORMAT(A60) - -C IF THE USER DIDN'T END HIS PATH WITH A '\', PUT ONE IN FOR PATH. - -C NOTE THAT IF THE USER ENTERED A BLANK PATH, IT WILL BE ASSUMED THAT -C HE WANTS THE CURRENT (WORKING) DIRECTORY. - - DO I=1,60 - - J = 60 + 1 - I - IF(PATH(J:J) .NE. ' ') THEN - - NOB = J - IF(PATH(J:J) .NE. '\') THEN - PATH(J+1:J+1) = '\' - NOB = J+1 - ENDIF - RETURN - ENDIF - END DO - - - ENDIF - - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - -C - SUBROUTINE FULLNAME(PATH,FILE,FILE2) - -C FULLNAME CONVERTS FILE TO FILE2, THE COMPLETE NAME OF -C THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE CURRENT - -C DIRECTORY). - - - CHARACTER PATH*60,FILE2*73,FILE*13,FILE1*73 - -C INITIALIZE FILE1 AND FILE2 AS ALL BLANKS, IN CASE THE USER IS -C RE-ENTERING HIS FILENAME (SO THERE WON'T BE SOMETHING ALREADY IN -C THESE FILENAMES). - - FILE2 = ' ' - FILE1 = ' ' - FILE1 = PATH//FILE - -C ESTABLISH FILE2 AS FILE1 WITHOUT ANY BLANKS. - - J = 0 - DO I=1,73 - IF(FILE1(I:I) .NE. ' ') THEN - J= J+1 - FILE2(J:J) = FILE1(I:I) - ENDIF - END DO - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - - SUBROUTINE SEEDIR(PATH,NOB,FILENAME) - CHARACTER FILENAME*20,PATH*60,PRTDIR*47,TEMP*72,PRTDIR2*47 - -C NOTE THAT PATH(1:NOB) IS THE CONDENSED (WITHOUT BLANKS) PATH. - - 10 PRTDIR = ' ' - WRITE(*,6) - 6 FORMAT(/' PRESS THE ENTER KEY TO SEE YOUR ENTIRE DIRECTORY;'// - 1' ENTER A PARTIAL FILENAME (WITH THE * WILDCARD) TO SEE A '/ - 2' PARTICULAR SUBSET OF FILENAMES IN YOUR DIRECTORY. '/ - 3' e.g., ENTER "TO*.INS TO SEE A LIST OF ALL FILES WHICH'/ - 4' BEGIN WITH "TO" AND HAVE A .INS SUFFIX '// - - 5' NOTE THAT THE FILES WILL AUTOMATICALLY BE TIME-ORDERED FROM '/ - 6' OLDEST TO NEWEST.'// - 7' ENTER YOUR CHOICE NOW: ') - READ(*,1) PRTDIR - 1 FORMAT(A47) - - -C REMOVE ANY BLANKS FROM PRTDIR SINCE THERE CAN BE NO BLANKS BETWEEN -C THE END OF THE PATH AND THE BEGINNING OF THE "OBJECT" OF THE -C DIR COMMAND FOR SUBDIRECTORIES. PRTDIR, WITHOUT BLANKS, WILL BE -C PRTDIR2. - - IF(PRTDIR .EQ. ' ') TEMP = 'DIR/OD '//PATH(1:NOB)//' |MORE' - - IF(PRTDIR .NE. ' ') THEN - PRTDIR2 = ' ' - J = 0 - DO I=1,47 - IF(PRTDIR(I:I) .NE. ' ') THEN - J = J+1 - - PRTDIR2(J:J) = PRTDIR(I:I) - - ENDIF - END DO - TEMP = 'DIR/OD '//PATH(1:NOB)//PRTDIR2(1:J)//' |MORE' - ENDIF - - - CALL SYSTEM(TEMP) - - WRITE(*,3) - 3 FORMAT(/' ENTER THE NAME OF THE DESIRED FILE (WITHOUT THE PATH); - 1'/ - 2' ENTER -99 TO ENTER A DIFFERENT FILE SPECIFICATION: ') - READ(*,2) FILENAME - 2 FORMAT(A20) - IF(FILENAME(1:3) .EQ. '-99') GO TO 10 - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE PUTASS(PATHFILE,IASS,C0P,C1P,C2P,C3P,NUMEQT) - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION IASS(MAXNUMEQ),C0P(MAXNUMEQ),C1P(MAXNUMEQ), - 1 C2P(MAXNUMEQ),C3P(MAXNUMEQ) - - - CHARACTER PATHFILE*73,READLINE*1000,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C THIS ROUTINE READS THE INFO IN FILE PATHFILE, AND MAKES SURE THE -C CORRECT ASSAY ERROR COEFFICIENTS ARE AT THE END OF THE FILE, AS -C FOLLOWS: - -C IASS(I) = 1 --> IF THE FILE ALREADY HAS C'S, THEY REMAIN; -C IF THE FILE DOESN'T HAVE C'S, -C [C0P(I),C1P(I),C2P(I),C3P(I)] ARE PUT INTO THE FILE -C FOR OUTPUT EQUATION I; I=1,NUMEQT. - - -C IASS(I) = 0 --> [C0P(I),C1P(I),C2P(I),C3P(I)] ARE PUT INTO THE FILE -C FOR OUTPUT EQUATION I; I=1,NUMEQT, REGARDLESS OF WHETHER -C THE FILE ALREADY HAS ASSAY C'S OR NOT. - - - - -C FIRST, DETERMINE IF FILE 21 HAS ASSAY COEFFICIENTS AT THE END. OPEN - -C THE FILE AND READ UNTIL THE LINE STARTING WITH -C "ASSAY COEFFICIENTS ..." IS ENCOUNTERED. IF THE NEXT WORD IS -C "FOLLOWS", THE LAST NUMEQT LINES CONTAIN ASSAY COEFFICIENTS. - - 3 FORMAT(A1000) - - OPEN(21,FILE=PATHFILE,STATUS='OLD') - 5 READ(21,3,IOSTAT=IEND) READLINE - -C IF THERE IS NO LINE WITH "ASSAY COE" ON IT, THIS IS NOT AN -C ACCEPTABLE WORKING COPY FILE. - - IF(IEND .LT. 0) THEN - - - - WRITE(*,56) PATHFILE - 56 FORMAT(//' PATIENT FILE '/ - 1' ',A73/ - 2' IS NOT AN ACCEPTABLE WORKING COPY FILE. SUCH A FILE MUST HAVE '/ - 2' "ASSAY COEFFICIENTS ... " NEAR THE BOTTOM OF THE FILE.'// - 3' THE PROGRAM STOPS. '//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,56) PATHFILE - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - IF(READLINE(1:9) .NE. 'ASSAY COE') GO TO 5 - - IF(READLINE(20:25) .EQ. 'FOLLOW' ) ICOFF = 1 - IF(READLINE(20:25) .NE. 'FOLLOW' ) ICOFF = 0 - -C NOTE THAT ICOFF = 1 IF ASSAY COEFFS. ARE AT THE END OF FILE 21; -C 0 IF ASSAY COEFFS. ARE NOT AT END OF THE FILE. - -C IF ICOFF=0, WRITE ALL OF FILE 21 TO FILE 27; -C IF ICOFF=1, WRITE ALL OF FILE 21, EXCEPT FOR ASSAY COEFFICIENT INFO, -C TO FILE 27. - - OPEN(27) - REWIND(21) - - 10 READ(21,3,IOSTAT=IEND) READLINE - IF(IEND .LT. 0 .OR. READLINE(1:5) .EQ. 'ASSAY' ) GO TO 25 - WRITE(27,3) READLINE - - GO TO 10 - - 25 READLINE = 'ASSAY COEFFICIENTS FOLLOW, ONE SET FOR EACH OUTPUT E - 1QUATION:' - WRITE(27,3) READLINE - -C NOW PUT IN THE APPROPRIATE C'S, DEPENDING ON THE VALUE OF ICOFF. - - -C********** PUT C'S IN FILE CURRENTLY HAVING NO C'S (BELOW) ************ - - IF(ICOFF .EQ. 0) THEN - - DO IEQ = 1,NUMEQT - - WRITE(27,16) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - - END DO - - 16 FORMAT(4(F16.8,2X)) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICOFF .EQ. 0) CONDITION. - -C********** PUT C'S IN FILE CURRENTLY HAVING NO C'S (ABOVE) ************ - - - -C********** PUT C'S IN FILE CURRENTLY HAVING C'S (BELOW) *************** - - IF(ICOFF .EQ. 1) THEN - - - DO IEQ = 1,NUMEQT - -C THIS FILE HAS C'S ON THE NEXT LINE. - - READ(21,*) C0,C1,C2,C3 - - - IF(IASS(IEQ) .EQ. 1) WRITE(27,16) C0,C1,C2,C3 - IF(IASS(IEQ) .EQ. 0) WRITE(27,16) C0P(IEQ),C1P(IEQ),C2P(IEQ), - 1 C3P(IEQ) - - END DO - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICOFF .EQ. 1) CONDITION. - -C********** PUT C'S IN FILE CURRENTLY HAVING C'S (ABOVE) *************** - -C NOW COPY FILE 27 BACK INTO FILE 21. - - CLOSE(21) - OPEN(21,FILE=PATHFILE) - REWIND(27) - - 60 READ(27,3,IOSTAT=IEND) READLINE - - IF(IEND .LT. 0) THEN - CLOSE(27) - CLOSE(21) - RETURN - ENDIF - - WRITE(21,3) READLINE - GO TO 60 - - - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE FILRED(NOBSER,NDD,NNDRUG,RSS,SIGG,YO,C0,C1,C2,C3, - 1 MAXOBDIM) - -C FILRED IS CALLED BY SUBROUTINE PREVRUN TO READ THE PORTION OF -C SCRATCH FILE 37 WHICH APPLIES TO THE SUBJECT UNDER CONSIDERATION. THE - -C 'POINTER' FOR FILE 37 IS IN THE PROPER POSITION TO BEGIN READING THE -C INFO FOR THE DESIRED SUBJECT. - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - - - DIMENSION SIG(5000),RS(5000,34),YO(MAXOBDIM,MAXNUMEQ), - 1 BS(5000,7),C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ), - 2 C3(MAXNUMEQ),YOO(594,MAXNUMEQ),TIM(594),RSS(5000,34),SIGG(5000) - - -C THE MAJOR CHANGE AS OF NPBIG11.FOR (WHICH ALLOWS MULTIPLE DRUGS) -C OCCURS IN THE DOSAGE REGIMEN BLOCK WHICH WILL NOW HAVE THE FOLLOWING -C COLUMNS, IN ORDER: - -C COL 1 = TIME -C COL 2 = IV FOR DRUG 1; COL 3 = PO FOR DRUG 1; -C COL 4 = IV FOR DRUG 2; COL 5 = PO FOR DRUG 2; -C ... EACH SUCCEEDING DRUG HAS AN IV FOLLOWED BY A PO COLUMN. -C NEXT NADD COLUMNS = ONE FOR EACH ADDITIONAL COVARIATE. - - CHARACTER SEX*1,READLINE*1000,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - - - COMMON/OBSER/ TIM,SIG,RS,YOO,BS - COMMON /CNST/ N,ND,NI,NUP,NUIC,NP - COMMON /CNST2/ NPL,NUMEQT,NDRUG,NADD - COMMON /SUM2/ M,NPNL - COMMON/DESCR/AGE,HEIGHT,ISEX,IETHFLG - - -C INPUT IS: SCRATCH FILE 37, WHICH IS POSITIONED AT THE BEGINNING OF -C THE INFO FOR THE SUBJECT DESIRED. - -C OUTPUT ARE: - -C NOBSER = THE NO. OF OBSERVATIONS FOR THIS SUBJECT. -C YO(I,J),I=1,M; J=1,NUMEQT = NO. OF OUTPUT EQS; I=1,M, WHERE M = NO. -C OF OBSERVATION TIMES. -C [C0(J),C1(J),C2(J),C3(J)] = ASSAY NOISE COEFFICIENTS FOR OUTPUT EQ. -C J; J=1,NUMEQT. - - -C AGE, SEX, HEIGHT, AND ETHNICITY FLAG ARE ON LINES 8-11. - - DO I=1,7 - READ(37,*) - END DO - - READ(37,*) AGE - READ(37,2) SEX - 2 FORMAT(A1) - ISEX=1 - IF(SEX .EQ. 'F') ISEX=2 - - READ(37,*) HEIGHT - READ(37,*) IETHFLG - - -C READ THE NO. OF DRUGS FROM THE LINE WITH 'NO. OF DRUGS' AS ENTRIES -C 12:23. THEN READ NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE -C EVENTS, ETC. - - 1 FORMAT(A1000) - 10 READ(37,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 - BACKSPACE(37) - - 3 FORMAT(T2,I5) - READ(37,3) NDRUG - - - IF(NDRUG .GT. 7) THEN - - - - WRITE(*,124) - 124 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 7'/ - 1' DRUGS. THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,124) - CLOSE(47) - - - - CALL PAUSE - - - STOP - - - - - ENDIF - - - READ(37,3) NADD - -C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND - -C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE -C BEYOND THE FIRST 4 ABOVE, AGE, SEX, HEIGHT, AND ETHNICITY FLAG). - - NI = 2*NDRUG + NADD - - IF(NI .GT. 34) THEN - - - - WRITE(*,123) - 123 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY COLUMNS IN '/ - 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ - 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ - 3' NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,123) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - READ(37,3) ND - - IF(ND .GT. 5000) THEN - - - - WRITE(*,125) - 125 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 5000'/ - 1' DOSE EVENTS. THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,125) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - -C ND*NDRUG IS THE TOTAL NO. OF IV RATES OVER WHICH THE PROGRAM WILL -C DO ITS MINIMIZATION. THESE VALUES ARE RETURNED TO MAIN IN THE -C ARGUMENT LIST. - - READ(37,*) - READ(37,*) - - - IF(ND.EQ.0) GO TO 40 - - DO I = 1,ND - READ(37,*) SIG(I),(RS(I,J),J=1,NI) - END DO - - -C ESTABLISH RSS = RS; ONE IS A DUMMY ARGUMENT; THE OTHER IS USED IN -C A COMMON. SIMILARLY SET NDD = ND, AND NNDRUG = NDRUG. AND ALSO -C SET SIGG(.) = SIG(.) - - - - NNDRUG = NDRUG - NDD = ND - DO I=1,ND - SIGG(I) = SIG(I) - - DO J=1,NI - RSS(I,J) = RS(I,J) - END DO - END DO - - - -C ASSIGN THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - -C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' -C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC. - - 40 READ(37,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 - BACKSPACE(37) - - READ(37,3) NUMEQT - READ(37,3) M - - IF(M .GT. MAXOBDIM) THEN - - - - WRITE(*,126) MAXOBDIM - 126 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ - 1' MANY OBSERVED VALUE TIMES. THIS NO. CANNOT EXCEED ',I5,'.'/ - 2' THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,126) MAXOBDIM - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - - IF(NUMEQT .GT. MAXNUMEQ) THEN - - WRITE(*,127) MAXNUMEQ - 127 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ - 1' MANY OUTPUT EQUATION COLUMNS. THIS NO. CANNOT EXCEED ',I2,'.'/ - 2' THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,127) MAXNUMEQ - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - DO I=1,M - READ(37,*) TIM(I),(YO(I,J),J=1,NUMEQT) - END DO - -C PUT YO VALUES INTO YOO BECAUSE A DUMMY ARGUMENT CANNOT BE IN A -C COMMON STATEMENT. - - DO I=1,M - DO J=1,NUMEQT - YOO(I,J) = YO(I,J) - END DO - END DO - - - NOBSER = M - - -C AT THIS POINT, MUST SKIP THE COVARIATE INFO IN THE FILE, AND PROCEED -C TO READ THE ASSAY NOISE COEFFICIENTS BELOW THAT. - - -C READ THE NUMEQT SETS OF ASSAY COEFFICIENTS JUST BELOW THE LINE -C WHICH HAS "ASSAY COEFFICIENTS FOLLOW" IN ENTRIES 1:25. - - - 50 READ(37,1) READLINE - IF(READLINE(1:25) .NE. 'ASSAY COEFFICIENTS FOLLOW') GO TO 50 - - DO IEQ = 1,NUMEQT - - READ(37,*) C0(IEQ),C1(IEQ),C2(IEQ),C3(IEQ) - END DO - - RETURN - END - - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE STACK(PATH,MAXOBDIM,PATFIL,AF) - -C THIS ROUTINE, CALLED BY MAIN, READS THE INFO IN FILE PATFIL, AND -C APPENDS IT ONTO THE END OF FILE 27. - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - - - - DIMENSION SIG(5000),RS(5000,34),AF(7) - CHARACTER PATFIL*20,READLINE*1000,PATH*60,TMPFILE*13, - 1 PATHFILE*73,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - -C SEE SUBROUTINE FILRED FOR SOME DETAILS ON THE MAJOR CHANGES AS -C OF NPBIG11.FOR. - -C INPUT IS: - - -C PATH = LOCATION (DIRECTORY) OF PATIENT DATA FILES. -C PATFIL = PATIENT DATA FILE. - - -C AF = ACTIVE FRACTION OF THE DRUG. EACH IV RATE AND BOLUS VALUE -C MUST BE MULTIPLIED BY AF. - - -C OUTPUT IS: - -C FILE 27 WHICH NOW HAS PATFIL APPENDED ONTO ITS END. -C COPY LINE-BY-LINE PATFIL TO FILE 27 EXCEPT FOR THE DOSAGE REGIMEN - -C (BECAUSE EACH IV RATE AND BOLUS INPUT MUST BE MULTIPLIED BY AF BEFORE -C BEING WRITTEN TO FILE 27). - - 1 FORMAT(A1000) - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = PATFIL - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE) - 10 READ(21,1,IOSTAT=IEND) READLINE - - -C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED. - - IF(IEND .LT. 0) THEN - - WRITE(*,128) PATFIL - 128 FORMAT(/' PATIENT DATA FILE ',A20,' HAS AN OLD-STYLE WORKING'/ - 1' COPY FORMAT.'// - 2' TO BE ACCEPTABLE TO THIS PROGRAM, A PATIENT DATA FILE MUST'/ - 3' HAVE BEEN MADE BY A RECENT BOXES PROGRAM. THE FILE MUST HAVE'/ - 4' "NO OF DRUGS" IN ENTRIES 12 THROUGH 23 ON OR NEAR LINE 18.'// - 5' THE PROGRAM STOPS. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,128) PATFIL - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - WRITE(27,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 - -C READLINE NOW CONTAINS THE NO. OF DRUGS, NDRUG. BACKSPACE AND READ -C NDRUG; THEN READ THE NO. OF ADDITIONAL COVARIATES, AND THE NO. OF -C DOSE EVENTS. - - - BACKSPACE(21) - 3 FORMAT(T2,I5) - - READ(21,3) NDRUG - - IF(NDRUG .GT. 7) THEN - - WRITE(*,124) PATFIL - 124 FORMAT(' PATIENT DATA FILE ',A20,' HAS TOO MANY DRUGS'/ - 1' (I.E, MORE THAN 7). THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,124) PATFIL - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - READ(21,3) NADD - - -C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND -C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE). - - NI = 2*NDRUG + NADD - - IF(NI .GT. 34) THEN - - - - WRITE(*,123) PATFIL - 123 FORMAT(/' PATIENT DATA FILE ',A20,' HAS TOO MANY COLUMNS IN '/ - 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ - 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ - 3' NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,123) PATFIL - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - READ(21,3) ND - - IF(ND .GT. 5000) THEN - - - - WRITE(*,125) PATFIL - - 125 FORMAT(' PATIENT DATA FILE ',A20,' HAS TOO MANY DOSE EVENTS'/ - 1' (I.E., MORE THAN 5000). THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,125) PATFIL - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - -C BACKSPACE TWICE AND PUT THE LAST TWO LINES, AND THE NEXT TWO LINES -C ONTO FILE 27 (THE NEXT LINE AFTER THAT STARTS THE DOSAGE REGIMEN). - - BACKSPACE(21) - BACKSPACE(21) - - DO I=1,4 - - READ(21,1) READLINE - WRITE(27,1) READLINE - END DO - - IF(ND.EQ.0) GO TO 40 - -C THE FIRST NDRUG*2 COLUMNS OF R HAVE THE IV AND BOLUS VALUES FOR -C THE NDRUG DRUGS IN THE FILE. THESE VALUES MUST BE MULTIPLIED BY -C AF(I), WHERE I IS THE DRUG NO. - - DO I = 1,ND - - READ(21,*) SIG(I),(RS(I,J),J=1,NI) - - DO J = 1,2*NDRUG - -C THE DRUG NO., IDRUG, IS THE INTEGER VALUE OF (J+1)/2. EX: (J+1)/2 -C WILL BE 1 IF J = 1 OR 2 SINCE INTEGER ARITHMETIC TRUNCATES. - - IDRUG = (J+1)/2 - RS(I,J) = RS(I,J)*AF(IDRUG) - - - END DO - - WRITE(27,*) SIG(I),(RS(I,J),J=1,NI) - - END DO - -C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' -C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC. CHECK -C THAT THESE ENTRIES ARE NOT TOO BIG. IF NOT, WRITE THE REST OF THE -C FILE 21 TO FILE 27. - - - 40 READ(21,1) READLINE - WRITE(27,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 - - BACKSPACE(21) - - READ(21,3) NUMEQT - READ(21,3) M - - IF(M .GT. MAXOBDIM) THEN - - - - WRITE(*,126) PATFIL,M,MAXOBDIM,MAXOBDIM - 126 FORMAT(/' PATIENT ',A20,' HAS ',I3,' OBSERVATION TIMES. THIS '/ - 1' IS MORE THAN THE ALLOWABLE MAXIMUM OF ',I3,'. PLEASE RERUN THE'/ - 2' PROGRAM AFTER ENSURING THAT ALL YOUR PATIENTS HAVE NO MORE '/ - 3' THAN ',I3,' OBSERVATION TIMES. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,126) PATFIL,M,MAXOBDIM,MAXOBDIM - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - - IF(NUMEQT .GT. MAXNUMEQ) THEN - - WRITE(*,127) PATFIL,NUMEQT,MAXNUMEQ,MAXNUMEQ - 127 FORMAT(/' PATIENT ',A20,' HAS ',I3,' OUTPUT EQUATION COLUMNS,'/ - 1' WHICH IS MORE THAN THE MAXIMUM ALLOWABLE NO. OF ',I2,'.'/ - 2' PLEASE RERUN THE PROGRAM AFTER ENSURING THAT ALL YOUR PATIENTS'/ - 3' HAVE NO MORE THAN ',I2,' OUTPUT EQUATION COLUMNS. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,127) PATFIL,NUMEQT,MAXNUMEQ,MAXNUMEQ - CLOSE(47) - - - - CALL PAUSE - - - STOP - - - - ENDIF - -C BACKSPACE JUST ONCE TO THE LINE WITH M ON IT, SINCE THE LINE WITH -C NUMEQT ON IT WAS ALREADY PUT INTO FILE 27. THEN COPY LINE FOR LINE -C THE REST OF THE FILE TO FILE 27. NOTE THAT IEND .LT. 0 --> END OF -C FILE REACHED. - - BACKSPACE(21) - - 20 READ(21,1,IOSTAT=IEND) READLINE - IF(IEND .LT. 0) GO TO 100 - WRITE(27,1) READLINE - GO TO 20 - 100 CLOSE(21) - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE ELDERY(N,START,XMIN,YNEWLO,REQMIN,STEP, - X ITMAX,FUNC,IPRINT,ICONV,NITER,ICOUNT,IPRINTOUT) - - - -C ELDERX DIFFERS FROM ELDER (DESCRIBED BELOW) ONLY IN THAT N, THE -C DIMENSION OF START (THE NO. OF UNKNOWN PARAMETERS OVER WHICH THE -C MINIMIZATION IS DONE) IS PASSED TO THE SUBROUTINE FUNC IN THE CALLING -C STATEMENTS. - - -C ELDER IS A PROGRAM TO MINIMIZE A FUNCTION USING THE NELDER-MEED -C ALGORITM. -C THE CODE WAS ADAPTED FROM A PROG. IN J. OF QUALITY TECHNOLOGY VOL. -C JAN. 1974. BY D.M. OLSSON. -C CALLING ARGUMENTS: -C N -NUMBER OF UNKNOWN PARAMS. UP TO 99. -C START -A VECTOR WITH THE INITIAL QUESSES OF THE SOLUTION PARAMS. -C ITMAX -THE MAXIMUM NUMBER OF ITERATIONS. -C (KCOUNT IS THE MAX NUM OF FUNC CALLS.SET AT 1000000) -C STEP -THE STEP SIZE VECTOR FOR DEFINING THE N ADDITIONAL -C VERTICIES. -C REQMIN-THE STOP TOLERANCE. - -C XMIN -THE SOLUTION VECTOR. -C YNEWLO-THE FUCTION VALUE AT XMIN. - - -C IPRINT-SWITCH WHICH DETERMINES IF INTERMEDIATE ITERATIONS -C ARE TO BE PRINTED. (0=NO,1=YES). -C ICONV -FLAG INDICATING WHETHER OR NOT CONVERGENCE HAS BEEN -C ACHEIVED. (0=NO,1=YES). -C NITER -THE NUMBER OF ITERATIONS PERFORMED. -C ICOUNT-THE NUMBER OF FUNCTION EVALUATIONS. -C FUNC -THE NAME OF THE SUBROUTINE DEFINING THE FUNCTION. - -C THIS SUBROUTINE MUST EVALUATE THE FUNCTION GIVEN A -C VALUE FOR THE PARAMETER VECTOR. THE ROUTINE IS OF -C THE FOLLOWING FORM: -C FUNC(P,FV), WHERE P IS THE PARAMETER VECTOR, -C AND FV IS THE FUNCTION VALUE. - -C A SUBROUTINE TO PRINT THE RESULTS OF ITERMEDIATE ITERATIONS -C MUST ALSO BE SUPPLIED. ITS NAME AND CALLING SEQUENCE ARE -C DEFINED AS FOLLOWS: -C PRNOUT(P,N,NITER,NFCALL,FV). -C OTHER PROGRAM VARIABLES OF INTEREST ARE; -C XSEC -THE COORDINATES OF THE VETEX WITH THE 2ND SMALLEST FUNCTION -C VALUE. NOTE: XSEC IS NOT USED. REMOVED IN BESTDOS7.FOR, IT -C IS REMOVED FROM THE DIMENSION STATEMENT, AND IS NOT - -C ASSIGNED VALUES ABOVE LABEL 26. - - -C YSEC - THE FUNCTION VALUE AT XSEC. - - PARAMETER(NMAX=5000) - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION START(N),STEP(N),XMIN(N), - X P(NMAX,NMAX+1),PSTAR(NMAX),P2STAR(NMAX),PBAR(NMAX),Y(NMAX+1) - EXTERNAL FUNC - DATA RCOEFF/1.0D0/,ECOEFF/2.0D0/,CCOEFF/.5D0/ - KCOUNT=1000000 - ICOUNT=0 - - NITER=0 - ICONV=0 -C -C CHECK INPUT DATA AND RETURN IF AN ERROR IS FOUND. -C - - IF(REQMIN.LE.0.0D0) ICOUNT=ICOUNT-1 - IF(N.LE.0) ICOUNT=ICOUNT-10 - IF(N.GT.99) ICOUNT=ICOUNT-10 - IF(ICOUNT.LT.0) RETURN -C -C SET INITIAL CONSTANTS -C - DABIT=2.04607D-35 - BIGNUM=1.0D+38 - KONVGE=5 -C XN=FLOAT(N) - DN=FLOAT(N) - - NN=N+1 - - -C -C CONSTRUCTION OF INITIAL SIMPLEX. -C -1001 DO 1 I=1,N -1 P(I,NN)=START(I) - - CALL FUNC(N,START,FN) - Y(NN)=FN - ICOUNT=ICOUNT+1 -C CALL PRNOUT(START,N,NITER,ICOUNT,FN) - IF(ITMAX.NE.0) GO TO 40 - DO 45 I=1,N -45 XMIN(I)=START(I) - YNEWLO=FN - RETURN -40 DO 2 J=1,N - DCHK=START(J) - START(J)=DCHK+STEP(J) - DO 3 I=1,N -3 P(I,J)=START(I) - CALL FUNC(N,START,FN) - Y(J)=FN - ICOUNT=ICOUNT+1 -2 START(J)=DCHK -C -C SIMPLEX CONSTRUCTION COMPLETE. -C -C FIND THE HIGHEST AND LOWEST VALUES. YNEWLO (Y(IHI)) INDICATES THE -C VERTEX OF THE SIMPLEX TO BE REPLACED. -C -1000 YLO=Y(1) - YNEWLO=YLO - ILO=1 - IHI=1 - - - DO 5 I=2,NN - IF(Y(I).GE.YLO) GO TO 4 - YLO=Y(I) - ILO=I -4 IF(Y(I).LE.YNEWLO) GO TO 5 - - YNEWLO=Y(I) - IHI=I -5 CONTINUE -C - - IF(ICOUNT.LE.NN) YOLDLO=YLO - - IF(ICOUNT.LE.NN) GO TO 2002 - IF(YLO.GE.YOLDLO) GO TO 2002 - YOLDLO=YLO - NITER=NITER+1 - IF(NITER.GE.ITMAX) GO TO 900 - IF(IPRINT.EQ.0) GO TO 2002 -C CALL PRNOUT(P(1,ILO),N,NITER,ICOUNT,YLO) -C -C PERFORM CONVERGENCE CHECKS ON FUNCTIONS. -C -2002 DCHK=(YNEWLO+DABIT)/(YLO+DABIT)-1.0D0 - -C PRINT OUT NITER (ITERATION NO.) AND ITMAX (MAX. NO. OF ITERATIONS) - -C STARTING WITH THE BESTDOS4.FOR PROGRAM, BECAUSE THIS PROGRAM SOLVES -C D.E.'S WHICH MEANS IT CAN TAKE A LONG TIME, AND NITER AND ITMAX -C GIVE AT LEAST SOME INDICATION OF HOW LONG THE PROGRAM HAS GONE AND - -C HOW LONG IT COULD GO. SIMILARLY, PRINT OUT DABS(DCHK) AN REQMIN, - -C THE MEASURE OF HOW CLOSE TO CONVERGENCE THE PROGRAM IS AND THE -C REQUIRED TOLERANCE FOR CONVERGENCE. - - -C THE FOLLOWING CONVERGENCE INFO IS ONLY WRITTEN IF IPRINTOUT = 1. - - - IF(IPRINTOUT .EQ. 1) WRITE(*,1234) NITER,ITMAX,DABS(DCHK),REQMIN - 1234 FORMAT('+ ',' ITER ',I5,' (MAX = ',I5,') TOL = ',G10.4,' (CONV. - 1 TOL = ',G10.4,')') - - IF(DABS(DCHK).GT. REQMIN) GO TO 2001 - - ICONV=1 - GO TO 900 -C -2001 KONVGE=KONVGE-1 - IF(KONVGE.NE.0) GO TO 2020 - KONVGE=5 - -C -C CHECK CONVERGENCE OF COORDINATES ONLY EVERY 5 SIMPLEXES. -C - DO 2015 I=1,N - - COORD1=P(I,1) - COORD2=COORD1 - DO 2010 J=2,NN - IF(P(I,J).GE.COORD1) GO TO 2005 - COORD1=P(I,J) -2005 IF(P(I,J).LE.COORD2) GO TO 2010 - COORD2=P(I,J) -2010 CONTINUE - DCHK=(COORD2+DABIT)/(COORD1+DABIT)-1.0D0 - IF(DABS(DCHK).GT.REQMIN) GO TO 2020 -2015 CONTINUE - ICONV=1 - GO TO 900 -2020 IF(ICOUNT.GE.KCOUNT) GO TO 900 -C -C CALCULATE PBAR, THE CENTRIOD OF THE SIMPLEX VERTICES EXCEPTING THAT -C WITH Y VALUE YNEWLO. -C - DO 7 I=1,N - Z=0.0D0 - DO 6 J=1,NN -6 Z=Z+P(I,J) - Z=Z-P(I,IHI) -7 PBAR(I)=Z/DN -C -C REFLECTION THROUGH THE CENTROID. -C - DO 8 I=1,N - -8 PSTAR(I)=(1.0D0+RCOEFF)*PBAR(I)-RCOEFF*P(I,IHI) - CALL FUNC(N,PSTAR,FN) - YSTAR=FN - ICOUNT=ICOUNT+1 - IF(YSTAR.GE.YLO) GO TO 12 - IF(ICOUNT.GE.KCOUNT) GO TO 19 -C -C SUCESSFUL REFLECTION SO EXTENSION. - -C - DO 9 I=1,N - -9 P2STAR(I)=ECOEFF*PSTAR(I)+(1.0D0-ECOEFF)*PBAR(I) - CALL FUNC(N,P2STAR,FN) - Y2STAR=FN - - ICOUNT=ICOUNT+1 -C - -C RETAIN EXTENSION OR CONTRACTION. - -C - IF(Y2STAR.GE.YSTAR) GO TO 19 -10 DO 11 I=1,N -11 P(I,IHI)=P2STAR(I) - - Y(IHI)=Y2STAR - GO TO 1000 -C -C NO EXTENSION. -C -12 L=0 - DO 13 I=1,NN - IF(Y(I).GT.YSTAR) L=L+1 -13 CONTINUE - IF(L.GT.1) GO TO 19 - IF(L.EQ.0) GO TO 15 -C - -C CONTRACTION ON REFLECTION SIDE OF CENTROID. -C - DO 14 I=1,N -14 P(I,IHI)=PSTAR(I) - Y(IHI)=YSTAR -C -C CONTRACTION ON THE Y(IHI) SIDE OF THE CENTROID. -C -15 IF(ICOUNT.GE.KCOUNT) GO TO 900 - DO 16 I=1,N -16 P2STAR(I)=CCOEFF*P(I,IHI)+(1.0D0-CCOEFF)*PBAR(I) - CALL FUNC(N,P2STAR,FN) - Y2STAR=FN - ICOUNT=ICOUNT+1 - - IF(Y2STAR.LT.Y(IHI)) GO TO 10 -C -C CONTRACT THE WHOLE SIMPLEX -C - DO 18 J=1,NN - DO 17 I=1,N - P(I,J)=(P(I,J)+P(I,ILO))*0.5D0 -17 XMIN(I)=P(I,J) - CALL FUNC(N,XMIN,FN) - Y(J)=FN - -18 CONTINUE - ICOUNT=ICOUNT+NN - IF(ICOUNT.LT.KCOUNT) GO TO 1000 - GO TO 900 -C -C RETAIN REFLECTION. -C -19 CONTINUE - DO 20 I=1,N -20 P(I,IHI)=PSTAR(I) - Y(IHI)=YSTAR - GO TO 1000 -C -C SELECT THE TWO BEST FUNCTION VALUES (YNEWLO AND YSEC) AND THEIR -C COORDINATES (XMIN AND XSEC)>. XSEC NOT SET AS OF BESTDOS7.FOR. -C -900 DO 23 J=1,NN - DO 22 I=1,N -22 XMIN(I)=P(I,J) - CALL FUNC(N,XMIN,FN) - Y(J)=FN -23 CONTINUE - ICOUNT=ICOUNT+NN - YNEWLO=BIGNUM - DO 24 J=1,NN - IF(Y(J).GE.YNEWLO) GO TO 24 - YNEWLO=Y(J) - IBEST=J -24 CONTINUE - - Y(IBEST)=BIGNUM - YSEC=BIGNUM - DO 25 J=1,NN - IF(Y(J).GE.YSEC) GO TO 25 - YSEC=Y(J) -C ISEC=J ... ISEC NOT USED. REMOVED IN BESTDOS7.FOR. -25 CONTINUE - DO 26 I=1,N - XMIN(I)=P(I,IBEST) -26 CONTINUE - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX, - 1 PARFIX,IRAN,INOPT) - -C THIS SUBROUTINE, CALLED BY MAIN, READS THE FORTRAN FILE, FORFILE, -C OPENED IN MAIN (FILE 28), WHICH WAS CREATED BY A 'BOXES'- TYPE -C PROGRAM, AND RETURNS THE VALUES IN THE ABOVE ARGUMENT LIST. - -C ??? -C NOTE: WHEN THIS PROGRAM STARTS READING THE NEW BOXES PROGRAM, MAKE -C SURE THAT THE MICHAELIS-MENTIN EQUATION IS CORRECT - IT SHOULD -C BE (SEE PAGE *1 OF M2_7/m2_7calc.f NOTES OR NOTES FROM PG. 5. -C OF PHARMACOKINETICS AND PHARMACODYNAMICS, VOL 2). - -C dX/dT = (VM x X) / (KM x V1 + X), WHERE VM = V1 * Vmax, AND -C THE UNITS ARE: X --> grams; T --> hours; VM --> grams/hour; - -C V1 --> liters; KM --> grams/liter; -C Vmax --> grams/(liter * hour) - -C NOTE: THE ABOVE EQUATION IS EXACTLY THE SAME AS -C dC/dT = (Vmax * C)/(KM + C), WHERE C = X/V1, WHICH IS -C EQUATION 3 ON PG. 5 OF PHARMACOKINETICS AND PHARMACODYNAMICS, -C VOL 2, WHERE: -C Vmax = dC/dT AS C--> infinity; -C KM = C WHEN dC/dT = Vmax/2. - - -C ABOVE COMMENTS WERE IMPROVED 7/27/99 AFTER -C CONVERSATION WITH ROGER AND DARRYL CLARDY. -C ??? - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION IRAN(32) - - CHARACTER PAR(30)*11,PARFIX(20)*11,READLINE*1000, - 1 PSYM(32)*11,RR*1,TEMP*11,C*1,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C FILE 28 WAS OPENED (IN MAIN) AT THE END OF THE FILE. BACKSPACE AND -C THEN READ IN NDIM, NP AND PSYM(I),I=1,NP. - - 2 FORMAT(A1000) - - 30 BACKSPACE(28) - - BACKSPACE(28) - READ(28,2) READLINE - IF(READLINE(8:9) .NE. 'N=') GO TO 30 - BACKSPACE(28) - READ(28,3) NDIM - 3 FORMAT(T10,I3) - - 40 READ(28,2) READLINE - IF(READLINE(8:9) .NE. 'NP') GO TO 40 - BACKSPACE(28) - READ(28,4) NP - 4 FORMAT(T11,I3) - - 50 READ(28,2) READLINE - - IF(READLINE(8:11) .NE. 'PSYM') GO TO 50 - BACKSPACE(28) - - DO 70 I=1,NP - - IF(I .LE. 9) READ(28,14) TEMP - IF(I .GE. 10 .AND. I .LE. 99) READ(28,6) TEMP - -C WRITE TEMP INTO PSYM, STRIPPING OFF THE ENDING QUOTE MARK, IF ONE -C IS THERE. - - C = '''' - - PSYM(I) = TEMP - - DO J=1,11 - - IF(TEMP(J:J) .EQ. C) THEN - PSYM(I) = TEMP(1:J-1) - GO TO 70 - ENDIF - - END DO - - - - 70 CONTINUE - - 14 FORMAT(T17,A11) - 6 FORMAT(T18,A11) - - -C IF INOPT .EQ. 3 (MEANING THE PROGRAM HAS ALREADY OPENED THE -C FILE, 'GUICMDS.INX'), THE NEXT LINE IN THE INSTRUCTION FILE HAS -C THE VALUES FOR IRAN(I),I=1,NP. READ THIS LINE, CALCULATE NVAR AND -C NOFIX AND ... THAT'S IT. THERE IS NO USER INTERACTION IF -C INOPT .EQ. 3. - - IF(INOPT .EQ. 3) THEN - - READ(23,*) -C SKIP THIS LINE. IT CONTAINS 'IRAN INDICES'. - - - READ(23,*) (IRAN(I),I=1,NP) - - NVAR = 0 - NOFIX = 0 - - DO I = 1,NP - - - IF(IRAN(I) .EQ. 1) THEN - NVAR = NVAR+1 - PAR(NVAR) = PSYM(I) - ENDIF - - IF(IRAN(I) .EQ. 0) THEN - NOFIX = NOFIX + 1 - PARFIX(NOFIX) = PSYM(I) - ENDIF - - END DO - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 3) CONDITION. - - -C IF INOPT .EQ. 1 (MEANING THE PROGRAM HAS ALREADY OPENED AN -C INSTRUCTION FILE) THE NEXT LINE IN THE INSTRUCTION FILE HAS THE -C VALUES FOR IRAN(I),I=1,NP. READ THIS LINE AND PRESENT THE INFO TO -C THE USER. - - IF(INOPT .EQ. 1) THEN - - READ(23,*) -C SKIP THIS LINE. IT CONTAINS 'IRAN INDICES'. - - READ(23,*) (IRAN(I),I=1,NP) - WRITE(*,201) - 201 FORMAT(/' YOU HAVE SELECTED YOUR PARAMETERS TO BE RANDOM'/ - 1' OR FIXED AS INDICATED BELOW. IF YOU WANT TO CHANGE THIS, YOU'/ - 2' WILL HAVE TO RERUN THIS PROGRAM WITHOUT AN INSTRUCTION FILE'/ - 3' SINCE THE REST OF THIS INSTRUCTION FILE (BOUNDARIES AND/OR'/ - 4' FIXED VALUES WILL NOT BE COMPATIBLE WITH YOUR CHANGED '/ - 5' DESIGNATIONS.'/) - - CALL PAUSE - - - - NVAR = 0 - NOFIX = 0 - - - DO I = 1,NP - - - IF(IRAN(I) .EQ. 1) THEN - TEMP = 'RANDOM' - NVAR = NVAR+1 - PAR(NVAR) = PSYM(I) - ENDIF - - IF(IRAN(I) .EQ. 0) THEN - TEMP = 'FIXED' - - NOFIX = NOFIX + 1 - PARFIX(NOFIX) = PSYM(I) - ENDIF - - WRITE(*,202) PSYM(I),TEMP - 202 FORMAT(2X,A11,2X,A11) - - END DO - - 210 WRITE(*,203) - 203 FORMAT(/' ENTER 1 IF THE ABOVE DESIGNATIONS ARE CORRECT;'/ - 1' ENTER 0 OTHERWISE: ') - - - READ(*,*,ERR=210) ICORRECT - IF(ICORRECT .NE. 1 .AND. ICORRECT .NE. 0) GO TO 210 - - - IF(ICORRECT .EQ. 0) THEN - - - - WRITE(*,204) - 204 FORMAT(//' PLEASE RERUN THE PROGRAM WITH KEYBOARD ENTRY.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,204) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - -C IF NVAR .GT. MAXDIM, PRINT MESSAGE TO USER AND HAVE HIM TRY AGAIN. -C SIMILARLY IF NOFIX .GT. 20, OR IF NVAR + NOFIX .GT. 32. - - IF(NVAR .GT. MAXDIM) THEN - - - - WRITE(*,207) NVAR,MAXDIM - 207 FORMAT(//' SOMEHOW, YOUR INSTRUCTION FILE HAS ',I2,/ - 1' PARAMETERS DESIGNATED TO BE RANDOM VARIABLES. THE LIMIT IS '/ - 2' CURRENTLY ',I2,'. PLEASE USE A CURRENT INSTRUCTION FILE OR'/ - 3' RERUN THE PROGRAM WITH KEYBOARD ENTRY.'//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,207) NVAR,MAXDIM - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - IF(NOFIX .GT. 20) THEN - - - - WRITE(*,208) NOFIX - 208 FORMAT(//' SOMEHOW, YOUR INSTRUCTION FILE HAS ',I2,/ - 1' PARAMETERS DESIGNATED TO BE FIXED. THE LIMIT IS CURRENTLY 20.'/ - 2' PLEASE USE A CURRENT INSTRUCTION FILE OR RERUN THE PROGRAM'/ - 3' WITH KEYBOARD ENTRY.'//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,208) NOFIX - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - IF(NVAR + NOFIX .GT. 32) THEN - - WRITE(*,209) NVAR + NOFIX - 209 FORMAT(//' SOMEHOW, YOUR INSTRUCTION FILE HAS ',I2,' TOTAL'/ - 1' PARAMETERS. THE LIMIT IS CURRENTLY 32. PLEASE USE A CURRENT '/ - 2' INSTRUCTION FILE OR RERUN THE PROGRAM WITH KEYBOARD ENTRY.'//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,209) NVAR + NOFIX - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 1) CONDITION. - - - - -C THE CODE BELOW IS FOR THE INOPT .EQ. 0 CASE. - - IF(INOPT .EQ. 0) THEN - - -C NOW QUIZ THE USER TO SEE WHICH PARAMETERS ARE FIXED, AND WHICH ARE -C RANDOM. - -C SET IRAN(I) = 1 IF PSYM(I) = RANDOM; -C 0 IF PSYM(I) = FIXED. - - 80 WRITE(*,7) NP - 7 FORMAT(/' FOR EACH OF THE ',I2,' PARAMETERS, '// - 1' ENTER "R" IF IT IS TO BE A RANDOM VARIABLE;'/ - 2' ENTER "F" IF IT IS TO BE A FIXED PARAMETER.'//) - - NVAR = 0 - NOFIX = 0 - - - DO I=1,NP - - - 8 FORMAT(1X,A11,': ') - 60 WRITE(*,8) PSYM(I) - READ(*,9) RR - - 9 FORMAT(A1) - IF(RR .NE. 'R' .AND. RR .NE. 'r' .AND. RR .NE. 'F' - 1 .AND. RR .NE. 'f') GO TO 60 - - IF(RR .EQ. 'R' .OR. RR .EQ. 'r') THEN - NVAR = NVAR+1 - - -C NOTE THAT THIS PROGRAM RESETS NP TO A VERY LARGE VALUE -C IF NVAR > THE DIMENSION LIMIT OF PAR. THIS IS BIZARRE. IT DOESN'T - -C HAPPEN IF NOFIX > THE DIMENSION LIMIT OF PARFIX, AND IT DOESN'T -C HAPPEN IN MONTBIG8.FOR WHICH HAS THE SAME CODE AS HERE. -C BUT SINCE IT HAPPENS HERE, CHECK TO SEE IF NVAR > MAXDIM, AND IF -C SO TRANSFER CONTROL TO LABEL 110 WITHOUT SETTING PAR(MAXDIM+1) TO -C PSYM(I). - - IF(NVAR .GT. MAXDIM) GO TO 110 - PAR(NVAR) = PSYM(I) - - IRAN(I) = 1 - ENDIF - - IF(RR .EQ. 'F' .OR. RR .EQ. 'f') THEN - NOFIX = NOFIX+1 - PARFIX(NOFIX) = PSYM(I) - IRAN(I) = 0 - ENDIF - - - END DO - -C IF NVAR .GT. MAXDIM, PRINT MESSAGE TO USER AND HAVE HIM TRY AGAIN. -C SIMILARLY IF NOFIX .GT. 20, OR IF NVAR + NOFIX .GT. 32. - - 110 IF(NVAR .GT. MAXDIM) THEN - WRITE(*,111) NVAR,MAXDIM - 111 FORMAT(//' YOU HAVE SELECTED ',I2,' PARAMETERS TO BE RANDOM'/ - 1' VARIABLES. THE LIMIT IS CURRENTLY ',I2,'. PLEASE RESELECT YOUR'/ - - 2' RANDOM VARIABLES WITH THIS LIMIT IN MIND.'//) - GO TO 80 - ENDIF - - IF(NOFIX .GT. 20) THEN - WRITE(*,112) NOFIX - 112 FORMAT(//' YOU HAVE SELECTED ',I2,' PARAMETERS TO BE FIXED'/ - 1' PARAMETERS. THE LIMIT IS CURRENTLY 20. PLEASE RESELECT YOUR'/ - 2' RANDOM VARIABLES WITH THIS LIMIT IN MIND.'//) - GO TO 80 - ENDIF - - IF(NVAR + NOFIX .GT. 32) THEN - - - - WRITE(*,113) NVAR + NOFIX - 113 FORMAT(//' YOUR MODEL FILE HAS A TOTAL OF ',I2,' PARAMETERS.'/ - 1' THE LIMIT IS CURRENTLY 32. PLEASE EDIT YOUR MODEL FILE SO '/ - 2' THAT IT HAS .LE. 32 PARAMETERS. '//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,113) NVAR + NOFIX - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INOPT .EQ. 0) CONDITION. - - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - -C SUBROUTINE DETECT(NOB,PATH,FORFILE,IVERS) - REMOVED. - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - -C SUBROUTINE CHECKLIN(READLINE,TARGET,IYES) - REMOVED. - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - -C SUBROUTINE WRITEDIF(IVERS) - REMOVED. - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - -C SUBROUTINE WRITEOUT(IVERS) - REMOVED. - - - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - -C SUBROUTINE WRITESYM(IVERS) - REMOVED. - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - -C SUBROUTINE SKIPLINE(READLINE,IYES) - REMOVED. - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - - SUBROUTINE GETNUMEQ(NUMEQT,NDRUG) - - IMPLICIT REAL*8(A-H,O-Z) - CHARACTER READLINE*78,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - -C THIS SUBROUTINE READS THE PATIENT DATA FILE (FILE 21) TO FIND THE -C NO. OF OUTPUT EQUATIONS (NUMEQT), AND THE NO. OF DRUGS (NDRUG). - -C PRINT MESSAGE TO THE USER THAT IF HE CHANGES HIS WORKING COPY -C FILE IN SUBROUTINE VERIF1, HE MUST MAKE SURE THAT THE NEW WORKING -C COPY FILE HAS THE SAME NO. OF OUTPUT EQUATIONS AS THE FILE. - - WRITE(*,4) - 4 FORMAT(//' YOUR WORKING COPY FILE WILL NOW BE OPENED TO'/ - 1' READ THE NUMBER OF OUTPUT EQUATIONS, AND THE NUMBER OF DRUGS.'/ - - 2' LATER, YOU WILL HAVE THE OPTION TO CHANGE YOUR WORKING COPY'/ - 3' FILE. IF YOU DO THIS, MAKE SURE THAT THE NEW FILE HAS THE SAME'/ - - 4' NUMBER OF OUTPUT EQUATIONS AND THE SAME NUMBER OF DRUGS.'//) - - CALL PAUSE - -C NOTE THAT NUMEQT IS ON THE LINE WITH "NO. OF TOTAL OUTPUT EQUATIONS" -C IN COLUMNS 12:40. IF NO LINE HAS THESE WORDS, THIS PATIENT DATA -C FILE IS NOT A NEW-STYLE WORKING COPY FILE FROM ANDREAS' NEW -C BOXES PROGRAM. - - 3 FORMAT(A78) - 35 READ(21,3,IOSTAT=IEND) READLINE - - IF(IEND .LT. 0) THEN - - - - WRITE(*,58) - 58 FORMAT(//' YOUR WORKING COPY FILE IS NOT A CURRENT MULTIPLE'/ - 1' DRUG WORKING COPY FILE. SUCH A FILE MUST HAVE A LINE WITH '/ - 2' "NO. OF DRUGS" IN COLUMNS 12:23.'// - 3' THE PROGRAM STOPS. '//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,58) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 35 - BACKSPACE(21) - 13 FORMAT(T2,I5) - READ(21,13) NDRUG - - - 45 READ(21,3,IOSTAT=IEND) READLINE - - IF(IEND .LT. 0) THEN - - - - WRITE(*,59) - 59 FORMAT(//' YOUR WORKING COPY FILE IS NOT A CURRENT MULTIPLE'/ - 1' DRUG WORKING COPY FILE. SUCH A FILE MUST HAVE A LINE WITH '/ - 2' "NO. OF TOTAL OUTPUT EQUATIONS IN COLUMNS 12:40.'// - 3' THE PROGRAM STOPS. '//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,59) - CLOSE(47) - - - - - CALL PAUSE - STOP - - - - ENDIF - - IF(READLINE(12:40) .NE. 'NO. OF TOTAL OUTPUT EQUATIONS') - 1 GO TO 45 - BACKSPACE(21) - READ(21,13) NUMEQT - CLOSE(21) - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE PAUSE - -C THIS ROUTINE IS USED TO REPLACE A PAUSE STATEMENT, WHICH CAUSES -C WARNINGS WHEN THIS PROGRAM IS COMPILED AND LINKED USING gfortran -C (AND FORCES THE USER TO TYPE "go" INSTEAD OF SIMPLY HITTING THE -C ENTER KEY). - - WRITE(*,1) - 1 FORMAT(' HIT ANY KEY TO CONTINUE: ') - READ(*,*,ERR=10) IKEY - IF(IKEY .EQ. 1) RETURN - 10 RETURN - - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE VERIF1(FORFILE,ICSVFILE,FUTUREFILEIN,PATH,NOB,C0P, - 1 C1P,C2P,C3P,NUMEQT,NOFIX,VALFIX,PARFIX,TOLER,ATOL,IASS,AF, - 2 MATFIL,NPAGDENFILE,INCLUDPAST,IPASTFILE,PASTFILEIN, - 3 IERRMOD,GAMLAM,NDRUG,IPRIOROBS,TNEXT,IDELTA,MAXOBDIM,MAXCYC, - 4 IOPTIMIZE,BIASWEIGHT,ITARGET) - - PARAMETER(MAXDIM=25) - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION C0P(MAXNUMEQ),C1P(MAXNUMEQ),C2P(MAXNUMEQ), - 1 C3P(MAXNUMEQ),VALFIX(20),IASS(MAXNUMEQ),IRAN(32),ATOL(20),AF(7) - - CHARACTER FORFILE*20,MATFIL*20,FUTUREFILEIN*20,PARFIX(20)*11, - 1 TMPFILE*13,PATHFILE*73,PAR(30)*11,PATH*60,NPAGDENFILE*20, - 2 PASTFILEIN*20,ESTNAM*6 - -C SUBROUTINE VERIF1 IS CALLED BY MAIN TO PRINT TO THE SCREEN THE INPUT -C INFO, SO THE USER CAN VERIFY THAT THE VALUES WERE ENTERED CORRECTLY, - -C OR CHANGE VALUES AS DESIRED. - - -C NOTE: SUBROUTINE CHANGE BELOW IS CALLED SEVERAL TIMES. ITS ARGUMENT, -C ICHANG, RETURNS AS 1 IF THE PREVIOUS INFORMATION PRINTED TO THE -C SCREEN IS VALIDATED BY THE USER; IT RETURNS AS 0 IF THE USER -C WANTS TO CHANGE SOMETHING. - - - - 102 FORMAT(A20) - 103 FORMAT(A3) - - 8040 WRITE(*,1) - 1 FORMAT(///' THE FOLLOWING INFO WAS READ IN; IF ANY OF IT IS '/ - 1' INCORRECT, MAKE THE DESIRED CHANGES.') - - WRITE(*,2) FORFILE - 2 FORMAT(/' THE MODEL FILE WHICH IS ALREADY LINKED WITH THIS '/ - 1' PROGRAM, AND IS AN EDITED VERSION OF TSTMULTM.FOR, IS ',A20) - - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - - WRITE(*,3) - 3 FORMAT(/' ENTER THE NAME OF THE MODEL FILE WHICH IS ALREADY'/ - 1' LINKED WITH THIS PROGRAM (IF THIS FILE IS NOT AN EDITED '/ - 2' VERSION OF TSTMULTM.FOR, STOP THE PROGRAM NOW): ') - READ(*,102) FORFILE - - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - 5010 TMPFILE = ' ' - TMPFILE = FORFILE - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - - OPEN(28,FILE=PATHFILE,ERR=50,STATUS='OLD',POSITION='APPEND') - - GO TO 30 - 50 WRITE(*,4406) FORFILE - 4406 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ - 1' ',A73/ - 2' ENTER THE CORRECT FILENAME OR ... '/ - 2' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,102) FORFILE - IF(FORFILE(1:3) .EQ. '-99') CALL SEEDIR(PATH,NOB,FORFILE) - GO TO 5010 - - 30 CALL USERPREP(NDIM,NP,NVAR,MAXDIM,PAR,NOFIX,PARFIX,IRAN,0) - - CLOSE(28) - -C THE ABOVE CALL OBTAINS THE FOLLOWING VALUES: - -C NDIM = NO. OF STATES FOR THE O.D.E. -C NP = TOTAL NO. OF PARAMETERS = NVAR + NOFIX. -C NVAR = NO. OF R.V.'S (1 .LE. NVAR .LE. MAXDIM). -C PAR(I),I=1,NVAR = NAMES OF THE RANDOM VARIABLES FOR THIS RUN. -C NOFIX = NO. OF NON-RANDOM (FIXED) PARAMETERS WHOSE FIXED VALUES ARE -C TO BE SET BY THE USER. -C PARFIX(I),I=1,NOFIX = NAMES OF FIXED PARAMETERS FOR THIS RUN. - -C IRAN(I) = 1 IF PARAMATER I IS RANDOM; -C 0 IF PARAMETER I IS FIXED; I = 1,NVAR+NOFIX. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION FOR THE -C FORFILE FILE. - - IF(INCLUDPAST .EQ. 0) WRITE(*,9001) NPAGDENFILE - 9001 FORMAT(/' YOUR RUN DOES NOT INCLUDE A "PAST" HISTORY FOR THE '/ - 1' SUBJECT BEING ANALYZED. THEREFORE, THE NPAG DENSITY FILE YOU'/ - 2' ENTERED ABOVE, ',A20,', WILL BE USED AS THE PARAMETER DENSITY'/ - 3' FOR THE OPTIMIZATION OVER THE DOSES IN THE "FUTURE" FILE.') - - IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 0) - 1 WRITE(*,9004) PASTFILEIN,NPAGDENFILE - 9004 FORMAT(/' YOUR RUN INCLUDES A "PAST" HISTORY FOR THE SUBJECT'/ - 1' BEING ANALYZED (IN FILE ',A20,'). BUT THIS FILE DOES NOT HAVE'/ - 2' ANY NON-MISSING OBSERVED VALUES, AND SO THE NPAG DENSITY FILE'/ - 3' YOU ENTERED ABOVE, ',A20,', WILL BE USED AS THE PARAMETER'/ - 4' DENSITY FOR THE OPTIMIZATION OVER THE DOSES IN THE "FUTURE" '/ - 5' FILE.') - - - IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN - - IF(IPASTFILE .EQ. 0) WRITE(*,9002) PASTFILEIN,NPAGDENFILE -9002 FORMAT(/' YOUR RUN INCLUDES A "PAST" HISTORY FOR THE SUBJECT'/ - 1' BEING ANALYZED (IN WORKING COPY FILE ',A20,'), AND THIS FILE'/ - 2' HAS NON-MISSING OBSERVED VALUES. THEREFORE, THE NPAG DENSITY'/ - 3' FILE YOU ENTERED ABOVE, ',A20,', WILL BE USED AS A PRIOR'/ - 4' DENSITY FOR ANOTHER NPAG RUN WHICH WILL OBTAIN A '/ - 5' POSTERIOR DENSITY WHICH WILL BE USED AS THE PARAMETER DENSITY'/ - 6' FOR THE OPTIMIZATION OVER THE DOSES IN THE "FUTURE" FILE.') - - - IF(IPASTFILE .EQ. 1) WRITE(*,9003) PASTFILEIN,NPAGDENFILE -9003 FORMAT(/' YOUR RUN INCLUDES A "PAST" HISTORY FOR THE SUBJECT'/ - 1' BEING ANALYZED (IT IS THE INFO OF THE FIRST SUBJECT IN THE'/ - 2' .CSV FILE, ',A20,'), AND THIS FILE HAS NON-MISSING OBSERVED'/ - 3' VALUES. THEREFORE, THE NPAG DENSITY FILE YOU ENTERED ABOVE,'/ - 4' ',A20,' WILL BE USED AS A PRIOR DENSITY FOR ANOTHER NPAG RUN'/ - 5' WHICH WILL OBTAIN A POSTERIOR DENSITY WHICH WILL BE'/ - 6' USED AS THE PARAMETER DENSITY FOR THE OPTIMIZATION OVER THE'/ - 7' DOSES IN THE "FUTURE" FILE.') - - - WRITE(*,8092) MAXCYC - 8092 FORMAT(//' AND THIS NEW NPAG ANALYSIS WILL RUN A MAXIMUM '/ - 1' OF ',I6,' CYCLES.') - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. - - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - - - 8010 WRITE(*,8013) - 8013 FORMAT(/' THIS PROGRAM REQUIRES AN NPAG DENSITY FROM A PREVIOUS'/ - 1' ANALYSIS OF A POPULATION. THIS NPAG DENSITY WILL BE USED AS'/ - 2' THE PARAMETER DENSITY FOR THE OPTIMIZATION OVER THE DOSES IN'/ - 3' THE "FUTURE" OF THE SUBJECT BEING CONSIDERED IN THIS RUN IF'/ - 4' THERE IS NO "PAST" HISTORY FOR THE SUBJECT, OR IF THE "PAST"'/ - 5' HISTORY INCLUDES NO OBSERVED VALUES.'// - 6' BUT IF THERE IS A "PAST" HISTORY FOR THE SUBJECT, AND IT '/ - 7' INCLUDES OBSERVATIONS, THEN THE NPAG DENSITY WILL BE USED AS'/ - 8' AS A PRIOR DENSITY FOR ANOTHER NPAG RUN WHICH WILL OBTAIN A'/ - 9' POSTERIOR DENSITY FOR THE SUBJECT, AND THIS NEW '/ - 1' DENSITY WILL THEN BE THE DENSITY FOR THE OPTIMIZATION. '// - 1' ENTER THE NAME OF THE FILE WHICH CONTAINS THE NPAG DENSITY'/ - 2' FROM A PREVIOUS ANALYSIS OF A POPULATION (IT WILL PROBABLY'/ - 3' BE DENxxxx, WHERE xxxx WAS THE JOB NUMBER): '// - 4' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,102) NPAGDENFILE - IF(NPAGDENFILE(1:3) .EQ. '-99') - - 1 CALL SEEDIR(PATH,NOB,NPAGDENFILE) - - - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE - -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - - TMPFILE = ' ' - TMPFILE = NPAGDENFILE - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8020,STATUS='OLD') - GO TO 8025 - 8020 WRITE(*,5316) PATHFILE - GO TO 8010 - 8025 CLOSE(21) - - 8030 WRITE(*,8031) - 8031 FORMAT(/' ENTER 1 IF THE CALCULATIONS ARE TO INCLUDE THE "PAST" '/ - 1' HISTORY FOR THE SUBJECT OF THIS RUN;'/ - 2' ENTER 0 OTHERWISE: ') - - READ(*,*,ERR=8030) INCLUDPAST - IF(INCLUDPAST .NE. 1 .AND. INCLUDPAST .NE. 0) GO TO 8030 - - IF(INCLUDPAST .EQ. 0) THEN - IPASTFILE = -1 - PASTFILEIN = 'NOT USED' - TNEXT = 0.D0 - ENDIF - -8035 IF(INCLUDPAST .EQ. 1) THEN - - - WRITE(*,8003) -8003 FORMAT(/' ENTER 1 IF THE FILE WHICH HAS THE "PAST" INFO FOR'/ - 1' THE SUBJECT OF THIS RUN IS A .CSV FILE (IN THIS CASE,'/ - 2' THE INFO FOR THE FIRST SUBJECT IN THE .CSV FILE WILL'/ - 3' BE USED); '/ - 4' ENTER 0 IF THE FILE WHICH HAS THE "PAST" INFO FOR THE SUBJECT'/ - 5' OF THIS RUN IS A WORKING COPY FILE: ') - - READ(*,*,ERR=8035) IPASTFILE - IF(IPASTFILE .NE. 1 .AND. IPASTFILE .NE. 0) GO TO 8035 - - IF(IPASTFILE .EQ. 0) THEN - - WRITE(*,1021) - READ(*,102) PASTFILEIN - IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = PASTFILEIN - - - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8050,STATUS='OLD') - GO TO 8045 - 8050 WRITE(*,5316) PATHFILE - GO TO 8030 - 8045 CONTINUE - - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIOROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - - - CLOSE(21) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 0) CONDITION. - - - IF(IPASTFILE .EQ. 1) THEN - - WRITE(*,8021) - 8021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ - 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ - 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// - 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,102) PASTFILEIN - IF(PASTFILEIN(1:3) .EQ. '-99')CALL SEEDIR(PATH,NOB,PASTFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - - TMPFILE = PASTFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,ERR=8060,STATUS='OLD') - - - GO TO 8055 - 8060 WRITE(*,5316) PATHFILE - GO TO 8030 - 8055 CONTINUE - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - CALL CONVERTCSV - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE -C READBLOCK2. - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - -C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.PST IN THE -C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN -C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. - - - REWIND(66) - -C AS OF BESTDOS108, CHANGE ARGUMENTS BELOW FROM C0,...,C3 TO -C C0P,...,C3P (SEE REASON AT THE TOP OF BESTDOS108.FOR). - - CALL READBLOCK2(PATH,C0P,C1P,C2P,C3P,1,0) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - - TMPFILE = ' ' - TMPFILE = 'XQZPJ001.PST' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=8065,STATUS='OLD') - GO TO 8070 - 8065 WRITE(*,5466) PATHFILE,PASTFILEIN - GO TO 8030 - - 8070 CONTINUE - -C MUST INSPECT THIS FILE TO SEE IF THERE ARE ANY OBSERVED VALUES. IF -C SO, THE PROGRAM WILL CALL NPAGFULL TO OBTAIN THE POSTERIOR -C DENSITY BASED ON THE INFO IN THIS FILE AND THE PRIOR DENSITY IN -C NPAGDENFILE; AND THIS NEW DENSITY WILL BE THE ONE USED FOR THE -C OPTIMIZATION OF DOSES. IF NOT, THE DENSITY IN NPAGDENFILE WILL BE -C THE DENSITY USED FOR THE OPTIMIZATION OF DOSES. - - CALL INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C IPRIROBS RETURNS AS 1 IF THERE ARE OBS. VALUES (NON-MISSING ONES) -C IN PATFILE. OTHERWISE, IT RETURNS AS 0. - - - CLOSE(21) - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IPASTFILE .EQ. 1) CONDITION. - - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(INCLUDPAST .EQ. 1) CONDITION. - - - IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) THEN - - 8080 WRITE(*,8077) - 8077 FORMAT(/' FOR THE NPAG ANALYSIS WHICH WILL OBTAIN THE POSTERIOR'/ - 1' DENSITY (WHICH WILL THEN BE THE DENSITY FOR THE OPTIMIZATION)'/ - 2' SELECT THE MAXIMUM NO. OF CYCLES IT SHOULD RUN. THE DEFAULT'/ - 3' IS A MAXIMUM OF 500 CYCLES. '// - 4' SELECT 1 FOR 500 CYCLE;'/ - 5' SELECT 0 FOR A DIFFERERENT NO. OF MAXIMUM CYCLES: ') - READ(*,*,ERR=8080) MAXCYC - - - IF(MAXCYC .NE. 1 .AND. MAXCYC .NE. 0) GO TO 8080 - - - IF(MAXCYC .EQ. 1) MAXCYC = 500 - - IF(MAXCYC .EQ. 0) THEN - 8090 WRITE(*,8091) - 8091 FORMAT(/' ENTER A POSITIVE NO. FOR THE MAXIMUM NO. OF CYCLES'/ - 1' THE NPAG ANALYSIS SHOULD RUN: ') - READ(*,*,ERR=8090) MAXCYC - - IF(MAXCYC .LT. 1) GO TO 8090 - ENDIF - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(INCLUDPAST .EQ. 1 .AND. IPRIOROBS .EQ. 1) CONDITION. - - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION. - - - IF(ICSVFILE .EQ. 1) WRITE(*,4) FUTUREFILEIN - 4 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN COMES FROM THE'/ - 1' DATA OF THE FIRST SUBJECT IN THE .CSV FILE ', A20) - IF(ICSVFILE .EQ. 0) WRITE(*,6) FUTUREFILEIN - - 6 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN COMES FROM THE '/ - 1' (MULTIPLE DRUG) WORKING COPY PATIENT DATA FILE ', A20) - - IF(INCLUDPAST .EQ. 1) WRITE (*,14) PASTFILEIN,TNEXT - 14 FORMAT(/' SINCE YOUR ANALYSIS INCLUDES THE "PAST" HISTORY FOR'/ - 1' THE SUBJECT (IN FILE ',A20,'), IT WILL'/ - 2' BE ASSUMED THAT THE "PAST" BEGINS AT TIME = 0, AND THE'/ - 3' "FUTURE" BEGINS AT TIME = TNEXT. IN OTHER WORDS, THE "FUTURE"'/ - 4' FILE SHOULD START AS USUAL WITH TIME = 0, BUT ALL THE TIMES IN'/ - 5' THIS FILE WILL BE INCREASED BY TNEXT HOURS, AND THEN THIS FILE'/ - 6' WILL BE CONCATENATED TO THE "PAST" TO PROVIDE A COMPLETE'/ - 7' DOSING/OBSERVED VALUE PROFILE OF THE SUBJECT.'// - 8' TNEXT IS CURRENTLY SET TO BE ',G12.5) - - - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - - 5020 WRITE(*,5002) - 5002 FORMAT(/' THE FUTURE PATIENT INFO FOR THIS RUN CAN BE INPUT VIA'/ - 1' A (MULTIPLE DRUG) WORKING COPY PATIENT DATA FILE OR A BLOCK '/ - 2' MATRIX .CSV FILE (THE INFO WILL COME FROM THE DATA OF THE'/ - 3' FIRST SUBJECT IN THIS CASE).'// - 5' ENTER 1 TO ENTER INFO USING A .CSV FILE; '/ - 6' ENTER 0 TO ENTER INFO USING A WORKING COPY PATIENT DATA FILE: ') - READ(*,*,ERR=5020) ICSVFILE - IF(ICSVFILE .NE. 1 .AND. ICSVFILE .NE. 0) GO TO 5020 - - IF(ICSVFILE .EQ. 0) THEN - - WRITE(*,1021) - 1021 FORMAT(/' ENTER THE NAME OF THE WORKING COPY PATIENT DATA FILE.' - 1// - 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,102) FUTUREFILEIN - IF(FUTUREFILEIN(1:3) .EQ. '-99') - 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=6440,STATUS='OLD') - GO TO 6455 - 6440 WRITE(*,5316) PATHFILE - - 5316 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ - 1' ',A73) - GO TO 5020 - 6455 CONTINUE - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 0) CONDITION. - - - IF(ICSVFILE .EQ. 1) THEN - - WRITE(*,3021) -3021 FORMAT(/' ENTER THE NAME OF THE BLOCK MATRIX .CSV FILE. ONLY'/ - 1' THE DATA FROM THE FIRST SUBJECT IN THIS FILE WILL BE READ TO'/ - 2' OBTAIN THE DOSE/COVARIATE INFORMATION FOR THIS SUBJECT.'// - - 1' ENTER -99 TO SEE ALL OR A PART OF YOUR DIRECTORY: ') - READ(*,102) FUTUREFILEIN - IF(FUTUREFILEIN(1:3) .EQ. '-99') - 1 CALL SEEDIR(PATH,NOB,FUTUREFILEIN) - -C CHECK THAT THIS IS AN EXISTING FILE. - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = FUTUREFILEIN - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(87,FILE=PATHFILE,ERR=5440,STATUS='OLD') - - GO TO 5455 - 5440 WRITE(*,5316) PATHFILE - GO TO 5020 - 5455 CONTINUE - -C AS OF BESTDOS103A.FOR, BEFORE CALLING NEWCSV, MUST CALL CONVERTCSV, -C WHICH CONVERTS A "EUROPEAN" .CSV FILE TO THE TYPICAL "AMERICAN" -C VERSION. IF THE .CSV FILE IS ALREADY IN THE "AMERICAN" FORMAT, -C CONVERTCSV SIMPLY REWRITES FILE 87 TO SCRATCH FILE 77. NOTE THAT -C NEWCSV CONVERTS FILE 77 TO FILE 67. - - CALL CONVERTCSV - -C CALL SUBROUTINE NEWCSV WHICH CONVERTS THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THEN CALL CSVCHANGE WHICH CHANGES .csv FILES WITH CODE OF -C POPDATA DEC_11 (I.E., THOSE WITH 2 EXTRA COLUMNS FOR ADDL AND II) -C TO EQUIVALENT .csv FILES WITH CODE OF POPDATA APR_11 (THOSE WITHOUT - -C THE TWO EXTRA COLUMNS). CSVCHANGE READS FILE 67, AND WRITES THE -C INFORMATION TO SCRATCH FILE 66. NOTE THAT IF THE .csv FILE READ IN -C ALREADY IS THE OLDER VERSION (WITH CODE POPDATA APR_11), CSVCHANGE -C SIMPLY REWRITES IT TO FILE 66, WHICH IS THEN READ BY SUBROUTINE -C READBLOCK2. - - OPEN(67) - CALL NEWCSV - CALL CSVCHANGE - -C CREATE THE MULTIPLE DRUG WORKING COPY FILE XQZPJ001.FUT IN THE -C WORKING COPY DIRECTORY FROM THE DATA OF THE FIRST SUBJECT IN -C PATHFILE. NOTE THAT READBLOCK2 IS COPIED FROM MONT101.FOR. - - REWIND(66) - -C AS OF BESTDOS108, CHANGE ARGUMENTS BELOW FROM C0,...,C3 TO -C C0P,...,C3P (SEE REASON AT THE TOP OF BESTDOS108.FOR). - - CALL READBLOCK2(PATH,C0P,C1P,C2P,C3P,2,0) - CLOSE(66) - -C NOW OPEN THE JUST MADE WORKING COPY PATIENT DATA FILE. - - TMPFILE = ' ' - - - TMPFILE = 'XQZPJ001.FUT' - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - OPEN(21,FILE=PATHFILE,ERR=5465,STATUS='OLD') - GO TO 5470 - 5465 WRITE(*,5466) PATHFILE,FUTUREFILEIN - 5466 FORMAT(//' THE FOLLOWING FILE DOES NOT EXIST ... '/ - 1' ',A73/ - 2' WHICH MEANS THAT YOUR .CSV FILE, ',A20,' WAS NOT READ '/ - 3' PROPERLY. PLEASE CHECK THIS FILE TO MAKE SURE IT IS CORRECT.'//) - - GO TO 5020 - - 5470 CONTINUE - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICSVFILE .EQ. 1) CONDITION. - -C AT THIS POINT, FILE 21 CONTAINS THE WORKING COPY FILE TO BE USED -C FOR THIS RUN (VIA EITHER THE ICSVFILE .EQ. 0 OR THE ICSVFILE .EQ. 1 -C BLOCK). CALL GETNUMEQ WHICH WILL READ THIS FILE 21 AND OBTAIN -C NUMEQT AND NDRUG. - - - CALL GETNUMEQ(NUMEQT,NDRUG) - CLOSE(21) - -C IF INCLUDPAST = 0, IT MEANS THAT THE USER IS PROVIDING NO "PAST" -C HISTORY FOR THE SUBJECT. IN THIS CASE, SET TNEXT = 0.0. OTHERWISE, -C HAVE THE USER ENTER TNEXT. - - IF(INCLUDPAST .EQ. 0) TNEXT = 0.D0 - - IF(INCLUDPAST .EQ. 1) THEN - 9040 WRITE(*,8041) PASTFILEIN,FUTUREFILEIN - 8041 FORMAT(/' YOUR ANALYSIS INCLUDES THE "PAST" HISTORY FOR THE'/ - - 1' SUBJECT IN FILE ',A20,' AND THE "FUTURE" IN FILE ',A20/ - 2' IT WILL BE ASSUMED THAT THE "PAST" BEGINS AT TIME = 0, AND THE'/ - 3' "FUTURE" BEGINS AT TIME = TNEXT. IN OTHER WORDS, THE "FUTURE"'/ - 4' FILE SHOULD START AS USUAL WITH TIME = 0, BUT ALL THE TIMES IN'/ - 5' THIS FILE WILL BE INCREASED BY TNEXT HOURS, AND THEN THIS FILE'/ - 6' WILL BE CONCATENATED TO THE "PAST" TO PROVIDE A COMPLETE'/ - 7' DOSING/OBSERVED VALUE PROFILE OF THE SUBJECT.'// - 8' BUT NOTE THAT OPTIMUM DOSES WILL BE FOUND ONLY IN THE "FUTURE"'/ - 9' TO BEST ACHIEVE THE OBSERVED VALUES IN THE "FUTURE" ... BASED'/ - 1' ON THE "PAST" HISTORY. '// - 2' ENTER TNEXT, A POSTIVE NO. OF HOURS, NOW: ') - READ(*,*,ERR=9040) TNEXT - IF(TNEXT .LE. 0.D0) GO TO 9040 - ENDIF - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION FOR THE -C ICSVFILE VALUE. - - - WRITE(*,8174) IDELTA -8174 FORMAT(/' THE OUTPUT FILE WILL INCLUDE, FOR EACH GRID POINT IN '/ - 1' THE PARAMETER DENSITY (AND THE WEIGHTED MEAN OF THESE GRID'/ - 2' POINTS), SIMULATED OBSERVED VALUES, BASED ON THE OPTIMAL DOSES'/ - 3' WHICH THE PROGRAM CALCULATES.'// - 4' THESE SIMULATED VALUES WILL BE ',I6,' MINUTES APART.') - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - - 8170 WRITE(*,8172) - 8172 FORMAT(/' THE OUTPUT FILE WILL INCLUDE, FOR EACH GRID POINT IN '/ - 1' THE PARAMETER DENSITY (AND THE WEIGHTED MEAN OF THESE GRID'/ - 2' POINTS), SIMULATED OBSERVED VALUES, BASED ON THE OPTIMAL DOSES'/ - 3' WHICH THE PROGRAM CALCULATES.'// - 4' ENTER 1 IF THESE VALUES SHOULD BE SIMULATED EVERY 15 MINUTES'/ - 5' 0 FOR A DIFFERENT NO. OF MINUTES BETWEEN SIMULATED VALUES: - 6 ') - READ(*,*,ERR=8170) IDELTA - IF(IDELTA .NE. 1 .AND. IDELTA .NE. 0) GO TO 8170 - - IF(IDELTA .EQ. 1) IDELTA = 15 - - - IF(IDELTA .EQ. 0) THEN - WRITE(*,8173) - 8173 FORMAT(/' ENTER THE NO. OF MINUTES BETWEEN SIMULATED VALUES: ') - READ(*,*,ERR=8170) IDELTA - IF(IDELTA .LE. 0) GO TO 8170 - ENDIF - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION. - - - - IF(NOFIX .GT. 0) THEN - - WRITE(*,7) NOFIX - - 7 FORMAT(/' THE VALUES FOR THE ',I2,' FIXED PARAMETERS ARE: ') - DO I = 1,NOFIX - WRITE(*,8) PARFIX(I),VALFIX(I) - - 8 FORMAT(' ',A11,': ',G14.7) - END DO - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - WRITE(*,4836) - 4836 FORMAT(/' ENTER THE VALUE FOR EACH FIXED PARAMETER: ') - DO I = 1,NOFIX - 4845 WRITE(*,34) PARFIX(I) - 34 FORMAT(/' ',A11,' : ') - READ(*,*,ERR=4845) VALFIX(I) - - END DO - - ENDIF - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NOFIX .GT. 0) CONDITION. - - - WRITE(*,9) TOLER - - 9 FORMAT(/' THE TOLERANCES FOR THE O.D.E. SOLVER ARE SET EQUAL'/ - 1' TO ',G14.7) - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - - 915 WRITE(*,913) - 913 FORMAT(/' ENTER 1 TO SET ALL TOLERANCES (FOR THE O.D.E. '/ - 1' SOLVER) TO THE DEFAULT VALUE ... 1.D-4.'/ - 2' ENTER 0 TO SELECT A DIFFERENT VALUE FOR THE TOLERANCES: ') - READ(*,*,ERR=915) ITOL - IF(ITOL .NE. 0 .AND. ITOL .NE. 1) GO TO 915 - - TOLER = 1.D-4 - - - - IF(ITOL .EQ. 0) THEN - - 910 WRITE(*,914) - - 914 FORMAT(/' ENTER A POSITIVE VALUE FOR THE TOLERANCE PARAMETERS: ') - READ(*,*,ERR=910) TOLER - IF(TOLER .LE. 0.D0) GO TO 910 - - - ENDIF - -C RTOL = TOLER <-- RTOL NOT USED IN THIS ROUTINE. - DO I=1,NDIM - ATOL(I) = TOLER - END DO - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) FOR TOLER. - - - WRITE(*,2112) NPAGDENFILE - 2112 FORMAT(/' IN THE NPAG RUN YOU DID WHICH PRODUCED THE DENSITY'/ - 1' FILE, ',A20,' YOU MODELED THE ASSAY ERROR FUNCTION, S.D., AS'/ - 2' FOLLOWS (ASSUMING SD1 = C0+C1*Y+C2*Y**2+C3*Y**3):') - IF(IERRMOD .EQ. 1) WRITE(*,2113) - IF(IERRMOD .EQ. 2) WRITE(*,2114) GAMLAM - IF(IERRMOD .EQ. 3) WRITE(*,2116) GAMLAM - IF(IERRMOD .EQ. 4) WRITE(*,2117) GAMLAM - 2113 FORMAT(/' S.D. = SD1') - 2114 FORMAT(/' S.D. = GAMMA*SD1, WITH GAMMA TO BE ESTIMATED, AND'/ - 1' THE FINAL GAMMA ESTIMATE WAS ',G16.10) - 2116 FORMAT(/' S.D. = SQRT(SD1**2 + LAMBDA**2), WITH LAMBDA TO BE ES - 1TIMATED'/ - 2' AND THE FINAL LAMBDA ESTIMATE WAS ',G16.10) - 2117 FORMAT(/' S.D. = GAMMA, WITH GAMMA TO BE ESTIMATED, AND'/ - 1' THE FINAL GAMMA ESTIMATE WAS ',G16.10) - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - - - CALL SYSTEM('CLS') - - 1110 WRITE(*,118) NPAGDENFILE - 118 FORMAT(//' SELECT HOW YOU MODELED THE ASSAY ERROR FUNCTION IN '/ - 1' THE NPAG RUN YOU DID WHICH PRODUCED THE DENSITY FILE, ',A20// - 1' RECALL THAT SD1 = C0+C1*Y+C2*Y**2+C3*Y**3; THEN ...'// - 2' ENTER 1 IF S.D. = SD1;'/ - 3' ENTER 2 IF S.D. = GAMMA*SD1, WITH GAMMA TO BE ESTIMATED;'/ - 4' ENTER 3 IF S.D. = SQRT(SD1**2 + LAMBDA**2), WITH LAMBDA TO BE ES - 5TIMATED;'/ - 6' ENTER 4 IF S.D. = GAMMA, WITH GAMMA TO BE ESTIMATED: ') - READ(*,*,ERR=1110) IERRMOD - IF(IERRMOD .LT. 1 .OR. IERRMOD .GT. 4) GO TO 1110 - - IF(IERRMOD .GE. 2) THEN - ESTNAM = ' GAMMA' - - - IF(IERRMOD .EQ. 3) ESTNAM = 'LAMBDA' - - 225 WRITE(*,223) ESTNAM - 223 FORMAT(/' ENTER THE FINAL ESTIMATE FOR ',A6,' IN THE NPAG RUN: - 1 ') - READ(*,*,ERR=225) GAMLAM - IF(GAMLAM .LE. 0.D0) THEN - WRITE(*,1223) - 1223 FORMAT(/' THIS VALUE MUST BE POSITIVE. '/) - GO TO 225 - ENDIF - ENDIF - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) FOR IERRMOD/GAMLAM - - - WRITE(*,12) NUMEQT - 12 FORMAT(/' NOTE THAT THE GENERAL VALUES FOR [C0,C1,C2,C3] '/ - 1' FOR EACH OF THE ',I2,' OUTPUT EQUATION(S), ARE SHOWN BELOW: '/) - - DO IEQ = 1,NUMEQT - WRITE(*,162) IEQ,C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - IAS = IASS(IEQ) - IF(IAS .EQ. 1) WRITE(*,419) - IF(IAS .EQ. 0) WRITE(*,519) - - END DO - - 162 FORMAT(' EQ. ',I2,': ',4(G16.10,1X)) - - 419 FORMAT(/' THE PATIENT DATA FILE FOR THIS RUN WILL BE ASSIGNED'/ - 1' THE ASSAY COEFFICIENTS IN ITS DATA FILE; IF THERE ARE NO'/ - - 2' COEFFICIENTS IN THE DATA FILE, THE PATIENT WILL BE ASSIGNED'/ - 3' THE ABOVE GENERAL VALUES.'/) - - 519 FORMAT(/' THE PATIENT DATA FILE FOR THIS RUN WILL BE ASSIGNED'/ - - 1' THE ABOVE GENERAL ASSAY COEFFICIENTS (I.E., INDIVIDUAL ASSAY'/ - - 2' COEFFICIENTS ALREADY IN THE PATIENT DATA FILE WILL BE'/ - 3' OVERWRITTEN BY THE ABOVE VALUES.)'/) - - CALL CHANGE(ICHANG) - - IF(ICHANG .EQ. 0) THEN - - CALL SYSTEM('CLS') - - WRITE(*,119) - 119 FORMAT(//' FOR EACH OUTPUT EQUATION(S), SELECT ONE OF THE FOLLOWIN - 1G'/ - - 5' OPTIONS FOR THE ASSAY COEFFICIENTS [C0,C1,C2,C3]: '// - 4' ENTER 1 FOR THE DEFAULT OPTION ...'/ - 5' IF THE PATIENT DATA FILE ALREADY INCLUDES '/ - 6' ASSAY COEFFICIENTS, THOSE COEFFICIENTS WILL BE USED. '/ - 7' OTHERWISE THE COEFFICIENTS YOU ENTER BELOW WILL BE '/ - 8' USED;'/ - 7' ENTER 0 IF YOU WOULD LIKE THE ASSAY COEFFICIENTS TO BE THOSE'/ - 1' YOU ENTER BELOW (WHETHER OR NOT YOUR PATIENT FILE HAS'/ - 2' ASSAY COEFFICIENTS ALREADY: ') - - CALL PAUSE - -C FOR EACH OUTPUT, INPUT IASS AND [C0P,...,C3P]. - - DO 2200 IEQ = 1,NUMEQT - - - 1120 WRITE(*,221) IEQ - 221 FORMAT(/' FOR OUTPUT EQUATION ',I1,':'// - 4' ENTER 1 FOR THE DEFAULT OPTION;'// - 7' ENTER 0 TO BE PROMPTED FOR ASSAY COEFFICIENTS: ') - READ(*,*,ERR=1120) IAS - - IF(IAS .NE. 0 .AND. IAS .NE. 1) GO TO 1120 - IASS(IEQ) = IAS - - - WRITE(*,1119) IEQ - 1119 FORMAT(/' ENTER THE GENERAL VALUES FOR [C0,C1,C2,C3] FOR '/ - 1' OUTPUT EQUATION ',I1,'. THESE ') - IF(IAS .EQ. 1) WRITE(*,1121) - IF(IAS .EQ. 0) WRITE(*,1123) - - 1121 FORMAT(' WILL BE USED IF YOUR PATIENT DATA FILE DOES NOT'/ - 1' ALREADY INCLUDE ASSAY COEFFICIENTS: ') - 1123 FORMAT(' WILL BE USED EVEN IF YOUR PATIENT DATA FILE ALREADY'/ - 1' INCLUDES ASSAY COEFFICIENTS: ') - 4140 READ(*,*,ERR=4145) C0P(IEQ),C1P(IEQ),C2P(IEQ),C3P(IEQ) - - GO TO 2200 - 4145 WRITE(*,4146) - 4146 FORMAT(/' SEE ABOVE; PLEASE ENTER FOUR REAL NUMBERS: ') - GO TO 4140 - - 2200 CONTINUE - - - WRITE(*,2119) - 2119 FORMAT(//' NOTE: DURING THIS PROGRAM, THE PATIENT DATA FILE'/ - 1' WILL HAVE ITS COEFFICIENTS WRITTEN TO THE END OF THE '/ - 2' WORKING COPY FILE. IF COEFFICIENTS ARE ALREADY THERE'/ - 3' FROM A PREVIOUS RUN, THEY WILL BE OVERWRITTEN.'//) - CALL PAUSE - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICHANG .EQ. 0) CONDITION FOR THE -C ASSAY COEFFICIENTS. - -4150 WRITE(*,112) NDRUG - 112 FORMAT(/' THE ACTIVE (SALT) FRACTION OF EACH OF THE ',I1,' DRUG( - 1S) FOLLOWS.') - - DO I = 1,NDRUG - WRITE(*,113) I,AF(I) - 113 FORMAT(' AF FOR DRUG ',I1,' IS ',G12.6) - END DO - - - CALL CHANGE(ICHANG) - IF(ICHANG .EQ. 0) THEN - - -5150 WRITE(*,129) - 129 FORMAT(//' ENTER THE ACTIVE (SALT) FRACTION OF EACH DRUG. AS '/ - 1' AN EXAMPLE, THE A.F. OF THEOPHYLLINE IS 1.0, WHILE THAT OF'/ - 2' AMINOPHYLLINE IS TYPICALLY BETWEEN .79 AND .85, DEPENDING ON'/ - 3' THE PREPARATION. '// - 4' EACH AF MUST BE A POSITIVE NUMBER LESS THAN OR EQUAL TO 1.0.'/) - - DO I = 1,NDRUG - WRITE(*,1129) I - 1129 FORMAT(' AF FOR DRUG ',I1,': ') - READ(*,*,ERR=5150) AF(I) - IF(AF(I) .LE. 0.0 .OR. AF(I) .GT. 1.0) GO TO 5150 - END DO - - ENDIF - - IF(IOPTIMIZE .EQ. 1) WRITE(*,2129) - 2129 FORMAT(/' THE DOSES SHOWN IN THE "FUTURE" FILE WILL BE THE'/ - 1' INITIAL GUESSES USED TO FIND THE OPTIMUM DOSES TO HIT THE'/ - 2' TARGET CONCENTRATIONS IN THE "FUTURE" FILE. ALL SUBSEQUENT'/ - 3' CALCULATIONS WILL BE BASED ON THE OPTIMUM DOSES.') - - IF(IOPTIMIZE .EQ. 0) WRITE(*,2131) - 2131 FORMAT(/' THE DOSES SHOWS IN THE "FUTURE" FILE WILL BE THOSE'/ - 1' USED FOR ALL SUBSEQUENT CALCULATIONS (I.E.,NO OPTIMIZATION OF'/ - 2' DOSES WILL BE DONE).') - - CALL CHANGE(ICHANG) - IF(ICHANG .EQ. 0) THEN - - 3130 WRITE(*,3129) - 3129 FORMAT(/' ENTER 1 IF YOU WANT TO FIND THE OPTIMUM DOSES TO HIT'/ - 1' THE TARGET CONCENTRATIONS IN THE "FUTURE" FILE.'/ - 4' ENTER 0 IF, INSTEAD, YOU WANT THE OUTPUT FILE TO SHOW '/ - 5' PREDICTED CONCENTRATIONS AND AUCs FOR THE DOSES IN '/ - 6' THE "FUTURE" FILE (I.E., NO OPTIMIZATION WILL BE DONE'/ - 7' IN THIS CASE): ') - READ(*,*,ERR=3130) IOPTIMIZE - IF(IOPTIMIZE .NE. 1 .AND. IOPTIMIZE .NE. 0) GO TO 3130 - - ENDIF - - -C IF IOPTIMIZE = 0, NO OPTIMIZATION IS TO BE DONE, WHICH RENDERS THE -C QUESTION ABOUT BIASWEIGHT BELOW MOOT. IN THIS CASE, SIMPLY SET -C BIASWEIGHT = 0. - -C BUT IF IOPTIMIZE = 1, THEN REPORT THE CURRENT VALUE OF BIASWEIGHT AND -C SEE IF THE USER WANTS TO CHANGE IT (I.E., ASK THE THE USER ABOUT -C HOW THE COST FUNCTION (WHICH ESTABLISHES THE BEST DOSES) SHOULD BE -C CALCULATED). - - - - IF(IOPTIMIZE .EQ. 0) THEN - BIASWEIGHT = 0.D0 - ENDIF - - IF(IOPTIMIZE .EQ. 1) THEN - - WRITE(*,3151) BIASWEIGHT - 3151 FORMAT(/' THE COST FUNCTION TO BE MINIMIZED IN FINDING THE'/ - 1' "BEST" DOSES IS (1 - BIASWEIGHT)*V(U) + BIASWEIGHT*B(U), WHERE'/ - 2' V(U) IS THE MEAN SQUARED ERROR ASSOCIATED WITH ALL THE '/ - 3' GRID PTS. IN THE PARAMETER DENSITY; AND B(U) IS THE MEAN '/ - 4' SQUARED ERROR DUE TO BIAS ABOUT THE MEAN RESPONSE.'// - 5' THE VALUE OF BIASWEIGHT IS ',G12.6) - - - CALL CHANGE(ICHANG) - IF(ICHANG .EQ. 0) THEN - - 3140 WRITE(*,3139) - 3139 FORMAT(/' ENTER THE VALUE FOR BIASWEIGHT BETWEEN 0 AND 1, INCLUS - 1IVE:') - READ(*,*,ERR=3140) BIASWEIGHT - IF(BIASWEIGHT .LT. 0.D0 .OR. BIASWEIGHT .GT. 1.D0) GO TO 3140 - ENDIF - - - ENDIF -C THE ABOVE ENDIF IS FOR THE IF(IOPTIMIZE .EQ. 1) CONDITION. - - - IF(ITARGET .EQ. 1) WRITE(*,3252) - 3252 FORMAT(/' THE OBSERVED VALUES IN THE FUTURE PATIENT FILE ARE'/ - 1' TARGET CONCENTRATIONS.') - IF(ITARGET .EQ. 2) WRITE(*,3253) - 3253 FORMAT(/' THE OBSERVED VALUES IN THE FUTURE PATIENT FILE ARE'/ - 1' TARGET AUCs.') - - CALL CHANGE(ICHANG) - IF(ICHANG .EQ. 0) THEN - - 3150 WRITE(*,3149) - 3149 FORMAT(/' ENTER 1 IF THE OBSERVED VALUES IN THE FUTURE PATIENT'/ - 1' FILE ARE TARGET CONCENTRATIONS; '/ - 2' ENTER 2 IF THE OBSERVED VALUES ARE TARGET AUCs: ') - READ(*,*,ERR=3150) ITARGET - IF(ITARGET .NE. 1 .AND. ITARGET .NE. 2) GO TO 3150 - - ENDIF - - - - 7005 WRITE(*,7001) - 7001 FORMAT(///' ENTER 1 IF ALL INSTRUCTIONS ARE NOW CORRECT;'/ - 2' ENTER 0 OTHERWISE: ') - READ(*,*,ERR=7005) ICHANG - IF(ICHANG .NE. 0 .AND. ICHANG .NE. 1) GO TO 7005 - IF(ICHANG .EQ. 0) GO TO 8040 - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE CHANGE(ICHANG) -C -C THIS SUBROUTINE IS CALLED BY SUBROUTINE VERIF1 TO HAVE THE USER CHECK -C WHETHER HIS INPUT INFO IS CORRECT OR NEEDS TO BE CHANGED. -C -C INPUT: NOTHING -C -C OUTPUT: -C -C ICHANG = 1 IF INFO PRINTED PREVIOUSLY TO THE SCREEN IS CORRECT. -C = 0 IF INFO PRINTED PREVIOUSLY TO THE SCREEN SHOULD BE -C CHANGED. -C - 10 WRITE(*,1) - 1 FORMAT(//' ENTER 1 IF THE ABOVE INFORMATION IS CORRECT;'/ - 1' ENTER 0 IF IT SHOULD BE CHANGED: ') - READ(*,*,ERR=10) ICHANG - IF(ICHANG .NE. 0 .AND. ICHANG .NE. 1) GO TO 10 - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE READBLOCK2(PATH,C0,C1,C2,C3,IWHICH,IGUI) - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - -C THIS ROUTINE IS BASED ON SUBROUTINE READBLOCK IN NPBG15E1.FOR, BUT -C INSTEAD OF CREATING A WORKING COPY PATIENT DATA FILE FOR EACH BLOCK -C OF DATA IN THE .CSV FILE ALREADY OPENED AS FILE 66 IN MAIN, IT ONLY -C CREATES ONE MULTIPLE DRUG WORKING COPY PATIENT DATA FILE, -C 'XQZPJ001.PST' IF IWHICH = 1, AND 'XQZPJ001.FUT' IF IWHICH = 2, - -C FROM THE FIRST SUBJECT'S DATA. SO MAXSUB WILL BE -C HARDCODED = 1 BELOW, AND ALL DIMENSIONS WHICH WERE MAXSUB IN -C NPBG15E1.FOR/READBLOCK WILL NOW BE 1. - - - - DIMENSION TIMOUT(1,MAXNUMEQ,650),TIMIV(1,7,5200), - 1 NTIMOUT(1,MAXNUMEQ),NTIMIV(1,7),RATEIV(1,7,5200),BOLUS(1,7,5200), - 2 OUT(1,MAXNUMEQ,650),COV(1,26,5200),ICOVTYPE(26), - 5 TIMBOL(1,7,5200),NTIMBOL(1,7),NTIMCOV(1,26), - 6 TIMCOV(1,26,5200),TIMALL(1,72000),NTIMALL(1), - 7 TIMI(72000),C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ), - 8 C3(MAXNUMEQ),CSUB(1,4,MAXNUMEQ),NSST(1),DOSELINEST(1,99,100) - - CHARACTER READLINE*1000,COVNAME(26)*11,NUMBER(1)*3, - 1 PATFIL*20,CHARSUB*3,SUBID*11,SUBIDPREV*11,SUBARRAY(1)*11, - 3 PATH*60,TMPFILE*13,PATHFILE*73,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - - 1 FORMAT(A1000) - -C SET MAXSUB = 1 SINCE ONLY 1 SUBJECT WILL BE CREATED BY THIS ROUTINE. - - MAXSUB = 1 - - -C INITIALIZE NDRUG (THE NO. OF DRUGS IN THE PATIENT DATA SET) TO BE -C 0. EVERY TIME IDRUGNO IS READ BELOW, NDRUG WILL BE SET = -C MAX(NDRUG,IDRUGNO). - -C SIMILARLY, INITIALIZE NOUT (THE NO. OF OUTPUT EQUATIONS IN THE -C PATIENT DATA SET) TO BE 0. EVERY TIME IOUTEQ IS READ BELOW, -C NOUT WILL BE SET = MAX(NOUT,IOUTEQ). - - NDRUG = 0 - NOUT = 0 - -C INITIALIZE NSST(.) TO 0. IT GIVES THE NO. OF STEADY STATE DOSE -C LINES THAT WILL BE WRITTEN TO THE DOSAGE BLOCK FOR THE SUBJECT. - - DO ISUB = 1,MAXSUB - NSST(ISUB) = 0 - END DO - - -C NOTE THAT ANY LINE STARTING WITH A # WILL BE IGNORED. THE FIRST LINE -C WILL ALSO BE IGNORED - IT HAS ALREADY BEEN VERIFIED TO HAVE THE -C REQUIRED CODE IN IT. - - - READ(66,*) - -C READ THE 2ND LINE, WHICH MUST HAVE A # AS THE FIRST CHARACTER. IT HAS -C THE NAMES OF THE COLUMNS. COUNT THE NO. OF COMMAS ON THE LINE. THE -C NO. OF COVARIATES WILL BE THE NO. OF COMMAS - 11 (SINCE THERE ARE 12 -C FIXED ENTRIES WHICH POTENTIALLY SHOW UP ON EACH LINE: PATIENT ID, -C EVENT ID, TIME, INFUSION DURATION, TOTAL DOSE, INPUT DRUG NO., -C OUTPUT VALUE, OUTPUT EQ., AND 4 SPOTS FOR ASSAY COEFFICIENTS WHICH -C ONLY SHOW UP ON OUTPUT LINES). NOTE THAT THIS VALUE WILL BE CALLED -C NCOVA, WHICH MEANS NO. OF ADDITION COVARIATES (IN ADDITION TO THE 4 -C PERMANENT ONES AT THE TOP OF EACH PATIENT'S WORKING COPY FILE (AGE, -C SEX, HEIGHT, ETHNICITY FLAG), ... TO BE CONSISTENT WITH THE NAME -C USED IN NPAG100.FOR. - - READ(66,1) READLINE - - NCOMMA = 0 - - DO ISTART = 1,1000 - - IF(READLINE(ISTART:ISTART) .EQ. ',') THEN - NCOMMA = NCOMMA + 1 - ENDIF - - END DO - - NCOVA = NCOMMA - 11 - - IF(NCOVA .GT. 0) THEN - -C READ THE NAMES OF THE NCOVA COVARIATES FROM THE LINE STARTING WITH -C #ID OR "#ID. - -C NOTE THAT AFTERCOMMA OPENS AND PUTS INTO FILE 57 THE PART OF READLINE - -C WHICH IS BETWEEN COMMA C AND COMMA C+1, WHERE C IS THE 3RD ARGUMENT. -C ALSO,NOTE THAT NCOVA MUST BE PROVIDED TO AFTERCOMMA SO IT WILL KNOW -C THE TOTAL NO. OF COMMAS IN READLINE (WHICH = 11 + NCOVA). - - - REWIND(66) - 120 READ(66,1) READLINE - IF(READLINE(1:3) .NE. '#ID' .AND. READLINE(1:4).NE. '"#ID' - - 1 .AND. READLINE(1:3) .NE. '#id' .AND. READLINE(1:4).NE. '"#id') - 2 GO TO 120 - - - DO ICOV = 1,NCOVA - CALL AFTERCOMMA(NCOVA,READLINE,11+ICOV) - BACKSPACE(57) - READ(57,2) COVNAME(ICOV) - 2 FORMAT(A11) - CLOSE(57) - END DO - - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE IF(NCOVA .GT. 0) CONDITION. - - - -C CALL SUBROUTINE GETMAXTIM TO GET THE MAXIMUM TIME OVER ALL THE -C SUBJECTS IN FILE 66. THIS INCLUDES THE ENDING TIME OVER ALL IV -C EVENTS. THEN SET TIMADD = THIS TIME + 1. FOR EACH SUBJECT BELOW, -C EACH TIME WILL HAVE TIMADD*NRESET ADDED TO IT, WHERE NRESET IS THE -C NO. OF TIME RESETS (FOR THAT SUBJECT) UP TO AND INCLUDING THAT TIME. -C THIS WILL MAKE EACH TIME A UNIQUE TIME (I.E., WITH TIME RESETS IN -C THE BLOCK FORMAT FILE, THERE COULD BE MANY TIMES WITH THE SAME -C VALUE). - - - CALL GETMAXTIM(NCOVA,TIMAX) - -C VERIFY THAT TIMAX WAS CALCULATED CORRECTLY - I.E., THAT IT IS NOT -C STILL THE INITIALIZED NEGATIVE VALUE IN GETMAXTIM. - - IF(TIMAX .LT. 0) THEN - - - - - WRITE(*,11) - 11 FORMAT(/' THERE IS SOMETHING WRONG WITH YOUR BLOCK FORMAT'/ - 1' FILE. THE TIMES IN COLUMN 3 AND/OR THE TIME DURATIONS'/ - 2' IN COLUMN 4 ARE BAD. PLEASE CHECK YOUR VALUES. '// - 3' THE PROGRAM STOPS.') - - - OPEN(47,FILE=ERRFIL) - WRITE(47,11) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - TIMADD = TIMAX + 1.D0 - - -C REWIND FILE 66, READ PAST THE FIRST LINE WHICH HAS THE CODE, AND -C THE SECOND LINE, WHICH HAS THE COVARIATE INFORMATION ON IT, AND -C THEN READ ALL LINES, EXCEPT THOSE THAT START WITH # OR "#. -C GO THROUGH EACH SUCCEEDING LINE IN FILE 66 AND EXTRACT ALL THE -C INFORMATION. NOTE THAT EACH LINE CAN CONTAIN OUTPUT INFO OR DOSAGE -C INFO (INCLUDING COVARIATE VALUES), DEPENDING ON THE VALUE FOR IDEVENT -C (THE 2ND ENTRY IN EACH LINE), BUT NOT BOTH. IN PARTICULAR, IF -C IDEVENT = 0 --> THE ROW HAS OUTPUT EQUATION INFO. -C IDEVENT = 1 --> THE ROW HAS DOSAGE/COVARIATE INFO. -C IDEVENT = 4 --> SAME AS IDEVENT = 1, EXCEPT THIS ROW REPRESENTS A -C TIME RESET. - - REWIND(66) - READ(66,1) - READ(66,1) - -C INITIALIZE SUBIDPREV (THE PREVIOUS SUBJECT ID) TO BE '%^&*' SO THE - -C FIRST SUJBECT ID READ IN BELOW WILL BE DIFFERENT THAN THIS, AND SO -C START THE SUBJECT ID LOGIC. ALSO, INITIALIZE THE SUBJECT NO. TO 0. - - SUBIDPREV = '%^&*' - NSUB = 0 - -C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED. - - 10 READ(66,1,IOSTAT=IEND) READLINE - IF(IEND .LT. 0) GO TO 100 - IF(READLINE(1:1) .EQ. '#' .OR. READLINE(1:2) .EQ. '"#') GO TO 10 - -C THE FIRST VALUE (I.E., AFTER COMMA NO. 0) IS THE SUBJECT ID. - - CALL AFTERCOMMA(NCOVA,READLINE,0) - BACKSPACE(57) - READ(57,2) SUBID - CLOSE(57) - - -C NOTE THAT SUBID CONTAINS THE 1ST 11 CHARACTERS OF THE LINE, BUT THE -C SUBJECT ID IS JUST THE SET OF CHARACTERS PRIOR TO THE 1ST COMMA. -C CALL SUBROUTINE GETID TO CORRECT THE VALUE OF SUBID. - - CALL GETID(SUBID) - -C IF SUBID = SUBIDPREV, THIS IS ANOTHER LINE FOR THE CURRENT SUBJECT. -C IF SUBID .NE. SUBIDPREV, THIS IS THE 1ST EVENT FOR A NEW SUBJECT, SO -C INCREASE NSUB, AND SET THE NO. OF INFUSIONS (FOR EACH DRUG), BOLI, -C OBSERVATION, AND COVARIATE TIMES FOR THIS SUBJECT TO 0 (THEY WILL -C BE UPDATED BELOW AS REQUIRED). SIMILARY SET THE TOTAL NO. OF DOSE -C EVENTS = 0. - -C ALSO, SINCE THIS IS A NEW SUBJECT, DEFAULT THE ASSAY COEFFICIENTS FOR -C OUTPUT EQ. IEQ TO [C0(IEQ),C1(IEQ),C2(IEQ),C3(IEQ)], -C IEQ = 1,MAXNUMEQ (MAXNUMEQ IS THE MAXIMUM THAT NUMEQT CAN BE). THEN, -C AS THIS SUBJECT'S INFO IS BEING READ BELOW, ANY ASSAY C'S SPECIFIED -C FOR THIS SUBJECT WILL OVERWRITE THE DEFAULT VALUES. AND NOTE THAT IF -C A SUBJECT HAS MORE THAN ONE SET OF ASSAY C'S FOR A GIVEN OUTPUT EQ., -C THE LAST SET WILL BE USED. - -C NOTE THAT AFTER READBLOCK2 HAS FINISHED READING THE PATIENT INFO, -C CSUB(I,J,K), J=1,4 WILL BE ASSAY C'S [C0 C1 C2 C3] FOR SUBJECT I -C AND OUTPUT EQ. K. - - - IF(SUBID .NE. SUBIDPREV) THEN - - SUBIDPREV = SUBID - - NSUB = NSUB + 1 - -C FASTFORWARD THE LOGIC TO THE END OF THE ROUTINE IF NSUB = 2, SINCE -C THE INFO FOR THE FIRST SUBJECT WILL ALREADY HAVE BEEN READ IN. AND -C RESET NSUB = 1 AT THAT POINT SINCE ONLY THE FIRST SUBJECT'S DATA WILL -C BE NEEDED. - - IF(NSUB .EQ. 2) GO TO 100 - - - SUBARRAY(NSUB) = SUBID - - NTIMALL(NSUB) = 0 - - DO K = 1,7 - NTIMIV(NSUB,K) = 0 - NTIMBOL(NSUB,K) = 0 - END DO - - DO K = 1,26 - NTIMCOV(NSUB,K) = 0 - END DO - - DO K = 1,MAXNUMEQ - NTIMOUT(NSUB,K) = 0 - CSUB(NSUB,1,K) = C0(K) - CSUB(NSUB,2,K) = C1(K) - CSUB(NSUB,3,K) = C2(K) - CSUB(NSUB,4,K) = C3(K) - END DO - - -C SEE LOGIC BELOW. IF THIS ROW REPRESENTS A TIME RESET, THEN AN -C EXTRA VALUE (-99) AT AN EXTRA TIME (0) WILL BE ADDED TO EACH OUTPUT -C EQUATION ARRAY. BUT THIS NEEDS TO BE DONE JUST ONCE FOR EACH TIME -C RESET, NOT FOR EACH DOSAGE LINE THAT HAS A RESET. I.E., IF THERE -C ARE 5 DRUGS, THEN THERE COULD BE AS MANY AS 5 DOSE LINES WITH A -C RESET VALUE. ALSO, WITHIN EACH LINE, A DOSE AND/OR A COVARIATE - -C COULD HAVE A RESET TIME OF 0. THEREFORE EACH BLOCK OF CODE BELOW, -C FOR EACH DRUG NO. AND EACH COVARIATE, IS TESTED FOR A TIME RESET, -C AND IN EACH CASE, EXTRA LINES ARE POTENTIALLY ADDED TO THE OUPUT -C ARRAYS. TO PREVENT MORE EXTRA LINES (OF OUTPUT VALUES = -99 AT -C TIMES = 0) THAN ARE NECESSARY, INITIALIZE NRESETADD = 0. THIS -C TELLS THE PROGRAM THAT NO EXTRA LINES HAVE BEEN ADDED TO THE OUTPUT -C ARRAYS SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE -C ARRAYS. NRESETADD WILL BE CHANGED TO 1 WHENEVER EXTRA LINES HAVE -C BEEN ADDED TO THE OUTPUT ARRAYS, AND THEN BACK TO 0 WHENEVER ANOTHER -C ACTUAL OUTPUT VALUE HAS BEEN PUT INTO AN ARRAY. - - NRESETADD = 0 - -C INITIALIZE NRESET TO 0. IT WILL BE THE NO. OF TIME RESETS THAT -C HAVE OCCURRED UP TO ANY TIME. ALSO INITIALIZE TIMERESET = 0; THIS -C WILL BE THE RUNNING TIME TO BE ADDED TO EACH ACTUAL TIME. IT WILL -C ALWAYS BE SET = TIMADD*NRESET BELOW. - - - NRESET = 0 - TIMERESET = TIMADD*NRESET - -C ALSO INITIALIZE NRESETLAST = -1 (SEE CODE BELOW). - - NRESETLAST = -1 - DOSELINEST(NSUB,1,100) = -99 - -C DOSELINE(NSUB,1,100) IS INITIALIZED TO BE -99. IF IT CHANGES BELOW -C TO BE .GE. 0, IT MEANS THAT THERE IS AT LEAST ONE STEADY STATE DOSE -C SET, AND THE FIRST ONE OCCURS AT THE VALUE OF NRESET = -C DOSELINEST(NSUB,1,100). - - -C VERIFY THAT THE 2ND VALUE (I.E., AFTER COMMA NO. 1), WHICH IS THE -C EVENT ID, IDEVENT, IS 1 SINCE THE FIRST EVENT FOR EACH SUBJECT -C SHOULD BE 1 (A NON-TIME-RESET DOSE EVENT). - - CALL AFTERCOMMA(NCOVA,READLINE,1) - BACKSPACE(57) - READ(57,*) IDEVENT - CLOSE(57) - - IF(IDEVENT .NE. 1) THEN - - - - WRITE(*,402) SUBARRAY(NSUB),IDEVENT - 402 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ - 1 1X,A11,', THE FIRST EVENT ID IS NOT 1 AS REQUIRED. IT IS ',I3/ - 3' THE PROGRAM STOPS.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,402) SUBARRAY(NSUB),IDEVENT - CLOSE(47) - - - - - CALL PAUSE - STOP - - - - ENDIF - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SUBID .NE. SUBIDPREV) CONDITION. - - -C THE 2ND VALUE (I.E., AFTER COMMA NO. 1) IS THE EVENT ID, IDEVENT -C (SEE ABOVE). - - CALL AFTERCOMMA(NCOVA,READLINE,1) - BACKSPACE(57) - READ(57,*) IDEVENT - CLOSE(57) - -C IF THE ID OF THIS EVENT IS NO. 4, IT IS A TIME RESET EVENT. IN THIS -C CASE, INCREASE NRESET AND TIMERESET AS INDICATED ABOVE. - - - IF(IDEVENT .EQ. 4) THEN - -C AS OF BESTDOS119.FOR, STOP THE PROGRAM IF THE PATIENT DATA FILE -C HAS AN IDEVENT OF 4. - - WRITE(*,502) - 502 FORMAT(/' YOUR PATIENT DATA FILE HAS AN EVENT OF 4, WHICH '/ - 1' INDICATES A DOSE RESET. DOSE RESETS ARE NOT ALLOWED. THE '/ - 2' PROGRAM STOPS. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,502) - CLOSE(47) - - CALL PAUSE - STOP - - NRESET = NRESET + 1 - TIMERESET = TIMADD*NRESET - ENDIF - - -C THE 3RD VALUE (I.E., AFTER COMMA NO. 2) IS THE TIME OF THE EVENT. -C READ THIS VALUE NOW. - - - CALL AFTERCOMMA(NCOVA,READLINE,2) - BACKSPACE(57) - READ(57,*) TIMEVENT - CLOSE(57) - - - IF(TIMEVENT .LT. 0.D0) THEN - - -C STORE INTO DOSELINEST(.,.,.) ALL THE INFO FOR THE WORKING COPY FILE -C FOR THIS STEADY STATE DOSE SET. - - -C COMPARE NRESET WITH THE PREVIOUS VALUE OF NRESET WHEN THIS PART OF - -C THE CODE WAS USED: IF THEY ARE THE SAME, THIS LINE WILL PROVIDES -C MORE INFO (FOR A DIFFERENT DRUG NO.) FOR THE SAME STEADY STATE DOSE -C EVENT TO BE PUT INTO THE WORKING COPY FILE. IF THEY ARE DIFFERENT, -C THIS LINE IS THE FIRST LINE OF A NEW STEADY STATE DOSE SET. - - - IF(NRESET .GT. NRESETLAST) THEN - -C PUT IN NEW INFO FOR A NEW LINE (FOR A NEW STEADY STATE DOSE SET). -C THIS LINE IS THE FIRST LINE WITH INFO ON A NEW STEADY STATE DOSE SET. -C STORE ALL THE INFO FROM THIS LINE, INCLUDING NRESET, SO SUBROUTINE -C WRITEDOS CAN WRITE THE INFO FOR THIS LINE SEPARATELY. NOTE THAT THIS -C LINE WILL NOT BE A PART OF THE LOGIC BELOW WHICH STORES ALL DOSE -C INFO, AND THEN SORTS IT BY TIME. NOTE THAT NRESET IS STORED INTO -C ENTRY 100 FOR THIS LINE. - - NSST(NSUB) = NSST(NSUB) + 1 - - IF(NSST(NSUB) .GT. 99) THEN - - - WRITE(*,172) NSUB - 172 FORMAT(/' FOR SUBJECT NO. ',I5,' THE NO. OF STEADY STATE DOSE'/ - 1' SETS IS MORE THAN 99, THE MAXIMUM ALLOWED. PLEASE RERUN THE'/ - 2' PROGRAM AFTER REDUCING THE NO. OF STEADY STATE DOSE SETS TO'/ - 3' NO MORE THAN 99.'// - 4' THE PROGRAM STOPS.'/) - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,172) NSUB - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - DOSELINEST(NSUB,NSST(NSUB),100) = NRESET - - -C TIMEVENT IS THE NEGATIVE OF THE INTERDOSE INTERVAL, WHICH WILL SHOW -C UP IN THE TIME COLUMN OF THE WORKING COPY FILE. - - DOSELINEST(NSUB,NSST(NSUB),1) = TIMEVENT - -C ZERO OUT ALL THE IV AND BOLUS ENTRIES FOR ALL POSSIBLE DRUGS -C (I.E., THERE COULD BE AS MANY AS 7 DRUGS). - - DO I = 1,7 - - DOSELINEST(NSUB,NSST(NSUB),2*I) = 0.D0 - DOSELINEST(NSUB,NSST(NSUB),2*I+1) = 0.D0 - END DO - - -C STORE ANY COVARIATE INFO INTO THE COVARIATE ENTRIES. NOTE IT IS NOT -C KNOWN AT THIS POINT HOW MANY TOTAL DRUGS ARE USED IN THE MODEL SINCE -C THE VALUE FOR NDRUG HAS NOT YET FINISHED UPDATING (IN THE CODE BELOW, -C IT IS SET = IDRUGNO IF NDRUG .LT. IDRUGNO). SO, THE COVARIATE VALUES -C WILL BE STORED FAR ENOUGH OUT IN THE DOSELINEST(.,.,.) ARRAY TO NOT -C INTERFERE WITH THE ENTRIES FOR THE MAXIMUM NO. OF POSSIBLE DRUGS. -C SINCE THERE ARE AT MOST 7 POSSIBLE DRUGS, ENTRIES 2,3,...,14,15 WILL -C BE RESERVED FOR THESE DRUG VALUES, AND THE COVARIATE VALUES WILL -C START WITH ENTRY NO. 20. - - - IF(NCOVA .GT. 0) THEN - - DO 110 ICOV = 1,NCOVA - CALL AFTERCOMMA(NCOVA,READLINE,11+ICOV) - BACKSPACE(57) - READ(57,*,ERR=95) COVVAL - CLOSE(57) - DOSELINEST(NSUB,NSST(NSUB),19+ICOV) = COVVAL - - GO TO 110 - 95 DOSELINEST(NSUB,NSST(NSUB),19+ICOV) = -99.D0 - 110 CONTINUE - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE IF(NCOVA .GT. 0) CONDITION. - - -C FOR BESTDOS103A.FOR, ADD LOGIC FOR EXTRA OBS. LINE WITH VALUES OF -C -99'S. - -C THIS IS EITHER A TIME RESET EVENT, OR THE TOP OF THE PATIENT'S FILE. - -C IF IT IS THE TOP OF THE PATIENT'S FILE, NRESET WILL = 0. IF IT IS A - -C TIME RESET EVENT, NRESET WILL BE > 0, AND IN THIS CASE, MUST STORE -C VALUES INTO THE OUPUT ARRAYS (SEE LOGIC BELOW) WHICH INDICATE THAT -C SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. - - - IF(NRESET .GT. 0) THEN - DO IOUTEQ = 1,MAXNUMEQ - NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 - TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMERESET - OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 - END DO - ENDIF - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NRESET .GT. NRESETLAST) CONDITION. - - -C ESTABLISH THE DURATION, (4TH VALUE, AFTER THE 3RD COMMA), DOSE (5TH -C VALUE, AFTER THE 4TH COMMA), AND DRUG NO. (6TH VALUE, AFTER THE 5TH -C COMMA) FOR THIS LINE. - - CALL AFTERCOMMA(NCOVA,READLINE,3) - - - BACKSPACE(57) - READ(57,*,ERR=170) DUR - - - CLOSE(57) - - CALL AFTERCOMMA(NCOVA,READLINE,4) - BACKSPACE(57) - READ(57,*,ERR=170) TOTDOS - CLOSE(57) - - CALL AFTERCOMMA(NCOVA,READLINE,5) - BACKSPACE(57) - READ(57,*,ERR=170) IDRUGNO - CLOSE(57) - -C STORE THE IV RATE INTO THE IV ENTRY FOR DRUG NO. IDRUGNO; SIMILARLY, -C STORE THE TOTAL DOSE INTO THE BOLUS ENTRY FOR DRUG NO. IDRUGNO. -C NOTE THAT IF DUR = 0, THIS LINE REPRESENTS A STEADY STATE OF BOLUS -C VALUES. IN THIS CASE, SET THE IV RATE TO 0. - - - IF(DUR .LE. 0.D0) - 1 DOSELINEST(NSUB,NSST(NSUB),2*IDRUGNO) = 0.D0 - IF(DUR .GT. 0.D0) - 1 DOSELINEST(NSUB,NSST(NSUB),2*IDRUGNO) = TOTDOS/DUR - DOSELINEST(NSUB,NSST(NSUB),2*IDRUGNO+1) = TOTDOS - - - -C NOTE THAT COVARIATE VALUES ARE ONLY READ FOR THE FIRST DOSE LINE -C IN A STEADY STATE SET (I.E., WHEN NRESET .GT. NRESETLAST). IT IS -C POSSIBLE THAT THE USER'S .csv FILE HAS A DIFFERENT SET OF COV. VALUES -C FOR EACH LINE (FOR A DIFFERENT DRUG) THAT IS INCLUDED IN THE -C CURRENT STEADY STATE DOSE SET. BUT, THIS WOULD BE A MISTAKE SINCE -C ONLY 1 SET OF COV. VALUES CAN BE USED FOR THE STEADY STATE SET. THE -C FIRST SET OF VALUES WILL BE USED (AND ALL OTHERS WILL BE IGNORED). - -C SET NRESETLAST = NRESET SO IF ANOTHER LINE OF DOSE INFO FOR THE -C CURRENT STEADY STATE SET FOLLOWS, THE PROGRAM WILL KNOW IT IS -C MORE INFO ON THE CURRENT SET, AND NOT NEW INFO ON THE NEXT SET. - - NRESETLAST = NRESET - - GO TO 10 - - - 170 WRITE(*,171) READLINE(1:75) - 171 FORMAT(/' THERE IS AN ERROR IN YOUR BLOCK FORMAT FILE FOR '/ - 1' SUBJECT NO. 1. EITHER THE DURATION, THE DOSE, OR THE '/ - 2' DRUG NUMBER IS MISSING. THE 1ST 75 CHARACTERS OF THE LINE ARE:'/ - 2A75// - 3' THE PROGRAM STOPS.'/) - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,171) READLINE(1:75) - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - CALL PAUSE - STOP - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(TIMEVENT .LT. 0.D0) CONDITION. - - - - TIMEVENT = TIMEVENT + TIMERESET - - -C IF IDEVENT = 0, IT MEANS THAT THIS ROW IS AN OBSERVED VALUE ROW. -C IN THIS CASE, READ THE OBSERVED VALUE INFO. - - IF(IDEVENT .EQ. 0) THEN - - -C THE 7TH ENTRY (AFTER COMMA NO. 6) IS AN OUTPUT VALUE FOR THIS TIME -C IF THERE IS AN ERROR, IT IS ASSUMED THAT THE PROGRAM READ A DOT, -C WHICH WOULD BE INCONSISTENT SINCE IDEVENT = 0 (MEANING THERE SHOULD -C BE AN OUTPUT VALUE ON THE ROW). - - CALL AFTERCOMMA(NCOVA,READLINE,6) - BACKSPACE(57) - READ(57,*,ERR=30) YVAL - CLOSE(57) - -C TO GET TO THIS POINT --> YVAL CONTAINS AN OUTPUT VALUE FOR THIS -C LINE. BEFORE THIS VALUE CAN BE STORED, MUST READ THE OUTPUT EQUATION -C NO. AFTER COMMA NO. 7. - - CALL AFTERCOMMA(NCOVA,READLINE,7) - BACKSPACE(57) - READ(57,*,ERR=30) IOUTEQ - IF(NOUT .LT. IOUTEQ) NOUT = IOUTEQ - CLOSE(57) - -C STORE THIS VALUE. ALSO STORE THE TIME OF THIS EVENT INTO THE ARRAY -C WHICH STORES OUTPUT TIMES. - - NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 - TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT - OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = YVAL - NRESETADD = 0 - -C SEE CODE ABOVE REGARDING NRESEADD. - - GO TO 20 - - - - 30 WRITE(*,31) NSUB, TIMEVENT - TIMERESET - 31 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ - 1' NO. ',I4,' AND TIME ',F10.4, ' A LINE HAS AN EVENT ID OF 0 IN'/ - 2' COL. 2, INDICATING OBSERVED VALUE INFORMATION. BUT THERE IS '/ - 3' EITHER NO OBSERVED VALUE IN COL. 7, OR NO OUTPUT EQUATION NO.'/ - 4' IN ENTRY 8. '// - 3' THE PROGRAM STOPS.') - - WRITE(*,401) NSUB,SUBARRAY(NSUB) - 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,31) NSUB, TIMEVENT - TIMERESET - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - CALL PAUSE - - STOP - - 20 CONTINUE - -C THE 9TH - 12TH ENTRIES FOR THIS ROW POTENTIALLY HOLD NEW ASSAY -C COEFFICIENTS FOR THIS SUBJECT (NSUB) AND OUTPUT EQ. (IOUTEQ). -C READ THESE VALUES. IF THEY ARE NOT MISSING, UPDATE THE ASSAY -C COEFFICIENT INFO FOR THIS SUBJECT/OUTPUT EQ. - -C NOTE THAT THESE ENTRIES SHOULD ALL BE MISSING (DOTS OR n's) OR ALL - -C BE NUMBERS. IF THERE IS A COMBINATION OF MISSING VALUES AND NUMBERS, -C STOP THE PROGRAM AND TELL THE USER. - - IMISSC0 = 0 - IMISSC1 = 0 - IMISSC2 = 0 - IMISSC3 = 0 - - CALL AFTERCOMMA(NCOVA,READLINE,8) - BACKSPACE(57) - - READ(57,*,ERR=230) C00 - CLOSE(57) - - - GO TO 235 - 230 IMISSC0 = 1 - - 235 CALL AFTERCOMMA(NCOVA,READLINE,9) - BACKSPACE(57) - READ(57,*,ERR=240) C11 - CLOSE(57) - - GO TO 245 - 240 IMISSC1 = 1 - - - 245 CALL AFTERCOMMA(NCOVA,READLINE,10) - BACKSPACE(57) - - - READ(57,*,ERR=250) C22 - CLOSE(57) - - GO TO 255 - 250 IMISSC2 = 1 - - 255 CALL AFTERCOMMA(NCOVA,READLINE,11) - BACKSPACE(57) - READ(57,*,ERR=260) C33 - CLOSE(57) - - - GO TO 265 - 260 IMISSC3 = 1 - - 265 CONTINUE - -C IF ALL IMISSCx VALUES ARE 0, UPDATE THE ASSAY C'S FOR THIS -C SUBJECT AND OUTPUT EQ. NO. IF ALL IMISSCx VALUES ARE 1, THEY -C ARE ALL MISSING, SO JUST CONTINUE. IF SOME OF THE IMISSCx VALUES -C ARE 0 AND SOME ARE 1, THIS IS AN INCONSISTENCY (I.E., THE USER HAS -C ENTERED SOME BUT NOT ALL OF THE ASSAY C'S). IN THIS CASE, STOP THE - -C PROGRAM AFTER INFORMING THE USER OF HIS ERROR. - - ISUMC = IMISSC0 + IMISSC1 + IMISSC2 + IMISSC3 - - - - IF(ISUMC .EQ. 0) THEN - CSUB(NSUB,1,IOUTEQ) = C00 - CSUB(NSUB,2,IOUTEQ) = C11 - CSUB(NSUB,3,IOUTEQ) = C22 - CSUB(NSUB,4,IOUTEQ) = C33 - ENDIF - - - IF(ISUMC .NE. 0 .AND. ISUMC .NE. 4) THEN - - - WRITE(*,231) NSUB, TIMEVENT - TIMERESET,IOUTEQ - 231 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ - 1' NO. ',I4,' AND TIME ',F10.4, ' A LINE HAS AN EVENT ID OF 0 IN'/ - 2' COL. 2, INDICATING OBSERVED VALUE INFORMATION, BUT THIS LINE'/ - 3' HAS AN INCOMPLETE SET OF ASSAY COEFFICIENTS FOR OUTPUT EQ. '/ - 4' NUMBER ',I3,'. THERE MUST BE EITHER 4 ASSAY COEFFICIENTS ON'/ - 5' AN OUTPUT LINE, OR NONE (IF NO OUTPUT LINES FOR A PARTICULAR'/ - 6' SUBJECT x OUTPUT EQ. COMBO HAVE ASSAY COEFFICIENTS, THEN THE'/ - 7' POPULATION COEFFICIENTS WILL BE USED).'// - 8' THE PROGRAM STOPS.') - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,231) NSUB, TIMEVENT - TIMERESET,IOUTEQ - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 0) CONDITION. - - - - IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) THEN - - -C IDEVENT = 1 OR 4 --> DOSE AND/OR COVARITE INFO IS TO BE READ IN. - -C THE 4TH ENTRY (AFTER COMMA NO. 3) IS AN INFUSION DURATION, AND THE -C 5TH ENTRY (AFTER COMMA NO. 4) IS THE TOTAL DOSE ... IF THIS LINE -C HAS DOSE INFORMATION. NOTE THAT IF THERE IS NO DOSE, THE TOTAL DOSE -C ENTRY WILL BE A DOT ("."). ALSO, IF THERE IS A TOTAL DOSE, BUT THE -C INFUSION DURATION IS 0, THIS LINE REPRESENTS A BOLUS INPUT. - -C SO, 1ST TRY READING THE TOTAL DOSE AS A REAL NUMBER; IF THERE IS AN -C ERROR, IT IS ASSUMED THAT THE PROGRAM READ A DOT. - - CALL AFTERCOMMA(NCOVA,READLINE,4) - BACKSPACE(57) - READ(57,*,ERR=40) TOTDOS - CLOSE(57) - -C TO GET TO THIS POINT --> TOTDOS CONTAINS A TOTAL DOSE VALUE FOR THIS -C LINE. READ THE INFUSION DURATION AFTER COMMA NO. 3 TO SEE IF THIS -C DOSE IS AN INFUSION (WITH A POSITIVE DURATION) OR A BOLUS (WITH A -C 0 DURATION). - - CALL AFTERCOMMA(NCOVA,READLINE,3) - BACKSPACE(57) - READ(57,*,ERR=50) DUR - - CLOSE(57) - -C BEFORE THIS VALUE CAN BE STORED, MUST READ THE DRUG NO. AFTER COMMA -C NO. 5. - - CALL AFTERCOMMA(NCOVA,READLINE,5) - BACKSPACE(57) - READ(57,*,ERR=50) IDRUGNO - IF(NDRUG .LT. IDRUGNO) NDRUG = IDRUGNO - CLOSE(57) - -C STORE THE ABOVE VALUES DEPENDING ON WHETHER THEY REPRESENT AN -C INFUSION OR A BOLUS INPUT. - -C INCREASE THE NO. OF DOSAGE LINES FOR THIS SUBJECT. IF DUR > 0, THE -C NO. OF DOSAGE LINES INCREASES BY 2 SINCE THERE WILL BE A START TIME -C AND AN ENDING TIME. IF DUR = 0, THE NO. OF DOSAGE LINES WILL INCREASE -C BY 1. - - - IF(DUR .GT. 0) THEN - -C THE INFUSION RATE IS TOTDOS/DUR. SO THE DOSE VALUE THE 1ST DOSE -C TIME BELOW WILL BE THIS INFUSION RATE, AND THE DOSE VALUE AT THE - -C 2ND DOSE TIME BELOW WILL BE 0. - -C NOTE THAT EVERYTIME NTIMALL(NSUB) IS INCREASED, THE PROGRAM CHECKS -C THAT IT HAS NOT GONE PAST 72000. IF SO, A MESSAGE TO THE USER IS - - -C WRITTEN THAT THIS IS NOT ALLOWED AND THE PROGRAM STOPS. - - - NTIMALL(NSUB) = NTIMALL(NSUB) + 1 - - IF(NTIMALL(NSUB) .GT. 72000) THEN - - - WRITE(*,3001) NSUB - 3001 FORMAT(/' THE NO. OF LINES IN THE DOSAGE REGIMEN FOR SUBJECT'/ - 1' NO. ',I5,' IS MORE THAN THE LIMIT OF 72000. PLEASE RERUN THE'/ - 2' PROGRAM AFTER REDUCING THIS NO. TO BE LESS THAN 72000.'/) - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,3001) NSUB - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT - - - IF(IDEVENT .EQ. 4) THEN - -C SEE FORMAT 502 ABOVE. IDEVENT = 4 IS DISALLOWED EXPLICITLY AS OF -C BESTDOS119.FOR. - -C IF IDEVENT = 4, IT MEANS THAT THIS IS A TIME RESET POINT (I.E., A -C TIME IN THE DISTANT FUTURE WHICH WILL SHOW UP AS T = 0 IN THE -C WORKING COPY FORMAT FILE). IN THIS CASE, IF NRESETADD = 0, ADD -C VALUES TO NTIMOUT, TIMOUT, AND OUT FOR EACH OF THE MAXNUMEQ POSSIBLE -C OUTPUT EQUATIONS (THERE ARE NOUT OUTPUT EQUATIONS SO FAR, BUT IN - - -C SUBSEQUENT ROWS, NOUT COULD INCREASE TO AT MOST MAXNUMEQ) TO -C INDICATE THAT ANY OUTPUTS FOLLOWING THIS TIME ARE BASED ON THE TIME -C RESET. TO DO THIS, PUT IN THE CURRENT TIME IN TIMOUT, AND A -C CORRESPONDING VALUE OF -99 (MISSING VALUE), FOR EACH OUTPUT EQUATION. - - -C STORE VALUES INTO THE OUPUT ARRAYS (TIME = 0 AND VALUE = -99) WHICH -C INDICATE THAT SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. -C ... BUT ONLY STORE THESE EXTRA VALUES IF NRESETADD = 0. IF -C NRESETADD = 1, IT MEANS THAT THESE LINES HAVE ALREADY BEEN ADDED -C SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE OUTPUT -C ARRAYS. - - IF(NRESETADD .EQ. 0) THEN - DO IOUTEQ = 1,MAXNUMEQ - NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 - TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT - OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 - END DO - NRESETADD = 1 - ENDIF - - ENDIF - - - -C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 4) CONDITION. - - -C IF THE CURRENT TIME IS THE SAME AS THE ENDING TIME OF THE PREVIOUS -C IV, DO NOT INCREASE NTIMIV(.,.) BELOW, BECAUSE THE NEW STARTING IV -C RATE MUST REPLACE THE 0.0 FROM THE ENDING OF THE PREVIOUS IV. - - ISAME = 0 - IF(NTIMIV(NSUB,IDRUGNO) .GT. 0) - 1 CALL THESAME(TIMEVENT,TIMIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)), - 2 ISAME) - - IF(ISAME .EQ. 0) NTIMIV(NSUB,IDRUGNO) = NTIMIV(NSUB,IDRUGNO) + 1 - TIMIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = TIMEVENT - RATEIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = TOTDOS/DUR - - NTIMALL(NSUB) = NTIMALL(NSUB) + 1 - - - IF(NTIMALL(NSUB) .GT. 72000) THEN - - - WRITE(*,3001) NSUB - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,3001) NSUB - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT + DUR - NTIMIV(NSUB,IDRUGNO) = NTIMIV(NSUB,IDRUGNO) + 1 - TIMIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = TIMEVENT + DUR - RATEIV(NSUB,IDRUGNO,NTIMIV(NSUB,IDRUGNO)) = 0.D0 - - ENDIF - - - -C THE ABOVE ENDIF IS FOR THE IF(DUR .GT. 0) CONDITION. - - - - IF(DUR .LE. 0) THEN - - - -C STORE THE BOLUS VALUE AT THE INDICATED TIME, TIMEVENT. - - - NTIMALL(NSUB) = NTIMALL(NSUB) + 1 - - IF(NTIMALL(NSUB) .GT. 72000) THEN - - WRITE(*,3001) NSUB - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,3001) NSUB - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - - CALL PAUSE - STOP - - - - ENDIF - - TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT - - - - IF(IDEVENT .EQ. 4) THEN - -C SEE LOGIC ABOVE FOR TIME RESET LOGIC, AND ADDING LINES TO THE -C OUTPUT EQUATION VALUES IN THAT CASE. - -C STORE VALUES INTO THE OUPUT ARRAYS (SEE LOGIC ABOVE) WHICH -C INDICATE THAT SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. -C ... BUT ONLY STORE THESE EXTRA VALUES IF NRESETADD = 0. IF -C NRESETADD = 1, IT MEANS THAT THESE LINES HAVE ALREADY BEEN ADDED -C SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE OUTPUT -C ARRAYS. - - IF(NRESETADD .EQ. 0) THEN - DO IOUTEQ = 1,MAXNUMEQ - NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 - TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT - OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 - END DO - NRESETADD = 1 - ENDIF - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 4) CONDITION. - - NTIMBOL(NSUB,IDRUGNO) = NTIMBOL(NSUB,IDRUGNO) + 1 - TIMBOL(NSUB,IDRUGNO,NTIMBOL(NSUB,IDRUGNO)) = TIMEVENT - BOLUS(NSUB,IDRUGNO,NTIMBOL(NSUB,IDRUGNO)) = TOTDOS - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE IF(DUR .LE. 0) CONDITION. - - - GO TO 40 - - - 50 WRITE(*,51) NSUB, TIMEVENT - TIMERESET - 51 FORMAT(/' THERE IS AN ERROR IN THE BLOCK FORMAT. FOR SUBJECT '/ - 1' NO. ',I4,' AND TIME ',F10.4,' A LINE HAS A DOSAGE AMT., BUT NO'/ - 2' DURATION (EVEN A BOLUS SHOULD HAVE A DURATION OF 0) IN '/ - 3' ENTRY 4., OR NO DRUG NO. IN ENTRY 5.'// - 3' THE PROGRAM STOPS.') - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,51) NSUB, TIMEVENT - TIMERESET - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - CALL PAUSE - - - STOP - - - 40 CONTINUE - - -C READ IN ANY COVARIATE VALUES IF NCOVA .GT. 0. - - IF(NCOVA .GT. 0) THEN - - - DO 60 ICOV = 1,NCOVA - - CALL AFTERCOMMA(NCOVA,READLINE,11+ICOV) - BACKSPACE(57) - READ(57,*,ERR=70) COVVAL - CLOSE(57) - - - -C TO GET TO THIS POINT --> COVVAL REPRESENTS THE VALUE OF COV. NO. -C ICOV. STORE IT AT THE INDICATED TIME, TIMEVENT. - - NTIMALL(NSUB) = NTIMALL(NSUB) + 1 - - IF(NTIMALL(NSUB) .GT. 72000) THEN - - - WRITE(*,3001) NSUB - WRITE(*,401) NSUB,SUBARRAY(NSUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,3001) NSUB - WRITE(47,401) NSUB,SUBARRAY(NSUB) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - TIMALL(NSUB,NTIMALL(NSUB)) = TIMEVENT - - - - IF(IDEVENT .EQ. 4) THEN - - -C SEE LOGIC ABOVE FOR TIME RESET LOGIC, AND ADDING LINES TO THE -C OUTPUT EQUATION VALUES IN THAT CASE. - -C STORE VALUES INTO THE OUPUT ARRAYS (TIME = 0 AND VALUE = -99) WHICH -C INDICATE THAT SUBSEQUENT OUTPUT TIMES ARE BASED ON THIS TIME RESET. - -C ... BUT ONLY STORE THESE EXTRA VALUES IF NRESETADD = 0. IF -C NRESETADD = 1, IT MEANS THAT THESE LINES HAVE ALREADY BEEN ADDED -C SINCE THE LAST ACTUAL OUTPUT VALUE WAS PUT INTO ONE OF THE OUTPUT -C ARRAYS. - - IF(NRESETADD .EQ. 0) THEN - DO IOUTEQ = 1,MAXNUMEQ - NTIMOUT(NSUB,IOUTEQ) = NTIMOUT(NSUB,IOUTEQ) + 1 - TIMOUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = TIMEVENT - OUT(NSUB,IOUTEQ,NTIMOUT(NSUB,IOUTEQ)) = -99.D0 - END DO - NRESETADD = 1 - ENDIF - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 4) CONDITION. - -C SINCE MULTIPLE DOSE LINES CAN OCCUR AT THE SAME TIME (DEFINING - -C DOSES FOR DIFFERENT DRUGS OR IV VS. BOLUS VALUES, IT IS POSSIBLE -C THAT A COVARIATE VALUE IS BEING RESET AT THE SAME TIME AS IN A -C PREVIOUS LINE. IF THIS IS TRUE, TELL THE USER THAT THE COVARIATE -C VALUE FROM THE FIRST LINE WILL BE USED. THIS MUST BE CHECKED ONLY -C IF THE INDEX OF THE NO. OF COVARIATE VALUES IS > 0 - OTHERWISE -C THIS IS THE FIRST LINE WITH A COVARIATE VALUE ON IT). - -C BUT, ONLY WRITE THIS WARNING IF THE TWO COVARIATE VALUES ARE -C ACTUALLY DIFFERENT, BECAUSE IF THEY ARE THE SAME, THERE IS NO -C CONFLICT, JUST REDUNDANCY. - - - - IF(NTIMCOV(NSUB,ICOV) .GT. 0) THEN - - CALL THESAME(TIMEVENT,TIMCOV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)), - 1 ISAMETIME) - - CALL THESAME(COVVAL,COV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)), - 1 ISAMECOV) - - IF(ISAMETIME .EQ. 1 .AND. ISAMECOV .EQ. 1) GO TO 60 - - IF(ISAMETIME .EQ. 1 .AND. ISAMECOV .EQ. 0) THEN - WRITE(*,41) NSUB,TIMEVENT-TIMERESET,ICOV, - 1 COV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)),COVVAL - 41 FORMAT(/' FOR SUBJECT, 'I2,' AT TIME ',G14.7,', COVARIATE'/ - 1' NO. ',I2,' WAS SET TO BOTH ',G14.7,' AND ',G14.7,'. YOU SHOULD'/ - 2' CHECK YOUR BLOCK FILE. FOR NOW, THE FIRST VALUE WILL BE USED.') - - GO TO 60 - ENDIF - - ENDIF - - - - NTIMCOV(NSUB,ICOV) = NTIMCOV(NSUB,ICOV) + 1 - TIMCOV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)) = TIMEVENT - COV(NSUB,ICOV,NTIMCOV(NSUB,ICOV)) = COVVAL - - GO TO 60 - - 70 CONTINUE - -C TO GET TO LABEL 70 --> THERE WAS NO NUMBER IN THE ENTRY FOR - - -C COVARIATE, ICOV. - - 60 CONTINUE - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NCOVA .EQ. 0) CONDITION. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) -C CONDITION. - - -C RETURN TO LABEL 10 TO READ THE NEXT LINE IN THE BLOCK PATIENT -C DATA FILE. - - - GO TO 10 - - - 100 NSUB = 1 - - - IF(NCOVA .GT. 0) THEN - - -C IF IGUI = 1, IT MEANS THAT THIS PROGRAM IS BEING RUN WITHOUT ANY -C USER INTERACTION, AND ALL THE INFO IS INCLUDED IN THE FILE - -C 'GUICMDS.INX', WHICH IS CURRENTLY OPENED AS FILE 23. IN THIS CASE, -C SKIP THE KEYBOARD INPUTTING OF ICOVTYPE(.) BELOW, AND INSTEAD READ -C THESE VALUES FROM THE PREVIOUS LINE OF FILE 23. - - -C IF IGUI = 0, IT MEANS THAT THIS PROGRAM IS BEING RUN THE STANDARD -C WAY, WITH USER INTERACTION. IN THIS CASE, INPUT ICOVTYPE(.) FROM -C THE USER VIA THE KEYBOARD. - - IF(IGUI .EQ. 1) THEN - BACKSPACE(23) - READ(23,*) (ICOVTYPE(ICOV),ICOV=1,NCOVA) - ENDIF - - - IF(IGUI .EQ. 0) THEN - - - - IF(IWHICH .EQ. 1) WRITE(*,111) NCOVA - 111 FORMAT(/' YOUR BLOCK FORMAT PATIENT INFORMATION FILE, WHICH'/ - 1' HAS THE "PAST" INFORMATION ON YOUR SUBJECT, SHOWS'/ - 1' ',I2,' COVARIATES. EACH COVARIATE MUST BE SPECIFIED TO BE '/ - - - 2' EITHER A PIECEWISE CONSTANT COVARIATE OR AN INTERPOLATED '/ - 3' COVARIATE.'// - 4' A PIECEWISE CONSTANT COVARIATE WILL HAVE THE SAME VALUE FROM'/ - 5' ONE EXPLICITLY CODED VALUE, THROUGH ALL INTERVEENING DOSE'/ - 6' TIMES, TO THE NEXT EXPLICITLY CODED VALUE (WHEN IT WILL CHANGE). - 7 '// - 8' AN INTERPOLATED COVARIATE WILL HAVE INTERPOLATED VALUES FROM'/ - 9' ONE EXPLICITY CODED VALUE, THROUGH ALL INTERVEENING DOSE '/ - 1' TIMES, TO THE NEXT EXPLCITLY CODED VALUE.'//) - - - IF(IWHICH .EQ. 2) WRITE(*,117) NCOVA - 117 FORMAT(/' YOUR BLOCK FORMAT PATIENT INFORMATION FILE, WHICH'/ - 1' HAS THE "FUTURE" INFORMATION ON YOUR SUBJECT, SHOWS'/ - 1' ',I2,' COVARIATES. EACH COVARIATE MUST BE SPECIFIED TO BE '/ - 2' EITHER A PIECEWISE CONSTANT COVARIATE OR AN INTERPOLATED '/ - 3' COVARIATE.'// - 4' A PIECEWISE CONSTANT COVARIATE WILL HAVE THE SAME VALUE FROM'/ - 5' ONE EXPLICITLY CODED VALUE, THROUGH ALL INTERVEENING DOSE'/ - 6' TIMES, TO THE NEXT EXPLICITLY CODED VALUE (WHEN IT WILL CHANGE). - 7 '// - 8' AN INTERPOLATED COVARIATE WILL HAVE INTERPOLATED VALUES FROM'/ - 9' ONE EXPLICITY CODED VALUE, THROUGH ALL INTERVEENING DOSE '/ - 1' TIMES, TO THE NEXT EXPLCITLY CODED VALUE.'//) - - - - DO ICOV = 1,NCOVA - 130 WRITE(*,112) COVNAME(ICOV) - 112 FORMAT(/' FOR COVARIATE ',A11/ - 1' ENTER 1 IF IT IS TO BE PIECEWISE CONSTANT; '/ - 2' ENTER 2 IF IT IS TO BE INTERPOLATED: ') - - READ(*,*,ERR=130) ITYPE - - IF(ITYPE .NE. 1 .AND. ITYPE .NE. 2) GO TO 130 - ICOVTYPE(ICOV) = ITYPE - END DO - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IGUI .EQ. 0) CONDITION. - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NCOVA .GT. 0) CONDITION. - - - - -C WRITE OUT ALL THE INFO IN THE ABOVE ARRAYS INTO A WORKING COPY -C FORMAT. ACTUALLY, FOR NOW, JUST TRY TO CREATE THE DOSAGE AND -C OBSERVATION PART OF A FILE SIMILAR TO 2DRUG001 (I.E., DON'T -C WORRY NOW ABOUT THE TOP PART OF THE FILE, OR THE BOTTOM). - - -C FIRST, CALL SUBROUTINE GETCHAR2 TO ESTABLISH THE NUMBER ARRAY. - - DO JSUB = 1,NSUB - CALL GETCHAR2(JSUB,CHARSUB) - NUMBER(JSUB) = CHARSUB - END DO - - - DO 1000 ISUB = 1,NSUB - -C NOTE THAT THE WORKING COPY SUBJECTS WILL BE PLACED INTO THE -C WORKING DIRECTORY. THE PREFIX WILL BE HARDCODED TO 'XQZPJ', AND THE -C SUFFIX TO 'PST' IF IWHICH = 1, AND TO 'FUT' IF IWHICH = 2. - - IF(IWHICH .EQ. 1) PATFIL = 'XQZPJ'//NUMBER(ISUB)//'.PST' - IF(IWHICH .EQ. 2) PATFIL = 'XQZPJ'//NUMBER(ISUB)//'.FUT' - - -C CALL FULLNAME WHICH CONVERTS THE FILENAME TO PATHFILE, THE COMPLETE -C NAME OF THE FILE, WHICH INCLUDES THE PATH (IF THE PATH IS NOT THE -C CURRENT DIRECTORY). - - TMPFILE = ' ' - TMPFILE = PATFIL - CALL FULLNAME(PATH,TMPFILE,PATHFILE) - - - OPEN(33,FILE=PATHFILE) - - IF(NDRUG .GT. 7) THEN - - - - WRITE(*,101) NDRUG - 101 FORMAT(/' NO. OF DRUGS IN THIS PATIENT DATA SET IS ',I2/ - 1' THIS IS MORE THAN 7, THE MAXIMUM --> PROGRAM STOPS.'/) - WRITE(*,401) ISUB,SUBARRAY(ISUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,101) NDRUG - WRITE(47,401) ISUB,SUBARRAY(ISUB) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - IF(NOUT .GT. MAXNUMEQ) THEN - - - - WRITE(*,106) NOUT,MAXNUMEQ - 106 FORMAT(/' NO. OF OUTPUT EQS. THIS PATIENT DATA SET IS ',I2/ - 1' THIS IS MORE THAN THE MAX. ALLOWED VALUE OF ',I2,'. SO THE'/ - 2' PROGRAM STOPS.'/) - WRITE(*,401) ISUB,SUBARRAY(ISUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,106) NOUT,MAXNUMEQ - WRITE(47,401) ISUB,SUBARRAY(ISUB) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - IF(NCOVA .GT. 26) THEN - - WRITE(*,103) NCOVA - 103 FORMAT(/' NO. OF COVARIATES IN THIS PATIENT DATA SET IS ',I3/ - 1' THIS IS MORE THAN 26, THE MAXIMUM --> PROGRAM STOPS.'/) - WRITE(*,401) ISUB,SUBARRAY(ISUB) - - OPEN(47,FILE=ERRFIL) - WRITE(47,103) NCOVA - - - WRITE(47,401) ISUB,SUBARRAY(ISUB) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - -C BEFORE CALLING WRITEDOS, CALL TIMESET FOR THIS SUBJECT TO -C ELIMINATE ALL THE DUPLICATE TIMES IN TIMALL(ISUB,.). THERE COULD BE -C DUPLICATE TIMES BECAUSE NTIMALL(ISUB) WAS INCREASED BY 1 FOR EACH -C BOLUS, IV, OR COVARIATE VALUE, AND SOME OF THESE VALUES OCCUR AT THE -C SAME TIME. TIMESET ALSO ORDERS THE TIMES AND THEY COULD BE OUT OF -C ORDER DUE TO AN IV RATE WHOSE DURATION RESULTS IN THE ENDING TIME -C BEING PAST THE NEXT DOSE EVENT. - -C TIMESET RETURNS THE COMPLETE SET OF TIMES FOR THIS SUBJECT'S DOSAGE -C REGIMEN IN TIMI (AND THERE ARE NTIMI OF THEM). - - CALL TIMESET(MAXSUB,ISUB,SUBARRAY(ISUB),NTIMALL,TIMALL,NTIMI, - 1 TIMI) - - - -C CALL WRITEDOS TO WRITE THE PATIENT INFO TO PATHFILE = FILE 33. - - CALL WRITEDOS(ISUB,NTIMIV,TIMIV,RATEIV,NTIMBOL,TIMBOL,BOLUS, - 1 NTIMCOV,TIMCOV,COV,ICOVTYPE,NDRUG,NCOVA,NOUT,NTIMOUT, - 2 TIMOUT,OUT,SUBARRAY(ISUB),COVNAME,MAXSUB,NTIMI,TIMI,TIMADD, - 3 CSUB,NSST,DOSELINEST) - - - 1000 CONTINUE - - - RETURN - - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE AFTERCOMMA(NCOVA,READLINE,NCOMMA) - CHARACTER READLINE*1000,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C OPEN AND WRITE INTO SCRATCH FILE 57 THE PART OF READLINE THAT -C IS BETWEEN COMMAS NCOMMA AND NCOMMA+1 ... UNLESS NCOMMA IS THE MAX. -C NO. OF COMMAS (11+NCOVA). IN THIS CASE, WRITE INTO SCRATCH FILE 57 THE - -C PART OF READLINE THAT FOLLOWS COMMA NCOMMA (SINCE THERE WILL NOT BE -C ANOTHER COMMA). - - 1 FORMAT(A1000) - -C IF NCOMMA = 0, SET ISTART = 0 AND GO TO LABEL 10. - - IF(NCOMMA .EQ. 0) THEN - ISTART = 0 - GO TO 10 - ENDIF - - - ICOMMA = 0 - - DO ISTART = 1,300 - - IF(READLINE(ISTART:ISTART) .EQ. ',') THEN - - ICOMMA = ICOMMA + 1 - IF(ICOMMA .EQ. NCOMMA) GO TO 10 - ENDIF - END DO - - - - -C TO GET TO THIS POINT MEANS THAT THE NO. OF COMMAS IN LINE -C READLINE IS LESS THAN NCOMMA. WRITE A MESSAGE AND STOP. - - WRITE(*,2) NCOMMA,ICOMMA,READLINE - 2 FORMAT(/' THE FOLLOWING LINE WAS SUPPOSED TO HAVE AT LEAST ',I3/ - 1' COMMAS, BUT IT HAD ONLY ',I3,' SO THE PROGRAM STOPS.'// - 2A1000) - - OPEN(47,FILE=ERRFIL) - WRITE(47,2) NCOMMA,ICOMMA,READLINE - CLOSE(47) - - - - CALL PAUSE - STOP - - -C TO REACH LABEL 10, ISTART IS NOW THE COLUMN NO. WHICH HAS THE -C NCOMMAth COMMA IN LINE READLINE. FIND IEND, WHICH IS THE COLUMN NO. -C WHICH HAS THE NCOMMA+1 ST COMMA IN THE LINE. THEN WRITE THE PORTION -C OF READLINE WHICH IS BETWEEN ISTART AND IEND INTO FILE57. - - 10 ICOMMA = 0 - - DO IEND = 1,300 - IF(READLINE(IEND:IEND) .EQ. ',') THEN - ICOMMA = ICOMMA + 1 - IF(ICOMMA .EQ. NCOMMA+1) GO TO 20 - ENDIF - END DO - -C TO GET TO THIS POINT MEANS THAT THE NO. OF COMMAS IN LINE -C READLINE IS LESS THAN NCOMMA+1. THIS IS OK IF NCOMMA IS THE MAXIMUM -C NO. OF COMMAS, WHICH IS 11+NCOVA. OTHERWISE, WRITE A MESSAGE AND -C STOP. - - IF(NCOMMA .LT. 11 + NCOVA) THEN - - - - WRITE(*,2) NCOMMA+1,ICOMMA,READLINE - - OPEN(47,FILE=ERRFIL) - WRITE(47,2) NCOMMA+1,ICOMMA,READLINE - CLOSE(47) - - - - - CALL PAUSE - STOP - - - - ENDIF - - IF(NCOMMA .EQ. 11 + NCOVA) IEND = 301 - -C???DEBUG. NOTE THAT SOMETIMES, WHEN THIS PROGRAM IS COMPILED/LINKED -C WITH gfortran, IT PRODUCES AN ERROR RELATED TO FILE 57. THIS ERROR -C HAPPENS RANDOMLY, AND MAY BE ABLE TO BE REMOVED BY CHANGING FROM -C OPEN(57) TO OPEN(57,FILE='FILE57JUNK'). -C AS OF BESTDOS111.FOR, CHANGE TO OPEN(57,FILE='FILE57JUNK') BECAUSE -C MORE 'CANNOT OPEN' ERRORS RELATED TO FILE 57 HAVE BEEN OBSERVED. - - 20 OPEN(57,FILE='FILE57JUNK') - -C SEE CODE AT TOP OF MONTBG100.FOR TO SEE WHY FORMATTED WRITE -C STATEMENTS ARE USED (UNLESS NUMCHAR BELOW IS > 11, IN WHICH CASE - -C A FREE FORMAT WRITE STATEMENT IS STILL USED). - - NUMCHAR = IEND - ISTART - 1 - - IF(NUMCHAR .EQ. 1) WRITE(57,101) READLINE(ISTART+1:IEND-1) - 101 FORMAT(A1) - - IF(NUMCHAR .EQ. 2) WRITE(57,102) READLINE(ISTART+1:IEND-1) - 102 FORMAT(A2) - - IF(NUMCHAR .EQ. 3) WRITE(57,103) READLINE(ISTART+1:IEND-1) - 103 FORMAT(A3) - - IF(NUMCHAR .EQ. 4) WRITE(57,104) READLINE(ISTART+1:IEND-1) - 104 FORMAT(A4) - - IF(NUMCHAR .EQ. 5) WRITE(57,105) READLINE(ISTART+1:IEND-1) - 105 FORMAT(A5) - - IF(NUMCHAR .EQ. 6) WRITE(57,106) READLINE(ISTART+1:IEND-1) - 106 FORMAT(A6) - - IF(NUMCHAR .EQ. 7) WRITE(57,107) READLINE(ISTART+1:IEND-1) - 107 FORMAT(A7) - - IF(NUMCHAR .EQ. 8) WRITE(57,108) READLINE(ISTART+1:IEND-1) - - 108 FORMAT(A8) - - - IF(NUMCHAR .EQ. 9) WRITE(57,109) READLINE(ISTART+1:IEND-1) - 109 FORMAT(A9) - - IF(NUMCHAR .EQ. 10) WRITE(57,110) READLINE(ISTART+1:IEND-1) - 110 FORMAT(A10) - - IF(NUMCHAR .EQ. 11) WRITE(57,111) READLINE(ISTART+1:IEND-1) - 111 FORMAT(A11) - - IF(NUMCHAR .GT. 11) WRITE(57,*) READLINE(ISTART+1:IEND-1) - - - - RETURN - END -C - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE WRITEDOS(ISUB,NTIMIV,TIMIV,RATEIV,NTIMBOL,TIMBOL, - 1 BOLUS,NTIMCOV,TIMCOV,COV,ICOVTYPE,NDRUG,NCOVA,NOUT,NTIMOUT, - 2 TIMOUT,OUT,SUBID,COVNAME,MAXSUB,NTIMI,TIMI,TIMADD,CSUB,NSST, - 3 DOSELINEST) - - PARAMETER(MAXNUMEQ=7) - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION BOLVAL(7),COVVAL(26),XIVVAL(7),DOSELINE(5200,43), - 1 TIMOUT(MAXSUB,MAXNUMEQ,650),TIMIV(MAXSUB,7,5200), - 2 NTIMOUT(MAXSUB,MAXNUMEQ),NTIMIV(MAXSUB,7),RATEIV(MAXSUB,7,5200), - 3 BOLUS(MAXSUB,7,5200),OUT(MAXSUB,MAXNUMEQ,650), - 4 COV(MAXSUB,26,5200),ICOVTYPE(26),TIMBOL(MAXSUB,7,5200), - 5 NTIMBOL(MAXSUB,7),NTIMCOV(MAXSUB,26),TIMCOV(MAXSUB,26,5200), - 6 INDIV(7),INDBOL(7),INDCOV(26),TIMI(72000),TIMORD(3900), - 7 BLOCKOUT(3900,MAXNUMEQ),CSUB(MAXSUB,4,MAXNUMEQ), - 8 NSST(MAXSUB),DOSELINEST(MAXSUB,99,100),DOSELINES(100) - - CHARACTER SUBID*11,COVNAME(26)*11,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C THIS ROUTINE WRITES THE DOSE EVENTS AND THE OBSERVATION EVENTS OF -C THE PATIENT DATA FILE TO FILE33. NOTE THAT A DOSE EVENT OCCURS -C WHENEVER THERE IS A BOLUS APPLIED, AN IV RATE CHANGE, AND/OR A -C COVARIATE VALUE APPLIED. - - -C----------------- WRITE THE TOP OF FILE BELOW ------------------------- - - WRITE(33,301) SUBID - 301 FORMAT(' LAST AND FIRST NAMES ARE: ',A11) - WRITE(33,302) SUBID - 302 FORMAT(' CHART NUMBER IS: ',A11// - 1' WARD NO, PATIENT AGE (YEARS), SEX, HEIGHT (INCHES),'/ - 2' ETHNICITY FLAG, AND ETHNICITY DESCRIPTION (IF ANY) FOLLOW ON'/ - 3' THE NEXT 6 LINES:'/ - 4'-99'/ - 5'-99'/ - 6'M'/ - 7'-99'/ - 8'1'/ - - 9'Ethnicity Description'// - 1' DATE OF FIRST THERAPY IS 1 1 08'/ - - 2'CCR ML/MIN/ 0.00 150.00'/ - 3'HOURS MG MG/HR MCG/ML KG MG/DL 60 .00 ') - - -C----------------- WRITE THE TOP OF FILE ABOVE ------------------------- - - -C----------------- WRITE THE DOSE EVENTS BELOW ------------------------- - - - WRITE(33,102) NDRUG - 102 FORMAT(/' ',I1,' ... NO. OF DRUGS') - -C NOTE THAT NCOVA IS THE NO. OF COVARIATES IN THE USER'S BLOCK FORMAT -C FILE. THIS AUTOMATICALLY BECOMES NADD, THE NO. OF "ADDITIONAL" -C COVARIATES IN THE WORKING COPY FILE. - - WRITE(33,104) NCOVA - 104 FORMAT(' ',I2,' ... NO. OF ADDITIONAL COVARIATES') - - - -C INCREASE THE NO. OF DOSE EVENTS BY THE NO. OF STEADY STATE DOSE LINES -C THAT WILL BE IN THE FILE (THESE WERE NOT PART OF THE ARRAY EXAMINED -C BY SUBROUTINE TIMESET). - - WRITE(33,2) NTIMI + NSST(ISUB) - 2 FORMAT(' ',I3,' ... NO. OF DOSE EVENTS'// - 1' TIME, IV/PO FOR EACH DRUG; ADDITIONAL COVARIATES IF ANY') - - -C SET THE IVs FOR EACH DRUG TO 0. EACH DRUG IV VALUE STAYS THE SAME -C AS ITS PREVIOUS VALUE UNTIL CHANGED. ALSO INITIALIZE EACH BOLUS - -C VALUE TO 0. - - DO IDRUG = 1,NDRUG - - XIVVAL(IDRUG) = 0.D0 - BOLVAL(IDRUG) = 0.D0 - END DO - -C SET EACH COVARIATE VALUE TO ITS INITIAL VALUE. IT IS ASSUMED THAT -C EACH COV. HAS ITS FIRST VALUE SET AT THE FIRST DOSE TIME (T=0). -C IF THIS IS NOT TRUE, SEE REMARK BELOW WHERE THE COVARIATE VALUES -C ARE SET FOR EACH TIME. - - DO ICOV = 1,NCOVA - COVVAL(ICOV) = COV(ISUB,ICOV,1) - END DO - - -C INITIALIZE THE INDEX OF THE NEXT TIME IN EACH TIME ARRAY TO BE 1. - - DO IDRUG = 1,NDRUG - INDIV(IDRUG) = 1 - INDBOL(IDRUG) = 1 - END DO - - DO ICOV = 1,NCOVA - INDCOV(ICOV) = 1 - END DO - - -C GO THROUGH ALL THE NTIMI DOSAGE BLOCK TIMES IN TIMI AND ESTABLISH ALL -C IV, BOLUS, AND COV. VALUES AT EACH TIME AND WRITE THEM TO THE DOSAGE - -C REGIMEN, BUT NOTE THAT EACH TIME MUST BE REDUCED BY TIMERESET, WHERE -C TIMERESET = TIMADD*NRESET, WHERE NRESET IS THE NO. OF TIME RESETS -C THROUGH THAT TIME (SEE IN READBLOCK THAT TIMERESET WAS ADDED TO EACH -C TIME). - - - - - NRESET = 0 - TIMERESET = TIMADD*NRESET - -C INITIALIZE NSSEVENTS = 1. THIS WILL BE THE INDEX OF THE NEXT STEADY -C STATE DOSE EVENT (IF ANY) IN THE CURRENT PATIENT'S DATA FILE. THE -C TOTAL NO. OF SUCH EVENTS IS NSST(ISUB). - - - NSSEVENTS = 1 - - - - - -C AS OF NPAG104, PUT IN A STEADY STATE LINE AS THE FIRST DOSE EVENT -C IF ONE EXISTS. - -C DOSELINEST(ISUB,1,100) = NRESET, THE NO. OF DOSE RESETS BEFORE THE -C 1ST STEADY STATE DOSE SET. - -C IF DOSELINST(ISUB,1,100) = 0, IT MEANS THAT THERE IS A STEADY STATE -C DOSE SET AT THE TOP OF THE FILE (I.E., BEFORE ANY RESETS). - - -C IF DOSELINEST(ISUB,1,100) IS = -99, IT MEANS THERE ARE NO STEADY -C STATE LINES FOR THIS SUBJECT. - -C IF DOSELINEST(ISUB,1,100) = N > 0, IT MEANS THE FIRST STEADY STATE -C DOSE SET OCCURS AFTER RESET NO. N. - - - CALL THESAME(DOSELINEST(ISUB,1,100),0.D0,ISAME) - - IF(ISAME .EQ. 1) THEN - -C FILL IN THE ENTRIES TO DOSELINE FOR THE STEADY STATE DOSE AT THE -C TOP OF THE PATIENT'S FILE. - -C THE FIRST ENTRY IN DOSELINST IS TIMEVENT = THE NEGATIVE OF THE -C INTERDOSE INTERVAL. - - DOSELINES(1) = DOSELINEST(ISUB,1,1) - - NENTRY = 1 - -C FOR EACH DRUG, THE IV AND TOTAL VALUES ARE ALREADY STORED INTO -C DOSELINEST(ISUB,1,2*I) AND DOSELINEST(ISUB,1,2*I+1), I=1,NDRUG. - - DO IDRUG = 1,NDRUG - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,1,2*IDRUG) - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,1,2*IDRUG+1) - END DO - -C FOR EACH COVARIATE, IF ANY, THE VALUES ARE STORED INTO -C DOSELINEST(ISUB,1,19+ICOV), ICOV = 1,NCOVA. - - IF(NCOVA .GT. 0) THEN - DO ICOV = 1,NCOVA - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,1,19+ICOV) - END DO - ENDIF - - WRITE(33,1) (DOSELINES(J),J=1,NENTRY) - - NSSEVENTS = NSSEVENTS + 1 - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. - - - - DO 1000 ITIM = 1,NTIMI - - - TIME = TIMI(ITIM) - - -C IF THIS TIME = THE NEXT MULTIPLE OF TIMADD, INCREASE THE NO. OF -C RESETS BY 1 AND RECALCULATE TIMERESET, THE CURRENT AMOUNT THAT EACH -C TIME MUST BE REDUCED BEFORE BEING WRITTEN INTO THE WORKING COPY -C FILE. - -C AS OF NPAG104.FOR, THIS TIME COULD BE PAST A TIME RESET POINT. THIS -C WOULD HAPPEN IF A TIME RESET HAD A STEADY STATE DOSE SET ASSOCIATED -C WITH IT, WITHOUT A NON STEADY STATE DOSE IMMEDIATELY FOLLWOING IT (IF -C A NON STEADY STATE DOSE IMMEDIATELY FOLLOWED A STEADY STATE SET, -C THEN THERE WILL BE TIMI(.) ENTRY THAT = TIMADD*(NRESET+1)). IN THIS -C CASE TOO, UPDATE NRESET AND TIMERESET. - -C CALL THESAME HERE TO ESTABLISH THE VALUE FOR ISAMERESET. IT -C WILL USED BELOW TO SUPPRESS INTERPOLATION OF COVARIATES ACROSS A -C TIME RESET. - - CALL THESAME(TIME,TIMADD*(NRESET+1),ISAMERESET) - - - IF(TIME .GE. TIMADD*(NRESET+1)) THEN - -C TIME IS AT OR PAST THE NEXT MULTIPLE OF TIMADD (I.E., IT IS A TIME -C RESET POINT). IN THIS CASE, INCREASE NRESET BY 1 AND RECALCULATE -C TIMERESET. - - NRESET = NRESET + 1 - TIMERESET = TIMADD*NRESET - -C FOR THIS TIME RESET, CHECK TO SEE IF THE FIRST DOSE LINE WILL BE - -C A STEADY STATE DOSE EVENT. THE NO. OF STEADY STATE DOSE EVENTS IN -C THIS PATIENT'S FILE IS NSST(ISUB), AND THE NO. OF SUCH EVENTS THAT -C HAVE ALREADY BEEN WRITTEN TO FILE 33 IS NSSEVENTS-1 SO FAR. - - - - IF(NSSEVENTS .LE. NSST(ISUB)) THEN - -C THE NEXT STEADY STATE DOSE EVENT OCCURS AFTER RESET NO. -C DOSELINEST(ISUB,NSSEVENTS,100). CHECK TO SEE IF THIS VALUE IS -C THE SAME AS NRESET. IF SO, THIS RESET STARTS WITH A STEADY STATE -C LINE. - - XRESET = NRESET - - CALL THESAME(DOSELINEST(ISUB,NSSEVENTS,100),XRESET,ISAME) - - IF(ISAME .EQ. 1) THEN - -C FILL IN THE ENTRIES TO DOSELINE FOR THE STEADY STATE DOSE AT THE -C BEGINNING OF THIS DOSE RESET. - - -C THE FIRST ENTRY IN DOSELINST IS TIMEVENT = THE NEGATIVE OF THE - -C INTERDOSE INTERVAL. - - DOSELINES(1) = DOSELINEST(ISUB,NSSEVENTS,1) - NENTRY = 1 - -C FOR EACH DRUG, THE IV AND TOTAL VALUES ARE ALREADY STORED INTO -C DOSELINEST(ISUB,NSSEVENTS,2*I) AND DOSELINEST(ISUB,NSSEVENTS,2*I+1), -C I=1,NDRUG. - - DO IDRUG = 1,NDRUG - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG) - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG+1) - END DO - -C FOR EACH COVARIATE, IF ANY, THE VALUES ARE STORED INTO -C DOSELINEST(ISUB,NSSEVENTS,19+ICOV), ICOV = 1,NCOVA. - - IF(NCOVA .GT. 0) THEN - DO ICOV = 1,NCOVA - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,19+ICOV) - END DO - ENDIF - - WRITE(33,1) (DOSELINES(J),J=1,NENTRY) - - NSSEVENTS = NSSEVENTS + 1 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NSSEVENTS .LE. NSST(ISUB)) CONDITION. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(TIME .GE. TIMADD*(NRESET+1)) CONDITION. - - - -C CHECK TO SEE IF ANY BOLUS TIMES = TIME. - - - DO IDRUG = 1,NDRUG - -C IF THE CURRENT INDEX FOR THIS BOLUS IS MORE THAN THE NO. -C OF ENTRIES IN THE CORRESPONDING ARRAY, IT MEANS THAT THERE ARE NO -C MORE BOLUS VALUES FOR THIS DRUG. IN THAT CASE, SET ITS TIME TO -99. -C OTHERWISE, SET ITS TIME TO THE NEXT TIME IN THE ARRAY. - - - - IF(INDBOL(IDRUG) .GT. NTIMBOL(ISUB,IDRUG)) TIMEB = -99.D0 - - IF(INDBOL(IDRUG) .LE. NTIMBOL(ISUB,IDRUG)) THEN - TIMEB = TIMBOL(ISUB,IDRUG,INDBOL(IDRUG)) - ENDIF - - CALL THESAME(TIME,TIMEB,ISAME) - - - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE -C "SAME" (I.E., WITHIN 1.D-10). IN THIS CASE, SET THE BOLUS VALUE FOR -C THIS EVENT TO THE CORRESPONDING VALUE IN BOLUS, AND INCREASE THE -C INDEX OF THE NEXT TIME BY 1. IF ISAME RETURNS AS 0, SET THE BOLUS -C VALUE = 0. - - IF(ISAME .EQ. 0) BOLVAL(IDRUG) = 0.D0 - - - IF(ISAME .EQ. 1) THEN - BOLVAL(IDRUG) = BOLUS(ISUB,IDRUG,INDBOL(IDRUG)) - INDBOL(IDRUG) = INDBOL(IDRUG) + 1 - ENDIF - - - END DO - - - -C CHECK TO SEE IF ANY COVARIATE TIMES = TIME. - - DO ICOV = 1,NCOVA - -C IF THE CURRENT INDEX FOR THIS COVARIATE IS MORE THAN THE NO. -C OF ENTRIES IN THE CORRESPONDING ARRAY, IT MEANS THAT THERE ARE NO -C MORE COV VALUES FOR THIS COVARIATE. IN THAT CASE, SET ITS TIME TO -C -99. OTHERWISE, SET ITS TIME TO THE NEXT TIME IN THE ARRAY. - - - - IF(INDCOV(ICOV) .GT. NTIMCOV(ISUB,ICOV)) TIMEC = -99.D0 - - IF(INDCOV(ICOV) .LE. NTIMCOV(ISUB,ICOV)) THEN - TIMEC = TIMCOV(ISUB,ICOV,INDCOV(ICOV)) - ENDIF - - CALL THESAME(TIME,TIMEC,ISAME) - - - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE -C "SAME" (I.E., WITHIN 1.D-10). IN THIS CASE, SET THE COVARIATE VALUE -C FOR THIS EVENT TO THE CORRESPONDING VALUE IN COV, AND INCREASE THE -C INDEX OF THE NEXT TIME BY 1. - - - IF(ISAME .EQ. 1) THEN - COVVAL(ICOV) = COV(ISUB,ICOV,INDCOV(ICOV)) - INDCOV(ICOV) = INDCOV(ICOV) + 1 - ENDIF - - -C IF ISAME RETURNS AS 0, THE COV. VALUE WILL BE THE SAME AS IT WAS -C PREVIOUSLY IF ICOVTYPE(ICOV) = 1 OR 0 (I.E., IF THIS IS A PIECEWISE -C CONTINOUS COVARIATE). IT WILL ALSO BE THE SAME AS IT WAS PREVIOUSLY -C IF ICOVTYPE(ICOV) = 2 (I.E., FOR A LINEARLY INTERPOLATED COVARIATE) -C IF TIMEC = -99, OR IF ISAMERESET = 1. HERE IS WHY: - -C TIMEC = -99 --> THERE ARE NO MORE COVARIATE VALUES (SEE ABOVE). -C IF ISAMERESET = 1, THEN THIS IS A TIME RESET POINT. AND IN THIS CASE, -C EVEN AN INTERPOLATED COVARIATE VALUE SHOULD BE SET = ITS LAST VALUE -C FROM BEFORE THE RESET, SINCE NO INTERPOLATION IS POSSIBLE FOR OUT OF -C ORDER TIMES (E.G., (T,COV) = (24,400), FOLLOWED BY (T,COV) = -C (20,1000) --> INTERPOLATED VALUE AT 0 WOULD BE: -C (0-24)/(20-24) * (1000 - 400) + 400 = 4000, WHICH IS PREPOSTEROUS). - - - IF(ISAME .EQ. 0) THEN - -C SET INTERP = 1, WHICH MEANS THAT THIS COVARIATE VALUE SHOULD BE -C INTERPOLATED FROM THE TWO SURROUNDING COVARIATE VALUES (WHICH HAVE -C BEEN EXPLICITLY SPECIFIED IN THE BLOCK FORMAT FILE). CHANGE INTERP -C TO 0 IF THIS IS NOT AN INTERPOLATED COVARIATE (ICOVTYPE(ICOV) = 1 -C OR 0) OR IF THIS IS AN INTERPOLATED COVARIATE BUT THERE ARE NO MORE -C COVARIATE VALUES FOR THIS COVARIATE (TIMEC = -99) OR IF THIS IS A -C TIME RESET VALUE (ISAMERESET = 1), OR IF THE CURRENT COVARIATE TIME - -C (WHICH WOULD BE USED IN THE INTERPOLATION) IS AT OR PAST THE NEXT -C TIME RESET. - - - INTERP = 1 - - IF(ICOVTYPE(ICOV) .EQ. 1 .OR. ICOVTYPE(ICOV) .EQ. 0) - 1 INTERP = 0 - IF(TIMEC .LE. -99) INTERP = 0 - IF(ISAMERESET .EQ. 1) INTERP = 0 - IF(TIMEC .GE. TIMERESET + TIMADD) INTERP = 0 - - -C IF INTERP = 1: - -C NOTE THAT INDCOV(ICOV) MUST BE .GE. 2 UNLESS THE USER HAS MADE A -C MISTAKE SINCE THE FIRST TIME (TIME = 0) IS SUPPOSED TO HAVE ALL -C COVARIATE VALUES SPECIFIED, WHICH MEANS THE FIRST TIME THROUGH THIS -C PART OF THE CODE ABOVE, INDCOV(ICOV) WAS INCREASED BY 1 (FROM ITS -C ORIGINAL VALUE OF 1). IF THIS IS NOT TRUE, WRITE A MESSAGE TO THE -C USER AND STOP. - - - IF(INDCOV(ICOV) .EQ. 1) THEN - - - - WRITE(*,111) ICOV - 111 FORMAT(/' THERE IS A MISTAKE IN THE BLOCK FORMAT PATIENT'/ - 1' DATA FILE. THE FIRST VALUE FOR COVARIATE NO. ',I2,' WAS NOT'/ - 2' SPECIFIED AT THE ORIGINAL TIME = 0, AS IS REQUIRED. PLEASE'/ - 3' FIX THIS ERROR AND RERUN THE PROGRAM. '//) - WRITE(*,401) ISUB,SUBID - 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,111) ICOV - WRITE(47,401) ISUB,SUBID - CLOSE(47) - - - - CALL PAUSE - STOP - - - - - ENDIF - - - CLAST = COV(ISUB,ICOV,INDCOV(ICOV)-1) - - - IF(INTERP .EQ. 0) COVVAL(ICOV) = CLAST - - IF(INTERP .EQ. 1) THEN - - -C NOTE: THE LAST COV. VALUE WAS CLAST WHICH OCCURRED AT TLAST. THE NEXT - -C COV VALUE IS CNEXT WHICH OCCURS AT TNEXT. SO ESTABLISH THE -C LINEARLY INTERPOLATED VALUE FOR THIS TIME, TIME. NOTE THAT THE TIMES, - -C TLAST AND TNEXT, MUST BE RECAST AS THEIR ACTUAL TIMES (BY REDUCING -C THEM BY TIMERESET) FIRST. - - TLAST = TIMCOV(ISUB,ICOV,INDCOV(ICOV)-1) - TIMERESET - - CNEXT = COV(ISUB,ICOV,INDCOV(ICOV)) - TNEXT = TIMCOV(ISUB,ICOV,INDCOV(ICOV)) - TIMERESET - TIMEREAL = TIME - TIMERESET - COVVAL(ICOV) = (TIMEREAL-TLAST)/(TNEXT-TLAST) * (CNEXT-CLAST) - 1 + CLAST - ENDIF - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 0) CONDITION. - - - - END DO - - -C THE ABOVE END DO IS FOR THE DO ICOV = 1,NCOVA LOOP. - - -C CHECK TO SEE IF ANY IV TIMES = TIME. - - DO IDRUG = 1,NDRUG - -C IF THE CURRENT INDEX FOR THIS IV IS MORE THAN THE NO. -C OF ENTRIES IN THE CORRESPONDING ARRAY, IT MEANS THAT THERE ARE NO -C MORE IV VALUES FOR THIS DRUG. IN THAT CASE, SET ITS TIME TO -99. -C OTHERWISE, SET ITS TIME TO THE NEXT TIME IN THE ARRAY. - - IF(INDIV(IDRUG) .GT. NTIMIV(ISUB,IDRUG)) TIMEI = -99.D0 - - IF(INDIV(IDRUG) .LE. NTIMIV(ISUB,IDRUG)) THEN - TIMEI = TIMIV(ISUB,IDRUG,INDIV(IDRUG)) - ENDIF - - CALL THESAME(TIME,TIMEI,ISAME) - - - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE -C "SAME" (I.E., WITHIN 1.D-10). IN THIS CASE, SET THE IV VALUE FOR -C THIS EVENT TO THE CORRESPONDING VALUE IN RATEIV, AND INCREASE THE -C INDEX OF THE NEXT TIME BY 1. IF ISAME RETURNS AS 0, THE IV VALUE -C WILL REMAIN WHAT IT WAS PREVIOUSLY. - - - - IF(ISAME .EQ. 1) THEN - XIVVAL(IDRUG) = RATEIV(ISUB,IDRUG,INDIV(IDRUG)) - INDIV(IDRUG) = INDIV(IDRUG) + 1 - - ENDIF - - END DO - - -C PUT THE ACTUAL TIME (I.E., TIME - TIMERESET) INTO THE 1ST ENTRY FOR -C THIS ROW. THEN PUT IN THE IV/BOLUS VALUES FOR EACH OF THE NDRUG DRUGS -C IN ORDER; THEN ALL ADDITIONAL COV. VALUES. - - DOSELINE(ITIM,1) = TIME - TIMERESET - NENTRY = 1 - - DO IDRUG = 1,NDRUG - NENTRY = NENTRY+1 - DOSELINE(ITIM,NENTRY) = XIVVAL(IDRUG) - NENTRY = NENTRY+1 - DOSELINE(ITIM,NENTRY) = BOLVAL(IDRUG) - END DO - - DO ICOV = 1,NCOVA - NENTRY = NENTRY+1 - DOSELINE(ITIM,NENTRY) = COVVAL(ICOV) - END DO - - WRITE(33,1) (DOSELINE(ITIM,J),J=1,NENTRY) - 1 FORMAT(43(G19.9,1X)) - - 1000 CONTINUE - -C THE ABOVE LABEL IS THE END OF THE DO 1000 ITIM = 1,NTIMI LOOP. - - - -C NOW CHECK TO SEE IF THE DOSAGE REGIMEN ENDS WITH ONE OR MORE STEADY -C STATE EVENTS. NOTE THAT THERE ARE NSST(ISUB) STEADY STATE EVENTS, -C AND NSSEVENTS - 1 OF THESE HAVE BEEN WRITTEN TO THE WORKING COPY FILE - -C SO FAR. - - 1010 CONTINUE - - - IF(NSSEVENTS .LE. NSST(ISUB)) THEN - - -C THE NEXT STEADY STATE DOSE EVENT OCCURS AFTER RESET NO. -C DOSELINEST(ISUB,NSSEVENTS,100). - -C FILL IN THE ENTRIES TO DOSELINE FOR THE STEADY STATE DOSE AT THE -C BEGINNING OF THIS DOSE RESET. - - -C THE FIRST ENTRY IN DOSELINST IS TIMEVENT = THE NEGATIVE OF THE -C INTERDOSE INTERVAL. - - DOSELINES(1) = DOSELINEST(ISUB,NSSEVENTS,1) - NENTRY = 1 - -C FOR EACH DRUG, THE IV AND TOTAL VALUES ARE ALREADY STORED INTO -C DOSELINEST(ISUB,NSSEVENTS,2*I) AND DOSELINEST(ISUB,NSSEVENTS,2*I+1), - -C I=1,NDRUG. - - DO IDRUG = 1,NDRUG - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG) - - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,2*IDRUG+1) - END DO - - -C FOR EACH COVARIATE, IF ANY, THE VALUES ARE STORED INTO -C DOSELINEST(ISUB,NSSEVENTS,19+ICOV), ICOV = 1,NCOVA. - - IF(NCOVA .GT. 0) THEN - DO ICOV = 1,NCOVA - NENTRY = NENTRY+1 - DOSELINES(NENTRY) = DOSELINEST(ISUB,NSSEVENTS,19+ICOV) - END DO - ENDIF - - WRITE(33,1) (DOSELINES(J),J=1,NENTRY) - - NSSEVENTS = NSSEVENTS + 1 - - GO TO 1010 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NSSEVENTS .LE. NSST(ISUB)) CONDITION. - - - -C----------------- WRITE THE DOSE EVENTS ABOVE ------------------------- - - -C----------------- WRITE THE OBSERVATION EVENTS BELOW ------------------ - - - - - WRITE(33,106) NOUT - 106 FORMAT(/' ',I1,' ... NO. OF TOTAL OUTPUT EQUATIONS') - - -C EACH SET OF TIMES FOR EACH OUTPUT EQUATION, TIMOUT(ISUB,IOUT,I), -C I = 1,NTIMOUT(ISUB,IOUT), IS IN ORDER, BUT EACH TIME HAS ADDED -C TO IT TIMADD*NRESET, WHERE NRESET IS THE NO. OF TIME RESETS UP TO -C AND TIME. - -C CALL FIXOUTIM TO OBTAIN NTIMORD, TIMORD, AND BLOCKOUT, WHERE -C NTIMORD IS THE TOTAL NO. OF UNIQUE TIMES TO BE PUT INTO THE -C OBSERVATION BLOCK; TIMORD(.) IS THE ORDERED ACTUAL TIMES (I.E., EACH -C OF THE TIMES IN TIMOUT(.,.,.) HAS BEEN REDUCED BY TIMADD*NRESET - SEE -C ABOVE), EXCEPT THAT EACH TIME OF 0 IS NOT ORDERED (IT INDICATES THE -C NEXT TIME RESET) FOR THE OBSERVATION BLOCK; AND BLOCKOUT IS THE - -C CORRESPONDING ARRAY OF OBSERVED VALUES FOR THE NOUT OUTPUT EQUATIONS -C AT THE TIMES IN TIMORD. - - - CALL FIXOUTIM(MAXSUB,ISUB,SUBID,NOUT,NTIMOUT,TIMOUT,OUT,NTIMORD, - 1 TIMORD,BLOCKOUT,TIMADD) - - WRITE(33,62) NTIMORD - 62 FORMAT(' ',I3,' ... NO. OF OBSERVED VALUE TIMES') - - DO I = 1,NTIMORD - WRITE(33,63) TIMORD(I),(BLOCKOUT(I,J),J=1,NOUT) - 63 FORMAT(7(G16.8,1X)) - - END DO - - - -C----------------- WRITE THE OBSERVATION EVENTS ABOVE ------------------ - - - -C----------------- WRITE THE BOTTOM OF FILE BELOW ---------------------- - - WRITE(33,303) - 303 FORMAT(/' COVARIATE NAMES AND VALUES (1ST, LAST, AND MEAN) FOLLO - 1W:') - -C FOR NOW, THE MEAN VALUE OF EACH COV. WILL BE -99 ... UNTIL WE DECIDE -C WHAT KIND OF MEAN WE WANT. E.G., IF A COV. = 100 AT T=0 AND -C 200 AT T = 10 AND 300 AT T = 11, WHICH IS THE LAST TIME, DO WE -C SIMPLY AVERAGE 100,200, AND 300, OR DO WE TAKE A WEIGHTED MEAN -C WHICH WOULD BE (100*10 + 200*1 + 300*0)/11, OR SOMETHING ELSE - - XMEAN = -99 - - DO ICOV = 1,NCOVA - WRITE(33,304) COVNAME(ICOV),COV(ISUB,ICOV,1), - 1 COV(ISUB,ICOV,NTIMCOV(ISUB,ICOV)),XMEAN - END DO - 304 FORMAT(A11,3X,3(F15.5,1X)) - - WRITE(33,306) - 306 FORMAT(/'ASSAY COEFFICIENTS FOLLOW, ONE SET FOR EACH OUTPUT EQUA - 1TION:') - - DO K = 1,NOUT - WRITE(33,3061) (CSUB(ISUB,I,K),I=1,4) - END DO - - 3061 FORMAT(4(F17.8,1X)) - - -C----------------- WRITE THE BOTTOM OF FILE ABOVE ---------------------- - - CLOSE(33) - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE THESAME(X1,X2,ISAME) - - - IMPLICIT REAL*8(A-H,O-Z) - -C THIS ROUTINE CHECKS TO SEE IF X1 AND X2 ARE VIRTUALLY THE SAME -C VALUES (I.E., IF THEY ARE WITHIN 1.D-10 OF EACH OTHER). IF SO, -C ISAME RETURNS AS 1; IF NOT ISAME RETURNS AS 0. - - ISAME = 0 - - XDEL = DABS(X1-X2) - IF(XDEL .LE. 1.D-10) ISAME = 1 - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE GETID(SUBID) - CHARACTER SUBID*11,SUB*11 - -C THIS ROUTINE IS CALLED TO REPLACE SUBID (WHICH HAS 11 CHARACTERS IN - -C IT) WITH THE CHARACTERS UP TO BUT NOT INCLUDING THE 1ST COMMA. - - - SUB = ' ' - DO I = 1,11 - IF(SUBID(I:I) .NE. ',') SUB(I:I) = SUBID(I:I) - IF(SUBID(I:I) .EQ. ',') GO TO 10 - END DO - - - - 10 SUBID = SUB - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE TIMESET(MAXSUB,ISUB,SUBID,NTIMALL,TIMALL,NTIMI, - 1 TIMI) - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION TIMALL(MAXSUB,72000),NTIMALL(MAXSUB),TIMI(72000), - 1 TIM(72000) - CHARACTER SUBID*11 - - - -C THIS ROUTINE IS CALLED BY READBLOCK2, TO ORDER ALL THE NTIMALL(ISUB) -C TIMES IN TIMALL(ISUB,.), ELIMINATING DUPLICATE TIMES. - -C RETURNED TO READBLOCK2 IS THE VECTOR TIMI, WITH NTIMI TIMES, -C ESTABLISHED AS INDICATED ABOVE. - - -C THE FIRST TIME IS TIMALL(ISUB,1) AND SHOULD BE 0. CHECK THIS FIRST. - - CALL THESAME(TIMALL(ISUB,1),0.D0,ISAME) - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, THE TIMES ARE THE -C "SAME" (I.E., WITHIN 1.D-10). OTHERWISE, THE TIMES ARE NOT THE -C SAME AND ISAME = 0. - -C STARTING WITH BESTDOS103A.FOR, DO NOT CHECK THAT THE FIRST DOSE TIME -C IN EACH PATIENT IS 0, SINCE THE FIRST TIME MAY BE NEGATIVE (WHICH - -C SIGNIFIES THE DOSAGE REGIMEN BEGINS WITH A STEADY STATE OF DOSES). - - -C IF(ISAME .EQ. 0) THEN - -C WRITE(*,1) ISUB,TIMALL(ISUB,1) -C 1 FORMAT(/' THE FIRST TIME IN THE DOSAGE BLOCK FOR SUBJECT ',I5, -C 1' IS NOT 0; IT IS ',G14.5// -C 2' THIS IS NOT ALLOWED. PLEASE SET THE FIRST TIME IN THE DOSAGE'/ -C 3' BLOCKS FOR ALL SUBJECTS TO BE 0, AND RERUN THE PROGRAM.') -C WRITE(*,401) ISUB,SUBID -C 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) -C CALL PAUSE -C STOP -C ENDIF - - - -C CALL SUBROUTINE PUTORDER TO ORDER THE NTIMALL(ISUB) VALUES IN - -C TIMALL(ISUB,.). - - DO I = 1,NTIMALL(ISUB) - TIM(I) = TIMALL(ISUB,I) - END DO - - CALL PUTORDER(NTIMALL(ISUB),TIM) - - -C THE NTIMALL(ISUB) VALUES ARE NOW ORDERED IN TIM. - - - - -C THE CODE BELOW BELOW WILL REMOVE DUPLICATE TIMES. - - - TIMELAST = -1.D39 - - NTIMI = 0 - - DO I = 1,NTIMALL(ISUB) - - TIME = TIM(I) - CALL THESAME(TIME,TIMELAST,ISAME) - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TIME = TIMELAST (OR AT -C LEAST, THEY ARE WITHIN 1.D-10), AND THIS TIME CAN BE IGNORED SINCE IT -C WAS ALREADY PUT INTO TIMI (ACTUALLY THE VALUE REDUCED BY TIMERESET) -C BY A PREVIOUS TIME. - - IF(ISAME .EQ. 1) GO TO 30 - -C TO GET HERE, ISAME = 0, WHICH MEANS THIS IS A NEW TIME. SO PUT -C TIME INTO TIMI. THEN SET TIMELAST = TIME AND CONTINUE THE LOOP. - - NTIMI = NTIMI + 1 - - TIMI(NTIMI) = TIME - TIMELAST = TIME - - 30 CONTINUE - - END DO - - - - - RETURN - END - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE PUTORDER(NX,XX) - -C SUBROUTINE PUTORDER IS CALLED BY SUBROUTINE TIMESET. IT INPUTS XX, A -C VECTOR OF SIZE, NX, AND RETURNS RETURNS XX, BUT WITH THE VALUES -C ORDERED FROM LOW TO HIGH. - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION XX(72000),Y(72000),IZ(72000),IZZ(72000) - - -C ORDER THE NX VALUES IN X AS FOLLOWS: - -C PUT THE NX VALUES INTO VECTOR Y TO START. -C INITIALIZE VECTOR IZ TO BE -99 IN ALL ITS NX LOCATIONS. THEN, FOR -C EXAMPLE, IF ENTRY 17 IS THE SMALLEST VALUE IN Y, IZ(17) WILL BE -C SET = 0, AND THE PROGRAM WILL KNOW NOT TO CHECK THE 17TH ENTRY -C AGAIN (SINCE IT HAS ALREADY BEEN SELECTED). IF THE NEXT SMALLEST -C ENTRY HAS INDEX 37, THEN IZ(37) WILL BE SET = 0, ETC. - - -C NOTE THAT IZZ WILL BE THE ARRAY WHICH CONTAINS THE ACTUAL ORDERING. -C IN THE EXAMPLE ABOVE, IZZ(1) = 17, IZZ(2) = 37. IT WILL BE EASY TO - - -C ASSIGN ORDERED VALUES BACK INTO XX USING IZZ. IN THE EXAMPLE ABOVE, -C XX(1) = Y(IZZ(1)) = Y(17), XX(2) = Y(IZZ(2)) = Y(37), ETC. - - DO I=1,NX - - Y(I) = XX(I) - IZ(I) = -99 - END DO - - - DO IPLACE = 1,NX - -C PUT THE NEXT LOWEST VALUE OF Y INTO THE IPLACE LOCATION OF -C IZZ. - - -C TEMP IS THE RUNNING VALUE OF THE NEXT VALUE TO BE PLACED INTO Y. -C INITIALIZE IT TO BE VERY HIGH VALUE SO THE FIRST VALUE Y WILL BE -C SURE TO BE LOWER THAN IT IS. - - TEMP = 1.D50 - - DO I=1,NX - - IF(Y(I) .LT. TEMP .AND. IZ(I) .EQ. -99) THEN - TEMP = Y(I) - IND = I - ENDIF - END DO - -C AT THIS POINT, IND IS THE INDEX OF THE SMALLEST REMAINING VALUE -C (TEMP) IN Y. PUT THIS INFORMATION INTO IZZ. ALSO, - -C SET IZ(IND) = 0 --> THE IND LOCATION IN Y HAS BEEN USED. - - IZZ(IPLACE) = IND - IZ(IND) = 0 - - END DO - - -C AT THIS POINT IZZ CONTAINS THE ORDERED INDICES (LOW TO HIGH) OF Y. - -C USE THIS TO RE-ESTABLISH X TO BE ORDERED LOW TO HIGH. - - DO I = 1,NX - - XX(I) = Y(IZZ(I)) - END DO - - - RETURN - END - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE FIXOUTIM(MAXSUB,ISUB,SUBID,NOUT,NTIMOUT,TIMOUT,OUT, - 1 NTIMORD,TIMORD,BLOCKOUT,TIMADD) - - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION TIMOUT(MAXSUB,MAXNUMEQ,650),NTIMOUT(MAXSUB,MAXNUMEQ), - 1 IENTRY(MAXNUMEQ),OUT(MAXSUB,MAXNUMEQ,650),TIMORD(3900), - 2 BLOCKOUT(3900,MAXNUMEQ) - - - CHARACTER SUBID*11,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C FIXOUTIM IS CALLED BY WRITEDOS TO ORDER THE OUTPUT TIMES AMONG ALL -C THE NOUT OUTPUT EQUATIONS. NOTE THAT EACH OF THE TIMES CURRENTLY IN -C TIMOUT HAS BEEN INCREASE BY TIMERESET = TIMADD*NRESET, WHERE NRESET -C IS THE NO. OF TIME RESETS UP TO AND INCLUDING THAT TIME (THIS WAS -C DONE IN SUBROUTINE READBLOCK2). - - -C RETURNED TO SUBROUTINE WRITEDOS ARE: - -C NTIMORD = NO. OF TIME VALUES IN TIMORD. - -C TIMORD(I), I=1,NTIMORD = THE ORDERED SET OF TIMES (EXCEPT FOR 0'S -C WHICH INDICATE A TIME RESET) OVER ALL THE NOUT TIME ARRAYS. - -C BLOCKOUT(I,J) = OBSERVED VALUE FOR IOUTPUT EQUATION J, FOR THE TIME -C VALUE, TIMORD(I), I=1,NEXT; J = I,NOUT. - - -C NOTE THAT EACH OF THE TIME ARRAYS, TIMOUT(ISUB,IOUT,.) HAS ITS OWN -C VALUES IN ORDER (THEY WERE FILLED IN ORDER IN READBLOCK2). NOW, -C ESTABLISH THE ARRAY, TIMORD, WHICH HAS THE ORDERED SET OF -C TIMES OVER ALL THE NOUT TIME ARRAYS. ALSO, REDUCE EACH TIME BY -C TIMRESET = NRESET*TIMADD TO RETURN EACH TIME TO ITS ORIGINAL VALUE. -C NOTE THAT THIS WILL HAVE THE EFFECT OF SETTING TO 0 THE TIMES WHICH -C ARE THE TIME RESET POINTS (THEIR ACCOMPANYING OUTPUT VALUES WILL -C OF COURSE BE SET TO -99). - -C INITIALIZE THE NEXT TIME TO BE PUT INTO TIMORD TO BE A LARGE NO. -C AND INITIALIZE THE INDEX OF THE NEXT ENTRY IN EACH OF THE TIMOUT -C ARRAYS TO BE 1. ALSO INITIALIZE INEXT TO BE 1. IT WILL BE THE -C RUNNING INDEX OF THE NEXT ENTRY TO BE PUT INTO TIMORD. - - DO IOUT = 1,NOUT - - IENTRY(IOUT) = 1 - END DO - - INEXT = 1 - - 20 TIMENEXT = 1.D50 - -C SET IANOTHER = 0. IF IT STAYS 0, THERE ARE NO MORE TIMES IN -C ANY OF THE ARRAYS. - - IANOTHER = 0 - - - DO IOUT = 1,NOUT - -C FOR OUTPUT EQUATION IOUT, IF IENTRY(IOUT) .LE. THE NO. OF ENTRIES -C IN THE TIME ARRAY FOR IOUT, THEN THIS ENTRY IS EQUATION IOUT'S -C CANDIDATE FOR THE NEXT LOWEST TIME. - - - IF(IENTRY(IOUT) .LE. NTIMOUT(ISUB,IOUT)) THEN - IANOTHER = 1 - - IF(TIMOUT(ISUB,IOUT,IENTRY(IOUT)) .LE. TIMENEXT) - - 1 TIMENEXT = TIMOUT(ISUB,IOUT,IENTRY(IOUT)) - ENDIF - - - END DO - -C IF IANOTHER = 0, ALL TIME ARRAY, AND CORRESPONDING OBSERVED, VALUES -C HAVE BEEN STORED, SO GO TO 100 TO RECAST TIMORD BEFORE RETURNING. - - IF(IANOTHER .EQ. 0) GO TO 100 - - -C AT THIS POINT, TIMENEXT IS THE NEXT LOWEST TIME OVER ALL THE NOUT -C TIMOUT ARRAYS. PUT IT INTO TIMORD, AND PUT THE CORRESPONDING ENTRIES -C FOR EACH OF THE NOUT OUTPUT EQUATIONS INTO THE ARRAY BLOCKOUT. ALSO, -C INCREASE THE ENTRY NO. FOR THE TIME ARRAY(S) WHICH HAD THIS TIME. -C BUT CHECK THAT THE NO. OF ENTRIES INTO TIMORD IS NOT > THE MAX, 3900. -C IF IT IS, STOP. - - IF(INEXT .GT. 3900) THEN - - WRITE(*,1) - 1 FORMAT(/' THE TOTAL NO. OF OBSERVATION TIMES IS GREATER THAN'/ - 1' THE MAXIMUM ALLOWABLE VALUE OF 3900 (SUBROUTINE FIXOUTIM).'/ - 2' RERUN THE PROGRAM AFTER REDUCING THE NO. OF OBS. TIMES.'/) - WRITE(*,401) ISUB,SUBID - 401 FORMAT(/' NOTE: THE ID FOR SUBJECT NO. ',I4,' IS ',A11/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,1) - WRITE(47,401) ISUB,SUBID - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - TIMORD(INEXT) = TIMENEXT - - DO IOUT = 1,NOUT - - BLOCKOUT(INEXT,IOUT) = -99.D0 - CALL THESAME(TIMENEXT,TIMOUT(ISUB,IOUT,IENTRY(IOUT)),ISAME) - - IF(ISAME .EQ. 1) THEN - BLOCKOUT(INEXT,IOUT) = OUT(ISUB,IOUT,IENTRY(IOUT)) - IENTRY(IOUT) = IENTRY(IOUT) + 1 - ENDIF - - END DO - - - - INEXT = INEXT + 1 - - GO TO 20 - - - 100 NTIMORD = INEXT - 1 - - -C NOW, RECAST TIMORD TO BE THE CORRECT TIME VALUES. RECALL THAT, -C CURRENTLY, EACH TIME HAS NRESET*TIMADD ADDED TO ITS VALUE WHERE -C NRESET IS THE NO. OF TIME RESET 0'S UP TO AND INCLUDING THAT TIME -C VALUE. - -C INITIALIZE NRESET = 0. THIS IS THE RUNNING NUMBER OF TIME RESETS -C THAT HAVE OCCURED. ALSO INITIALIZE TIMERESET AS THE CURRENT AMOUNT -C OF TIME TO SUBTRACT TO DO THE RECASTING. - - NRESET = 0 - TIMERESET = TIMADD*NRESET - - DO I = 1,NTIMORD - CALL THESAME(TIMORD(I),TIMADD*(NRESET+1),ISAME) - - IF(ISAME .EQ. 1) THEN - NRESET = NRESET + 1 - TIMERESET = TIMADD*NRESET - ENDIF - - TIMORD(I) = TIMORD(I) - TIMERESET - END DO - - - RETURN - - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE GETMAXTIM(NCOVA,TIMAX) - - - - IMPLICIT REAL*8(A-H,O-Z) - CHARACTER READLINE*1000 - - -C THIS SUBROUTINE IS CALLED BY READBLOCK2 TO GET TIMAX, THE MAXIMUM TIME -C OVER ALL SUBJECTS IN FILE 66. THIS MAXIMUM TIME INCLUDES THE ENDING -C TIME FOR ALL IV RATES. - -C GO THROUGH ALL THE ROWS OF THE BLOCK FORMAT FILE. READ THE EVENT -C TIMES IN ENTRY 3. IF THE ROW IS AN IV ROW, ADD THIS VALUE TO THE -C DURATION TIME IN ENTRY 4. THEN UPDATE TIMAX IF THIS TOTAL TIME IS -C > TIMAX, WHICH IS INITIALIZED BELOW TO BE NEGATIVE. - - - TIMAX = -1.D0 - - - 10 READ(66,1,IOSTAT=IEND) READLINE - 1 FORMAT(A1000) - IF(IEND .LT. 0) RETURN - - IF(READLINE(1:1) .EQ. '#' .OR. READLINE(1:2) .EQ. '"#') GO TO 10 - - CALL AFTERCOMMA(NCOVA,READLINE,2) - BACKSPACE(57) - READ(57,*) TIMEVENT - CLOSE(57) - - - CALL AFTERCOMMA(NCOVA,READLINE,3) - BACKSPACE(57) - - READ(57,*,ERR=15) TIMDUR - GO TO 20 - 15 TIMDUR = 0.D0 - 20 TIME = TIMEVENT + TIMDUR - CLOSE(57) - - IF(TIMAX .LT. TIME) TIMAX = TIME - GO TO 10 - - - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE GETCHAR2(JSUB,CHARSUB) - - CHARACTER CHARSUB*3 - CHARACTER*1 B,C,D - -C THIS ROUTINE, CALLED BY READBLOCK2, INPUTS THE INTEGER JSUB -C (BETWEEN 1 AND 999), AND OUTPUTS THE 3-CHARACTER EQUIVALENT, CHARSUB. - - ILEFT = JSUB - - I3 = ILEFT/100 - ILEFT = ILEFT - I3*100 - I2 = ILEFT/10 - ILEFT = ILEFT - I2*10 - I1 = ILEFT - -C CONVERT THIS TO THE CHARACTER EQUIVALENT. - - IF(I3 .EQ. 1) B='1' - IF(I3 .EQ. 2) B='2' - IF(I3 .EQ. 3) B='3' - IF(I3 .EQ. 4) B='4' - IF(I3 .EQ. 5) B='5' - IF(I3 .EQ. 6) B='6' - IF(I3 .EQ. 7) B='7' - IF(I3 .EQ. 8) B='8' - IF(I3 .EQ. 9) B='9' - IF(I3 .EQ. 0) B='0' - - IF(I2 .EQ. 1) C='1' - IF(I2 .EQ. 2) C='2' - IF(I2 .EQ. 3) C='3' - - IF(I2 .EQ. 4) C='4' - IF(I2 .EQ. 5) C='5' - IF(I2 .EQ. 6) C='6' - - IF(I2 .EQ. 7) C='7' - IF(I2 .EQ. 8) C='8' - IF(I2 .EQ. 9) C='9' - IF(I2 .EQ. 0) C='0' - - - IF(I1 .EQ. 1) D='1' - IF(I1 .EQ. 2) D='2' - - IF(I1 .EQ. 3) D='3' - IF(I1 .EQ. 4) D='4' - IF(I1 .EQ. 5) D='5' - IF(I1 .EQ. 6) D='6' - IF(I1 .EQ. 7) D='7' - IF(I1 .EQ. 8) D='8' - IF(I1 .EQ. 9) D='9' - IF(I1 .EQ. 0) D='0' - - - CHARSUB = B//C//D - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE NEWCSV - -C NEWCSV IS CALLED BY MAIN TO CONVERT THE .CSV FILE IN FILE 77 TO -C A NEW .CSV FILE IN FILE 67, WITH ALL MISSING VALUE DOTS CHANGED TO -C n's. THIS CODE IS BASED ON THE STAND-A-LONE PROGRAM NEWCSV.FOR. - -C IN PARTICULAR, THE FOLLOWING SEQUENCES WILL BE REPLACED AS SHOWN: - - -C ,., WILL BE REPLACED BY ,n, -C ,. WILL BE REPLACED BY ,n <-- THIS OCCURS AT END OF LINES. - - -C NOTE THAT THE SECOND SEQUENCE ABOVE IS COMMA/DOT/SPACE, NOT JUST -C COMMA/DOT SINCE WE DON'T WANT ,.35 REPLACED BY ,n35, FOR EXAMPLE. - - IMPLICIT REAL*8(A-H,O-Z) - CHARACTER READLINE*1000 - - -C WRITE EACH LINE OF FILE 77 TO FILE 67, BUT REPLACE ALL MISSING VALUE -C DOTS WITH n's. - - 10 READ(77,4,IOSTAT=IEND) READLINE - 4 FORMAT(A1000) - IF(IEND .LT. 0) GO TO 100 - -C FOR THIS LINE, READLINE, FIND IENDL, THE LAST CHARACTER WHICH IS NOT -C BLANK. THEN ONLY CHARACTERS 1:IENDL WILL BE WRITTEN TO FILEOUT. - - DO IENDL = 1000,1,-1 - IF(READLINE(IENDL:IENDL) .NE. ' ') GO TO 20 - END DO - - - 20 CONTINUE - - -C BEFORE WRITING READLINE(1:IENDL) TO FILE 22, GO THROUGH THE LINE AND -C REPLACE ANY DOTS WHICH REPRESENT MISSING VALUES WITH n's. - -C NOTE THAT, AS EXPLAINED ABOVE, THIS MEANS REPLACING AS FOLLOWS: -C ,., WILL BE REPLACED BY ,n, -C ,. WILL BE REPLACED BY ,n <-- THIS OCCURS AT END OF LINES. - - - - DO I = 1,IENDL-2 - IF(READLINE(I:I+2) .EQ. ',.,') READLINE(I:I+2) = ',n,' - - - END DO - - IF(READLINE(IENDL-1:IENDL) .EQ. ',.') - 1 READLINE(IENDL-1:IENDL) = ',n' - - -C CANNOT USE WRITE(67,4) READLINE(1:IENDL) SINCE, FOR SOME REASON, -C WRITING LIKE THIS "RIGHT JUSTIFIES" THE CHARACTERS AT THE END - -C OF THE A1000 FORMAT. INSTEAD MUST WRITE (67,__) READLINE, WHERE -C THE FORMAT IS DETERMINED BY THE LAST NON-BLANK CHARACTER (IENDL) -C IN READLINE. - - IF(IENDL .LE. 26) THEN - WRITE(67,26) READLINE - 26 FORMAT(A26) - GO TO 10 - ENDIF - - IF(IENDL .LE. 51) THEN - WRITE(67,51) READLINE - 51 FORMAT(A51) - GO TO 10 - ENDIF - - IF(IENDL .LE. 76) THEN - WRITE(67,76) READLINE - 76 FORMAT(A76) - GO TO 10 - ENDIF - - IF(IENDL .LE. 101) THEN - WRITE(67,101) READLINE - 101 FORMAT(A101) - GO TO 10 - ENDIF - - - IF(IENDL .LE. 126) THEN - WRITE(67,126) READLINE - 126 FORMAT(A126) - GO TO 10 - ENDIF - - IF(IENDL .LE. 151) THEN - WRITE(67,151) READLINE - 151 FORMAT(A151) - GO TO 10 - ENDIF - - IF(IENDL .LE. 176) THEN - WRITE(67,176) READLINE - 176 FORMAT(A176) - GO TO 10 - ENDIF - - IF(IENDL .LE. 201) THEN - WRITE(67,201) READLINE - 201 FORMAT(A201) - GO TO 10 - ENDIF - - IF(IENDL .LE. 226) THEN - - - WRITE(67,226) READLINE - 226 FORMAT(A226) - GO TO 10 - ENDIF - - IF(IENDL .LE. 251) THEN - WRITE(67,251) READLINE - 251 FORMAT(A251) - GO TO 10 - ENDIF - - IF(IENDL .LE. 276) THEN - - - WRITE(67,276) READLINE - - 276 FORMAT(A276) - - GO TO 10 - ENDIF - - IF(IENDL .LE. 301) THEN - WRITE(67,301) READLINE - 301 FORMAT(A301) - GO TO 10 - ENDIF - - IF(IENDL .LE. 326) THEN - WRITE(67,326) READLINE - 326 FORMAT(A326) - GO TO 10 - - ENDIF - - IF(IENDL .LE. 351) THEN - WRITE(67,351) READLINE - 351 FORMAT(A351) - - GO TO 10 - ENDIF - - IF(IENDL .LE. 376) THEN - WRITE(67,376) READLINE - 376 FORMAT(A376) - GO TO 10 - ENDIF - - IF(IENDL .LE. 401) THEN - - WRITE(67,401) READLINE - 401 FORMAT(A401) - - GO TO 10 - ENDIF - - - IF(IENDL .LE. 426) THEN - WRITE(67,426) READLINE - 426 FORMAT(A426) - GO TO 10 - ENDIF - - - IF(IENDL .LE. 451) THEN - WRITE(67,451) READLINE - 451 FORMAT(A451) - GO TO 10 - ENDIF - - IF(IENDL .LE. 476) THEN - WRITE(67,476) READLINE - - 476 FORMAT(A476) - GO TO 10 - ENDIF - - IF(IENDL .LE. 501) THEN - WRITE(67,501) READLINE - 501 FORMAT(A501) - GO TO 10 - ENDIF - - IF(IENDL .LE. 526) THEN - WRITE(67,526) READLINE - 526 FORMAT(A526) - GO TO 10 - ENDIF - - IF(IENDL .LE. 551) THEN - WRITE(67,551) READLINE - 551 FORMAT(A551) - GO TO 10 - ENDIF - - IF(IENDL .LE. 576) THEN - WRITE(67,576) READLINE - 576 FORMAT(A576) - GO TO 10 - ENDIF - - IF(IENDL .LE. 601) THEN - WRITE(67,601) READLINE - 601 FORMAT(A601) - - GO TO 10 - ENDIF - - - - - IF(IENDL .LE. 626) THEN - - WRITE(67,626) READLINE - 626 FORMAT(A626) - GO TO 10 - - - ENDIF - - IF(IENDL .LE. 651) THEN - WRITE(67,651) READLINE - 651 FORMAT(A651) - GO TO 10 - ENDIF - - IF(IENDL .LE. 676) THEN - WRITE(67,676) READLINE - 676 FORMAT(A676) - GO TO 10 - ENDIF - - - IF(IENDL .LE. 701) THEN - WRITE(67,701) READLINE - - - - 701 FORMAT(A701) - GO TO 10 - ENDIF - - IF(IENDL .LE. 726) THEN - - WRITE(67,726) READLINE - 726 FORMAT(A726) - GO TO 10 - ENDIF - - IF(IENDL .LE. 751) THEN - WRITE(67,751) READLINE - - 751 FORMAT(A751) - GO TO 10 - ENDIF - - IF(IENDL .LE. 776) THEN - WRITE(67,776) READLINE - 776 FORMAT(A776) - - GO TO 10 - ENDIF - - IF(IENDL .LE. 801) THEN - WRITE(67,801) READLINE - 801 FORMAT(A801) - GO TO 10 - ENDIF - - IF(IENDL .LE. 826) THEN - WRITE(67,826) READLINE - 826 FORMAT(A826) - - - - GO TO 10 - ENDIF - - IF(IENDL .LE. 851) THEN - WRITE(67,851) READLINE - - 851 FORMAT(A851) - GO TO 10 - - ENDIF - - - - - IF(IENDL .LE. 876) THEN - - - - WRITE(67,876) READLINE - 876 FORMAT(A876) - GO TO 10 - ENDIF - - IF(IENDL .LE. 901) THEN - - WRITE(67,901) READLINE - 901 FORMAT(A901) - GO TO 10 - - ENDIF - - - IF(IENDL .LE. 926) THEN - WRITE(67,926) READLINE - 926 FORMAT(A926) - GO TO 10 - ENDIF - - IF(IENDL .LE. 951) THEN - WRITE(67,951) READLINE - 951 FORMAT(A951) - GO TO 10 - ENDIF - - IF(IENDL .LE. 976) THEN - WRITE(67,976) READLINE - - 976 FORMAT(A976) - GO TO 10 - - ENDIF - - WRITE(67,4) READLINE - - GO TO 10 - - - 100 CLOSE(77) - REWIND(67) - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE EQUIV(INUM,NAME) - - CHARACTER*1 A,B,C,D - CHARACTER NAME*4 - -C THIS SUBROUTINE, CALLED BY MAIN, INPUTS INTEGER INUM, AND RETURNS THE -C 4-CHARACTER EQUIVALENT IN NAME. - - I4 = INUM/1000 - ILEFT = INUM - I4*1000 - I3 = ILEFT/100 - ILEFT = ILEFT - I3*100 - I2 = ILEFT/10 - ILEFT = ILEFT - I2*10 - - I1 = ILEFT - -C CONVERT THIS TO THE CHARACTER EQUIVALENT. - - IF(I4 .EQ. 1) A='1' - IF(I4 .EQ. 2) A='2' - IF(I4 .EQ. 3) A='3' - IF(I4 .EQ. 4) A='4' - - IF(I4 .EQ. 5) A='5' - IF(I4 .EQ. 6) A='6' - IF(I4 .EQ. 7) A='7' - IF(I4 .EQ. 8) A='8' - IF(I4 .EQ. 9) A='9' - IF(I4 .EQ. 0) A='0' - - IF(I3 .EQ. 1) B='1' - IF(I3 .EQ. 2) B='2' - IF(I3 .EQ. 3) B='3' - - - IF(I3 .EQ. 4) B='4' - IF(I3 .EQ. 5) B='5' - IF(I3 .EQ. 6) B='6' - IF(I3 .EQ. 7) B='7' - - IF(I3 .EQ. 8) B='8' - IF(I3 .EQ. 9) B='9' - - IF(I3 .EQ. 0) B='0' - - IF(I2 .EQ. 1) C='1' - IF(I2 .EQ. 2) C='2' - IF(I2 .EQ. 3) C='3' - IF(I2 .EQ. 4) C='4' - IF(I2 .EQ. 5) C='5' - IF(I2 .EQ. 6) C='6' - IF(I2 .EQ. 7) C='7' - IF(I2 .EQ. 8) C='8' - IF(I2 .EQ. 9) C='9' - IF(I2 .EQ. 0) C='0' - - IF(I1 .EQ. 1) D='1' - IF(I1 .EQ. 2) D='2' - IF(I1 .EQ. 3) D='3' - IF(I1 .EQ. 4) D='4' - IF(I1 .EQ. 5) D='5' - IF(I1 .EQ. 6) D='6' - - - - - IF(I1 .EQ. 7) D='7' - IF(I1 .EQ. 8) D='8' - IF(I1 .EQ. 9) D='9' - IF(I1 .EQ. 0) D='0' - - - NAME = A//B//C//D - - RETURN - END - - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE CONVERTCSV - IMPLICIT REAL*8(A-H,O-Z) - CHARACTER READLINE*1000,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C SUBROUTINE CONVERTCSV READS FILE 87 AND WRITES SCRATCH FILE 77. -C IF FILE 87 IS ALREADY IN THE TYPICAL "AMERICAN" .CSV FORMAT, -C FILE 77 IS THE SAME AS FILE 87. - -C IF FILE 87 IS IN THE "EUROPEAN" .CSV FORMAT, WHERE SEMICOLONS -C ARE THE FIELD SEPARATORS, AND COMMAS ARE USED TO SEPARATE THE -C WHOLE AND FRACTIONAL PARTS OF NUMBERS, IT WILL BE WRITTEN TO -C FILE 77 WITH THE INDICATED CHANGES BELOW. - - -C FILE 87 IS AT LINE 1. READ PAST THIS LINE TO READ LINE 2 AND CHECK -C FOR A SEMICOLON. IF ONE IS FOUND, THEN THIS IS A "EUROPEAN" VERSION OF -C A .CSV FILE. NOTE THAT IT IS ONLY NECESSARY TO CHECK THE FIRST FEW -C CHARACTERS OF THIS LINE - EITHER THERE WILL BE COMMAS OR SEMICOLONS. -C IF THERE ARE BOTH COMMAS AND SEMICOLONS, SOMETHING IS WRONG WITH THE -C FILE; IN THIS CASE, PRINT A MESSAGE TO THE USER AND STOP. -C NOTE THAT, EVEN IN THE "EURO" VERSION, IT WILL STILL BE ASSUMED THAT -C A DOT REPRESENTS AN UNNEEDED VALUE. - - READ(87,*) - READ(87,4) READLINE - - ICOMMA = 0 - ISEMICOLON = 0 - - DO I = 1,20 - IF(READLINE(I:I) .EQ. ',') ICOMMA = 1 - IF(READLINE(I:I) .EQ. ';') ISEMICOLON = 1 - END DO - -C IF ICOMMA = 1 AND ISEMICOLON = 0, NO CONVERSION IS NEEDED AS THIS -C FILE IS A TYPICAL .CSV FILE. IN THIS CASE SET ICONVERT = 0. - -C IF ICOMMA = 0 AND ISEMICOLON = 1, CONVERT THIS FILE AS FOLLOWS: -C a. CHANGE ALL COMMAS TO PERIODS; THEN -C b. CHANGE ALL SEMICOLONS TO COMMAS. - -C IN THIS CASE, SET ICONVERT = 1. - -C IF ICOMMA = 1 AND ISEMICOLON = 1, STOP THE PROGRAM WITH A MESSAGE TO -C THE USER. - - IF(ICOMMA .EQ. 1 .AND. ISEMICOLON .EQ. 1) THEN - - - - WRITE(*,121) - 121 FORMAT(/' YOUR .CSV FILE HAS BOTH COMMAS AND SEMICOLONS IN '/ - 1' THE SECOND LINE. THIS IS A CONFLICT. IF YOU ARE USING THE '/ - 2' "EUROPEAN" VERSION OF A .CSV FILE, WITH SEMICOLONS AS FIELD'/ - 3' SEPARATORS AND COMMAS TO SEPARATE THE WHOLE AND FRACTIONAL'/ - 4' PARTS OF NUMBERS, THERE SHOULD BE NO COMMAS IN THE SECOND'/ - 5' LINE.'// - 6' SIMILARLY IF YOU ARE USING THE "AMERICAN" VERSION OF A .CSV'/ - 7' FILE, WITH COMMAS AS FIELD SEPARATORS, AND PERIODS TO SEPARTE'/ - 8' THE WHOLE AND FRACTIONAL PARTS OF NUMBERS, THERE SHOULD BE NO'/ - 9' SEMICOLONS IN THE SECOND LINE.'// - 1' PLEASE CORRECT YOUR .CSV FILE AND RERUN THE PROGRAM.'//) - - OPEN(47,FILE=ERRFIL) - WRITE(47,121) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - IF(ICOMMA .EQ. 1 .AND. ISEMICOLON .EQ. 0) ICONVERT = 0 - - - IF(ICOMMA .EQ. 0 .AND. ISEMICOLON .EQ. 1) ICONVERT = 1 - - REWIND(87) - OPEN(77) - - -C COPY FILE 87 TO FILE 77 BUT MAKE THE INDICATED CHANGES, IF -C ICONVERT = 1, LINE BY LINE. - - 10 READ(87,4,IOSTAT=IEND) READLINE - 4 FORMAT(A1000) - IF(IEND .LT. 0) GO TO 100 - -C FOR THIS LINE, READLINE, FIND IENDL, THE LAST CHARACTER WHICH IS NOT -C BLANK. THEN ONLY CHARACTERS 1:IENDL WILL BE WRITTEN TO FILEOUT. - - DO IENDL = 1000,1,-1 - IF(READLINE(IENDL:IENDL) .NE. ' ') GO TO 20 - END DO - - 20 CONTINUE - - DO I = 1,IENDL - IF(ICONVERT .EQ. 1) THEN - IF(READLINE(I:I) .EQ. ',') READLINE(I:I) = '.' - IF(READLINE(I:I) .EQ. ';') READLINE(I:I) = ',' - ENDIF - - END DO - - -C CANNOT USE WRITE(77,4) READLINE(1:IENDL) SINCE, FOR SOME REASON, -C WRITING LIKE THIS "RIGHT JUSTIFIES" THE CHARACTERS AT THE END -C OF THE A1000 FORMAT. INSTEAD MUST WRITE (77,__) READLINE, WHERE -C THE FORMAT IS DETERMINED BY THE LAST NON-BLANK CHARACTER (IENDL) -C IN READLINE. - - IF(IENDL .LE. 26) THEN - WRITE(77,26) READLINE - 26 FORMAT(A26) - GO TO 10 - ENDIF - - - - IF(IENDL .LE. 51) THEN - WRITE(77,51) READLINE - - 51 FORMAT(A51) - GO TO 10 - ENDIF - - IF(IENDL .LE. 76) THEN - WRITE(77,76) READLINE - 76 FORMAT(A76) - GO TO 10 - - ENDIF - - IF(IENDL .LE. 101) THEN - - WRITE(77,101) READLINE - 101 FORMAT(A101) - - GO TO 10 - ENDIF - - - IF(IENDL .LE. 126) THEN - WRITE(77,126) READLINE - 126 FORMAT(A126) - GO TO 10 - ENDIF - - IF(IENDL .LE. 151) THEN - WRITE(77,151) READLINE - 151 FORMAT(A151) - GO TO 10 - ENDIF - - IF(IENDL .LE. 176) THEN - WRITE(77,176) READLINE - 176 FORMAT(A176) - GO TO 10 - ENDIF - - IF(IENDL .LE. 201) THEN - WRITE(77,201) READLINE - 201 FORMAT(A201) - GO TO 10 - ENDIF - - IF(IENDL .LE. 226) THEN - WRITE(77,226) READLINE - 226 FORMAT(A226) - GO TO 10 - - ENDIF - - IF(IENDL .LE. 251) THEN - WRITE(77,251) READLINE - 251 FORMAT(A251) - GO TO 10 - ENDIF - - - IF(IENDL .LE. 276) THEN - WRITE(77,276) READLINE - 276 FORMAT(A276) - - - GO TO 10 - - ENDIF - - IF(IENDL .LE. 301) THEN - WRITE(77,301) READLINE - 301 FORMAT(A301) - GO TO 10 - ENDIF - - IF(IENDL .LE. 326) THEN - WRITE(77,326) READLINE - - 326 FORMAT(A326) - - GO TO 10 - ENDIF - - IF(IENDL .LE. 351) THEN - WRITE(77,351) READLINE - - 351 FORMAT(A351) - GO TO 10 - ENDIF - - IF(IENDL .LE. 376) THEN - WRITE(77,376) READLINE - 376 FORMAT(A376) - GO TO 10 - ENDIF - - IF(IENDL .LE. 401) THEN - WRITE(77,401) READLINE - 401 FORMAT(A401) - GO TO 10 - ENDIF - - IF(IENDL .LE. 426) THEN - WRITE(77,426) READLINE - 426 FORMAT(A426) - GO TO 10 - ENDIF - - - IF(IENDL .LE. 451) THEN - WRITE(77,451) READLINE - 451 FORMAT(A451) - - GO TO 10 - ENDIF - - IF(IENDL .LE. 476) THEN - - - WRITE(77,476) READLINE - 476 FORMAT(A476) - GO TO 10 - - ENDIF - - IF(IENDL .LE. 501) THEN - WRITE(77,501) READLINE - 501 FORMAT(A501) - GO TO 10 - ENDIF - - - IF(IENDL .LE. 526) THEN - WRITE(77,526) READLINE - 526 FORMAT(A526) - GO TO 10 - ENDIF - - - IF(IENDL .LE. 551) THEN - - WRITE(77,551) READLINE - 551 FORMAT(A551) - GO TO 10 - - ENDIF - - IF(IENDL .LE. 576) THEN - WRITE(77,576) READLINE - 576 FORMAT(A576) - GO TO 10 - ENDIF - - IF(IENDL .LE. 601) THEN - WRITE(77,601) READLINE - 601 FORMAT(A601) - GO TO 10 - ENDIF - - IF(IENDL .LE. 626) THEN - WRITE(77,626) READLINE - - - 626 FORMAT(A626) - GO TO 10 - ENDIF - - IF(IENDL .LE. 651) THEN - WRITE(77,651) READLINE - 651 FORMAT(A651) - GO TO 10 - ENDIF - - IF(IENDL .LE. 676) THEN - WRITE(77,676) READLINE - 676 FORMAT(A676) - GO TO 10 - ENDIF - - IF(IENDL .LE. 701) THEN - WRITE(77,701) READLINE - 701 FORMAT(A701) - GO TO 10 - - ENDIF - - IF(IENDL .LE. 726) THEN - WRITE(77,726) READLINE - 726 FORMAT(A726) - GO TO 10 - ENDIF - - IF(IENDL .LE. 751) THEN - WRITE(77,751) READLINE - 751 FORMAT(A751) - GO TO 10 - ENDIF - - IF(IENDL .LE. 776) THEN - WRITE(77,776) READLINE - - 776 FORMAT(A776) - GO TO 10 - ENDIF - - IF(IENDL .LE. 801) THEN - WRITE(77,801) READLINE - - 801 FORMAT(A801) - GO TO 10 - - ENDIF - - IF(IENDL .LE. 826) THEN - WRITE(77,826) READLINE - - 826 FORMAT(A826) - GO TO 10 - ENDIF - - IF(IENDL .LE. 851) THEN - WRITE(77,851) READLINE - 851 FORMAT(A851) - GO TO 10 - ENDIF - - IF(IENDL .LE. 876) THEN - WRITE(77,876) READLINE - - 876 FORMAT(A876) - GO TO 10 - ENDIF - - IF(IENDL .LE. 901) THEN - WRITE(77,901) READLINE - 901 FORMAT(A901) - GO TO 10 - ENDIF - - IF(IENDL .LE. 926) THEN - WRITE(77,926) READLINE - 926 FORMAT(A926) - - GO TO 10 - ENDIF - - IF(IENDL .LE. 951) THEN - WRITE(77,951) READLINE - 951 FORMAT(A951) - - GO TO 10 - ENDIF - - - IF(IENDL .LE. 976) THEN - WRITE(77,976) READLINE - 976 FORMAT(A976) - GO TO 10 - - ENDIF - - WRITE(77,4) READLINE - GO TO 10 - - - - - 100 CLOSE(87) - REWIND(77) - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE CSVCHANGE - -C SUBROUTINE CSVCHANGE IS CALLED BY MAIN AND SUBROUTINE GETNUMEQ TO -C CHANGE .csv FILES WITH CODE OF POPDATA DEC_11 (I.E., THOSE WITH 2 -C EXTRA COLUMNS FOR ADDL AND II) TO EQUIVALENT .csv FILES WITH CODE OF -C POPDATA APR_11 (THOSE WITHOUT THE TWO EXTRA COLUMNS). IT READS -C FILE 67, AND WRITES THE INFORMATION TO SCRATCH FILE 66. NOTE THAT IF -C THE .csv FILE READ IN ALREADY IS THE OLDER VERSION (WITH CODE -C POPDATA APR_11), THIS ROUTINE SIMPLY REWRITES IT TO FILE 66, WHICH IS -C THEN READ BY SUBROUTINE READBLOCK. - -C THIS ROUTINE IS BASED ON THE STAND-A-LONE PROGRAM, CSVCHANGE.FOR. -C AS OF IT2B104.FOR, THIS ROUTINE IS BASED ON CSVCHANGE2.FOR. - -C CSVCHANGE.FOR 12/6/11 - -C THIS PROGRAM CONVERTS THE NEW-STYLE .csv FILES (WITH TWO ADDITIONAL -C COLUMNS (ADDL AND II) TO THE PREVIOUS .csv FORMAT. - -C ADDL GIVES THE NO. OF ADDITIONAL DOSES FOR ANY DOSE EVENT, AND II -C GIVES THE INTERDOSE INTERVAL FOR THE ADDITIONAL DOSES. - -C EX: IF TIME = 0, DUR = 2, DOSE = 1000, ADDL = 2, II = 12, THIS -C PROGRAM WOULD PUT IN TWO EXTRA LINES AS FOLLOWS: - -C TIME DUR DOSE ADDL II - -C 0 2 1000 2 12 <-- ONLY LINE IN NEW-STYLE FILE -C 12 2 1000 <-- THESE TWO LINES ARE ADDED TO THE OLD -C 24 2 1000 STYLE FILE (WHICH DOESN'T HAVE ADDL AND -C II COLUMNS. - -C NOTE THAT ADDL = -1 IS A STEADY STATE DOSE INDICATOR. IN THIS CASE, -C CHANGE THE TIME OF THE DOSE TO -II, SO SUBROUTINES READBLOCK/WRITEDOS -C WILL RECOGNIZE THE LINE AS THE BEGINNING OF A STEADY STATE DOSE SET. - -C NOTE THAT ONCE ALL THE ADDITIONAL DOSES ARE ADDED TO THE DOSE -C ARRAY, THEY MUST ALL BE ORDERED AMONG THEMSELVES (UNTIL THE NEXT -C DOSE/TIME RESET) SINCE READBLOCK EXPECTS ORDERED DOSES. BUT IT IS -C OK FOR ALL THE DOSES IN A GIVEN REGION TO COME FIRST, AND THEN ALL -C THE OBSERVATIONS TO FOLLOW (I.E., THE DOSES SHOULD BE ORDERED AMONG -C THEMSELVES AND THE OBSERVATIONS FOLLOW THE DOSES, ORDERED AMONG -C THEMSELVES). - -C NOTE THAT ADDL AND II ENTRIES ARE IGNORED IF EVID = 0 (I.E.,THE -C EVENT IS AN OBSERVATION). - -C NOTE THAT IF ADDL AND II ARE MISSING FOR A DOSE EVENT (EVID = 1 OR -C 4) THEN ADDL IS ASSUME TO BE 0 (NO ADDITIONAL DOSES) AND II IS -C IRRELEVANT. - - -C NOTE THAT THIS PROGRAM WILL OPEN AND READ THE NEW-STYLE .csv -C FILE FROM FILE 67, AND THEN WRITE THE PREVIOUS .csv FORMAT TO FILE -C 66. - - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION TIMENTRY(99999),IDENTRY(99999) - - CHARACTER READLINE*1000,CODEPAT*15, - 1 READLINE2*1000,HOLDMAT(99999)*150,TIMCHAR*50,SUBID*11, - 2 SUBIDPREV*11,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - - 1 FORMAT(A1000) - 2 FORMAT(A20) - - OPEN(66) - - ICODEPAT = 0 - - - 6 FORMAT(A15) - ICODEPAT = -1 - - - READ(67,6) CODEPAT - IF(CODEPAT .EQ. '"POPDATA DEC_11') ICODEPAT = 1 - IF(CODEPAT(1:14) .EQ. 'POPDATA DEC_11') ICODEPAT = 1 - - - - IF(CODEPAT .EQ. '"POPDATA APR_11') ICODEPAT = 0 - IF(CODEPAT(1:14) .EQ. 'POPDATA APR_11') ICODEPAT = 0 - - - IF(ICODEPAT .EQ. -1) THEN - - - - WRITE(*,7) - 7 FORMAT(//' YOUR PATIENT DATA BLOCK FILE IS NOT FROM THE'/ - 1' ALLOWABLE SET OF SUCH FILES.'// - 2' A PATIENT DATA BLOCK FILE MUST HAVE "POPDATA XXX_XX IN'/ - 3' COLUMNS 1 THROUGH 15 ON LINE 1, WHERE XXX_XX IS APR_11 OR A '/ - 4' MORE RECENT DATE.'//) - WRITE(*,*)' THE PROGRAM STOPS.' - - OPEN(47,FILE=ERRFIL) - WRITE(47,7) - WRITE(47,*)' THE PROGRAM STOPS.' - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - -C IF ICODEPAT = 0, THE INPUT .csv FILE IS ALREADY IN THE CORRECT FORM -C TO BE READ BY SUBROUTINE READBLOCK. IN THIS CASE, JUST COPY FILE 67, - - -C LINE BY LINE TO FILE 66. - - IF(ICODEPAT .EQ. 0) THEN - -C WRITE THE TOP LINE (WITH THE CODE) TO FILE 66. - - CODEPAT = 'POPDATA APR_11' - WRITE(66,6) CODEPAT - - 1020 READ(67,1,IOSTAT=IEND) READLINE - IF(IEND .LT. 0) THEN - CLOSE(67) - RETURN - ENDIF - WRITE(66,1) READLINE - GO TO 1020 - - ENDIF - - -C ICODEPAT = 1. SO WRITE THE INFO IN FILE 67 TO FILE 66 IN THE OLD -C FORMAT (WITHOUT THE TWO COLUMNS FOR ADDL AND II). - -C WRITE THE TOP LINE (WITH THE CODE) TO FILE 66. - - CODEPAT = 'POPDATA APR_11' - WRITE(66,6) CODEPAT - -C READ THE 2ND LINE OF FILE 67 AND WRITE THIS LINE TO FILE 66, BUT -C WITHOUT THE ADDL AND II NAMES. - - READ(67,1) READLINE - -C SEARCH FOR THE CHARACTER STRING ",ADDL,II" IN THE EARLY PART OF - -C READLINE AND ELIMINATE IT, BEFORE WRITING THE LINE TO FILE 66. IF -C THIS STRING IS NOT FOUND, TELL THE USER HIS FILE 67 HAS AN ERROR IN -C IT, AND STOP - - DO I = 1,50 - IF(READLINE(I:I+7) .EQ. ',ADDL,II') THEN - ISS = I - GO TO 10 - ENDIF - END DO - -C TO GET HERE MEANS THE ABOVE STRING WAS NEVER FOUND. SO WRITE A -C MESSAGE TO THE USER AND STOP. - - WRITE(*,8) - 8 FORMAT(//' YOUR PATIENT DATA BLOCK FILE IS NOT FROM THE '/ - - 1' ALLOWABLE SET OF SUCH FILES.'// - 2' A PATIENT DATA BLOCK FILE MUST HAVE ",ADDL,II" AS THE 6TH AND'/ - 3' 7TH COLUMN HEADINGS ON LINE 2.'//) - WRITE(*,*)' THE PROGRAM STOPS.' - - OPEN(47,FILE=ERRFIL) - WRITE(47,8) - WRITE(47,*)' THE PROGRAM STOPS.' - CLOSE(47) - - - - CALL PAUSE - STOP - - - 10 CONTINUE - -C PUT ALL OF READLINE, EXCEPT ENTRIES ISS:ISS+7 INTO READLINE2, -C AND WRITE READLINE2 INTO FILE 66. - - READLINE2(1:ISS-1) = READLINE(1:ISS-1) - - READLINE2(ISS:992) = READLINE(ISS+8:1000) - WRITE(66,1) READLINE2 - - - -C EACH LINE IN FILE 67, STARTING WITH LINE 3 (EXCEPT FOR LINES -C BEGINNING WITH #) HAS A SUBJECT ID IN THE 1ST 11 ENTRIES. THEN -C THE ENTRIES ARE, IN ORDER, EVID, TIME, DUR, DOSE, ADDL, II, INPUT, -C ... - -C READ EACH DOSE LINE (EVID = 1 OR 4) TO OBTAIN THE VALUES OF ADDL AND -C II FOR THOSE. ADDL IS THE NO. OF ADDITIONAL DOSE LINES THAT ARE -C IDENTICAL TO THE CURRENT LINE, AND II IS THE ASSOCIATED INTERDOSE - -C INTERVAL. IF ADDL = -1, THIS REPRESENTS A STEADY STATE SET OF DOSES. - -C FOR A DOSE LINE, IF ADDL = 0 OR IS MISSING (WHICH MEANS ADDL IS -C ASSUMED TO BE 0), WRITE THE LINE, WITHOUT THE ADDL AND II VALUES, -C INTO HOLDMAT. - -C FOR EACH DOSE LINE WITH AN ADDL > 0, WRITE THAT LINE -C WITHOUT THE ADDL AND II VALUES, AND ADDL MORE SIMILAR LINES INTO THE -C HOLDMAT, MAKING SURE THAT THE TIME FOR EACH SUCCESSIVE LINE -C IS INCREASED BY II FROM THE PREVIOUS LINE. - - -C NOTE THAT THE ABOVE PROCESS CAN CAUSE THE DOSE LINES TO BE OUT OF -C ORDER IN HOLDMAT. EACH BLOCK OF DOSE LINES WILL BE -C ORDERED UP TO THE NEXT DOSE/TIME RESET LINE BELOW. AND NOTE THAT -C ALL THE DOSES IN EACH REGION (UNTIL THE NEXT TIME RESET LINE - I.E., -C UNTIL THE NEXT EVID = 4) WILL BE WRITTEN TOGETHER, AND THEN BE -C FOLLOWED BY ALL THE OBSERVATION LINES IN THAT REGION). - - -C NOTE BELOW THAT AFTERCOMMA OPENS AND PUTS INTO FILE 57 THE PART OF -C READLINE WHICH IS BETWEEN COMMA C AND COMMA C+1, WHERE C IS THE 3RD -C ARGUMENT. ALSO,NOTE THAT NCOVA MUST BE PROVIDED TO AFTERCOMMA SO IT -C WILL KNOW THE TOTAL NO. OF COMMAS IN READLINE, WHICH = 13 + NCOVA -C SINCE THIS FILE HAS 14 FIXED FIELDS (COUNTING THE 2 NEWS ONES, -C ADDL AND II). -C -C SO, FIRST FIND NCOVA FROM READLINE JUST READ IN (THE 2ND LINE OF THE -C .csv FILE). - - NCOMMA = 0 - - DO ISTART = 1,1000 - IF(READLINE(ISTART:ISTART) .EQ. ',') THEN - NCOMMA = NCOMMA + 1 - ENDIF - END DO - - NCOVA = NCOMMA - 13 - -C INITIALIZE SUBIDPREV (THE PREVIOUS SUBJECT ID), AND THE CURRENT -C SUBJECT TO BE '%^&*'. - - SUBIDPREV = '%^&*' - SUBID = '%^&*' - NROW = 0 - - - -C NROW IS THE RUNNING INDEX OF THE NEXT LINE TO BE PUT INTO THE -C HOLDMAT. - - - 20 READ(67,1,IOSTAT=IEND) READLINE - - -C IF IEND .LT. 0, THE FILE HAS BEEN READ THROUGH COMPLETELY, SO GO TO -C LABEL 100 TO WRITE THE LAST SUBJECT'S ROWS TO FILE 66. - - IF(IEND .LT. 0) GO TO 100 - -C IF READLINE(1:1) IS #, THIS LINE IS A COMMENT LINE AND CAN BE -C SKIPPED (I.E., NOT WRITTEN INTO HOLDMAT). - - IF(READLINE(1:1) .EQ. '#') GO TO 20 - - -C WILL ALSO GO TO LABEL 100 IF THIS SUBJECT ID IS DIFFERENT THAN -C SUBIDPREV (SINCE THAT MEANS THAT THE PREVIOUS SUBJECT'S LINES ARE -C READY TO BE WRITTEN TO FILE 66). - - -C THE FIRST VALUE (I.E., AFTER COMMA NO. 0) IS THE SUBJECT ID. - - CALL AFTERCOMMA(NCOVA,READLINE,0) - BACKSPACE(57) - READ(57,222) SUBID - 222 FORMAT(A11) - CLOSE(57) - -C NOTE THAT SUBID CONTAINS THE 1ST 11 CHARACTERS OF THE LINE, BUT THE -C SUBJECT ID IS JUST THE SET OF CHARACTERS PRIOR TO THE 1ST COMMA. -C CALL SUBROUTINE GETID TO CORRECT THE VALUE OF SUBID. - - CALL GETID(SUBID) - - IF(SUBID .NE. SUBIDPREV) GO TO 100 - - -C TO GET TO THIS POINT, SUBID = SUBIDPREV, WHICH MEANS THIS IS A -C LINE FOR THE CURRENT SUBJECT. - -C IF THE EVENT ID, IN ENTRY NO. 2 (I.E., AFTER COMMA NO. 1) IN -C READLINE IS 0, THE LINE REPRESENTS AN OBSERVATION AND CAN BE WRITTEN -C INTO HOLDMAT, EXCEPT FOR ADDL AND II AS DONE ABOVE. - - CALL AFTERCOMMA(NCOVA,READLINE,1) - BACKSPACE(57) - READ(57,*) IDEVENT - - CLOSE(57) - - IF(IDEVENT .EQ. 0) THEN - NROW = NROW + 1 - CALL GETCOM(NCOMMA,READLINE,I5,I7) - HOLDMAT(NROW) = READLINE(1:I5)//READLINE(I7+1:150) - ENDIF - - -C IF THE EVENT ID IS 1 OR 4, THE LINE REPRESENTS A DOSE -C EVENT (1 -> REGULAR DOSE; 4 -> TIME RESET EVENT WITH A DOSE). EITHER -C WAY IF THE ENTRY FOR ADDL IS MISSING OR A 0, IT MEANS THAT THIS LINE -C REPRESENTS A SINGLE DOSE. IF ADDL > 0, THIS LINE MUST BE COPIED -C ADDL TIMES. NOTE THAT THE ADDL ENTRY IS NO. 6, AFTER COMMA NO. 5. - - IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) THEN - - CALL AFTERCOMMA(NCOVA,READLINE,5) - BACKSPACE(57) - READ(57,*,ERR=25) IADDL - CLOSE(57) - GO TO 30 - - 25 IADDL = 0 - -C TO GET TO LABEL 25 MEANS IADDL TRIED TO READ A NON-NUMBER, WHICH -C MEANS IT IS MISSING --> IT IS EQUIVALENT TO 0. IN THIS CASE, WRITE -C THE LINE INTO HOLDMAT, EXCEPT FOR IADDL AND II AS -C DONE ABOVE. - - 30 CONTINUE - - - IF(IADDL .GE. 0) THEN - NROW = NROW + 1 - CALL GETCOM(NCOMMA,READLINE,I5,I7) - HOLDMAT(NROW) = READLINE(1:I5)//READLINE(I7+1:150) - ENDIF - - IF(IADDL .GT. 0) THEN - - -C THIS LINE MUST BE COPIED IADDL TIMES, BUT EACH LINE MUST HAVE ITS -C TIME ENTRY INCREASED BY XII (THE INTERDOSE INTERVAL) FROM THE -C PREVIOUS LINE. FIRST FIND THE VALUE OF XII, IN THE 7TH ENTRY, AFTER -C THE 6TH COMMA. IF XII IS MISSING, STOP THE PROGRAM TELLING THE USER -C THAT THE .cvs FILE HAS AN ERROR; IT HAS A ROW WITH AN IADDL > 0, BUT -C WITH AN ACCOMPANYING INTERDOSE INTERVAL WHICH IS MISSING. NOTE THAT -C THIS LINE NO. IS 2 (THE TOP 2 LINES) + NROW + 1 = NROW + 3. - - - CALL AFTERCOMMA(NCOVA,READLINE,6) - BACKSPACE(57) - READ(57,*,ERR=35) XII - CLOSE(57) - GO TO 40 - - 35 WRITE(*,36) NROW + 3 - 36 FORMAT(/' THE INTERDOSE INTERVAL IS MISSING ON LINE NO. ',I6// - 1' PLEASE CORRECT YOUR .csv FILE AND RERUN THE PROGRAM.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,36) NROW + 3 - CLOSE(47) - - - - CALL PAUSE - STOP - - - 40 CONTINUE - - - -C THE TIME FOR THE ORIGINAL DOSE IS IN ENTRY NO. 3, AFTER COMMA NO. 2. - - CALL AFTERCOMMA(NCOVA,READLINE,2) - BACKSPACE(57) - READ(57,*) TIM - CLOSE(57) - - DO IADD = 1,IADDL - - -C NOTE THAT THE ORIGINAL LINE FOR THIS DOSE HAS ALREADY BEEN WRITTEN -C TO HOLDMAT (IN THE IF(IADDL .GE. 0) SECTION ABOVE). SO -C NOW MUST WRITE IADDL LINES TO HOLDMAT, EACH IDENTICAL TO -C THE CURRENT LINE, EXCEPT EACH TIM WILL BE INCREMENTED BY -C XII. TO DO THIS, WRITE THE NEXT TIM + XII TO SCRATCH FILE 57; THEN -C REREAD THIS VALUE AS A CHARACTER SO IT CAN BE INSERTED INTO -C THE CHARACTER STRING READLINE AND THEN WRITTEN TO THE HOLDING -C MATRIX. - -C ... AND ... - - -C BUG CORRECTION FOR BESTDOS106.FOR. EACH REPEATED ROW MUST HAVE -C IDEVENT SET = 1. I.E.,IF IDEVENT FOR THE ORIGINAL ROW (WHICH IS BEING -C REPEATED IADDL TIMES) IS 4, THIS IS A TIME RESET EVENT, BUT THE -C REPEATED ROWS WILL ALL HAVE IDEVENTS OF 1 (OTHERWISE IT WOULD LOOK -C LIKE REPEATED TIME RESET EVENTS WHICH IS NOT WHAT IS INTENDED). -C FOR EXAMPLE, IADDL = 3 IN AN IDEVENT = 4 LINE --> THE FIRST LINE IN -C FILE 66 SHOULD HAVE IDEVENT = 4, BUT THE NEXT TWO LINES MUST HAVE -C IDEVENT = 1 (I.E., THEY ARE REGULAR DOSE LINES THAT FOLLOW THE -C IDEVENT = 4 LINE AT TIME INTERVALS OF XII). - -C FIRST RESET READLINE TO HOLDMAT(NROW), WHICH DOES NOT HAVE THE -C ADDL AND II ENTRIES. - - READLINE(1:150) = HOLDMAT(NROW) - - OPEN(57,STATUS='SCRATCH') - WRITE(57,*) TIM + XII*IADD - BACKSPACE(57) - READ(57,41) TIMCHAR - 41 FORMAT(A50) - CLOSE(57) - -C TAKE OUT ALL SPACES AT THE END OF TIMCHAR. - - - DO IEND = 50,1,-1 - IF(TIMCHAR(IEND:IEND) .NE. ' ') GO TO 50 - - END DO - - 50 CONTINUE - - -C NOW TIMCHAR(1:IEND) IS THE CONDENSED FORM OF THE TIME FOR THIS -C ROW. REPLACE WHAT IS CURRENTLY BETWEEN COMMAS 2 AND 3 OF -C HOLDMAT(NROW) WITH THIS, AND STORE IT INTO THE NEXT ROW OF HOLDMAT. -C ALSO, DETERMINE I1 = CHARACTER NO. FOR COMMA 1, IN ORDER TO KNOW -C WHERE TO WRITE THE IDEVENT NO. WHICH WILL ALWAYS BE 1. - - ICOMMA = 0 - - DO I = 1,150 - IF(READLINE(I:I) .EQ. ',') THEN - ICOMMA = ICOMMA + 1 - IF(ICOMMA .EQ. 1) I1 = I - IF(ICOMMA .EQ. 2) I2 = I - IF(ICOMMA .EQ. 3) THEN - I3 = I - GO TO 60 - ENDIF - ENDIF - END DO - - 60 READLINE2 = - 1 READLINE(1:I1)//'1,'//TIMCHAR(1:IEND)//READLINE(I3:150) - NROW = NROW + 1 - HOLDMAT(NROW) = READLINE2(1:150) - - END DO - -C THE ABOVE END DO IS FOR THE DO IADD = 1,IADDL LOOP. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IADDL .GT. 0) CONDITION. - - - - IF(IADDL .EQ. -1) THEN - - -C WRITE JUST ONE LINE TO THE NEW .CSV FILE, EVEN THOUGH IADDL = -1 -C REPRESENTS A STEADY STATE DOSE SET OF 100 DOSES. MAKE THE TIME FOR -C THIS EVENT = -II SO READBLOCK/WRITEDOS WILL KNOW THIS IS A LINE WITH -C STEADY STATE DOSE INFO. - - CALL AFTERCOMMA(NCOVA,READLINE,6) - BACKSPACE(57) - READ(57,*,ERR=65) XII - CLOSE(57) - GO TO 70 - - 65 WRITE(*,36) NROW + 3 - - OPEN(47,FILE=ERRFIL) - WRITE(47,36) NROW + 3 - CLOSE(47) - - - - CALL PAUSE - STOP - - 70 CONTINUE - - - -C NOW ESTABLISH THE NEXT LINE OF HOLDMAT AS THE CURRENT -C READLINE, BUT WITHOUT THE ENTRIES FOR ADDL AND II; THEN RESET -C READLINE TO BE THIS NEW LINE. - - NROW = NROW + 1 - CALL GETCOM(NCOMMA,READLINE,I5,I7) - HOLDMAT(NROW) = READLINE(1:I5)//READLINE(I7+1:150) - READLINE(1:150) = HOLDMAT(NROW) - -C NOW ESTABLISH READLINE2 = READLINE, BUT WITH THE TIME VALUE RESET -C TO BE TIME = -XII. TO DO THIS, WRITE -XII TO SCRATCH FILE 57; THEN -C REREAD THIS VALUE AS A CHARACTER SO IT CAN BE INSERTED INTO -C THE CHARACTER STRING READLINE AND THEN WRITTEN TO THE HOLDING -C MATRIX. - - OPEN(57,STATUS='SCRATCH') - WRITE(57,*) -XII - BACKSPACE(57) - READ(57,41) TIMCHAR - - CLOSE(57) - -C TAKE OUT ALL SPACES AT THE END OF TIMCHAR. - - DO IEND = 50,1,-1 - IF(TIMCHAR(IEND:IEND) .NE. ' ') GO TO 80 - END DO - - 80 CONTINUE - - -C NOW TIMCHAR(1:IEND) IS THE CONDENSED FORM OF THE TIME FOR THIS -C ROW. REPLACE WHAT IS CURRENTLY BETWEEN COMMAS 2 AND 3 OF -C HOLDMAT(NROW) WITH THIS, AND STORE IT BACK INTO THE SAME ROW OF -C HOLDMAT. - - ICOMMA = 0 - - DO I = 1,150 - IF(READLINE(I:I) .EQ. ',') THEN - ICOMMA = ICOMMA + 1 - IF(ICOMMA .EQ. 2) I2 = I - - IF(ICOMMA .EQ. 3) THEN - I3 = I - GO TO 90 - ENDIF - ENDIF - END DO - - 90 READLINE2 = - 1 READLINE(1:I2)//TIMCHAR(1:IEND)//READLINE(I3:150) - HOLDMAT(NROW) = READLINE2(1:150) - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(IADDL .EQ. -1) CONDITION. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(IDEVENT .EQ. 1 .OR. IDEVENT .EQ. 4) CONDITION. - - - GO TO 20 - - - 100 CONTINUE - -C AS OF NPAG109.FOR, WRITE LINE TO THE SCREEN TELLING THE USER WHICH -C SUBJECT IS BEING CONVERTED, IN CASE THERE ARE A LARGE NO. OF PATIENTS -C WITH A LOT OF DATA. OTHERWISE, THERE COULD BE A LONG "DEAD" TIME ON -C THE SCREEN MAKING THE PROGRAM LOOK LIKE IT HAS "HUNG". - - - - WRITE(*,103) SUBID - 103 FORMAT(' EXAMINING .CSV FORMAT FOR SUBJECT ',A11) - - - -C THE FIRST TWO LINES OF FILE 66 WERE WRITTEN ABOVE. NOW WRITE THE -C REST OF THE FILE. - -C NOTE THAT IN EACH SECTION OF DOSES (I.E., UNTIL THE NEXT IDEVENT -C = 4), MUST ORDER THE DOSES SINCE THEY COULD BE OUT OF ORDER DUE TO -C THE ADDL ENTRY. - -C FOR EXAMPLE, A DOSE OF T = 0 WITH ADDL = 2 AND II = 12 --> DOSES AT -C T = 0, 12, AND 24. THEN ANOTHER DOSE (FOR A DIFFERENT DRUG, OR THE -C SAME DRUG WITH A DIFFERENT ROUTE) COULD OCCUR AT T = 8. THEN, FROM -C THE ABOVE CODE, THE CURRENT DOSE TIMES WOULD BE [0 12 24 8]. - -C SO GO THROUGH THE NROW ROWS OF HOLDMAT, AND ORDER THE ROWS IN EACH -C SECTION (I.E., UNTL THE NEXT IDEVENT = 4 ROW). IN PARTICULAR, FIRST -C ORDER THE DOSE ROWS (IDEVENT = 1). IF THESE ROWS FOLLOW AN -C IDEVENT = 4 ROW, THAT ROW GOES FIRST OF COURSE. THEN WRITE IN THE -C OBSERVATION ROWS (THEY SHOULD ALREADY BE IN ORDER). - -C PUT ALL THE IDEVENT ENTRIES IN HOLDMAT INTO IDENTRY(.), AND PUT ALL -C THE TIME ENTRIES IN HOLDMAT INTO TIMENTRY(.). - - DO I = 1,NROW - - READLINE(1:150) = HOLDMAT(I) - - CALL AFTERCOMMA(NCOVA,READLINE,1) - - BACKSPACE(57) - READ(57,*) IDEVENT - IDENTRY(I) = IDEVENT - - CLOSE(57) - - CALL AFTERCOMMA(NCOVA,READLINE,2) - BACKSPACE(57) - READ(57,*) TIM - TIMENTRY(I) = TIM - CLOSE(57) - - END DO - - - NN = 0 - NFIRST = 1 - -C NN IS THE RUNNING INDEX OF THE ROW IN HOLDMAT UNDER CONSIDERATION. - -C NFIRST IS THE RUNNING INDEX OF THE FIRST ROW IN THE NEXT SECTION - -C UNDER CONSIDERATION. - - 150 CONTINUE - - - -C ORDER ALL THE ROWS UNTIL THE NEXT IDENTRY(.) = 4, OR UNTIL THE -C END OF THE ROWS IS ENCOUNTERED, WHICHEVER COMES FIRST. - - NN = NN + 1 - IF(NN .GT. NROW) GO TO 200 - - IF(IDENTRY(NN) .NE. 4 .AND. NN .LT. NROW) GO TO 150 - -C ORDER THE ENTRIES IN HOLDMAT FROM NFIRST TO EITHER NROW -C (IF NN = NROW) OR TO NN-1 (IF IDENTRY(NN) = 4), AND THEN - - -C WRITE THEM INTO FILE 66. - - IF(NN .EQ. NROW) NLAST = NROW - IF(IDENTRY(NN) .EQ. 4) NLAST = NN - 1 - CALL ORDERHOLD(HOLDMAT,NFIRST,NLAST,IDENTRY,TIMENTRY) - - - 151 FORMAT(A150) - - - - DO I = NFIRST,NLAST - WRITE(66,151) HOLDMAT(I) - END DO - - - NFIRST = NLAST + 1 - - GO TO 150 - - - 200 CONTINUE - -C IF FILE 67 HAS BEEN COMPLETELY READ, RETURN. - - IF(IEND .LT. 0) THEN - CLOSE(67) - RETURN - - ENDIF - - -C SINCE IEND .GE. 0, THE FILE HAS NOT BEEN COMPLETELY READ. SO, RESET -C SUBIDPREV = SUBID AND NROW TO BE 0, AND BACKSPACE FILE 67 SINCE THE -C FIRST LINE FOR THE NEXT SUBJECT WAS ALREADY READ (I.E., THE NEXT -C READ OF FILE 67 SHOULD REREAD THIS FIRST LINE) AND GO BACK TO LABEL -C 20 TO CONTINUE READING THE FILE. - - - SUBIDPREV = SUBID - NROW = 0 - BACKSPACE(67) - GO TO 20 - - - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE GETCOM(NCOMMA,READLINE,I5,I7) - - CHARACTER READLINE*1000,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C GETCOM IS CALLED BY CVSCHANGE TO FIND THE ENTRY NO. FOR COMMA NO. 5 -C (I5), AND THE ENTRY FOR COMMA NO. 7 (I7). - - - 1 FORMAT(A1000) - - ICOMMA = 0 - - DO I = 1,300 - IF(READLINE(I:I) .EQ. ',') THEN - ICOMMA = ICOMMA + 1 - - IF(ICOMMA .EQ. 5) I5 = I - - IF(ICOMMA .EQ. 7) THEN - I7 = I - RETURN - ENDIF - ENDIF - END DO - -C TO GET TO THIS POINT MEANS THAT READLINE DOESN'T HAVE 7 COMMAS IN -C IT. REPORT THIS ERROR TO THE USER AND STOP. - - WRITE(*,2) NCOMMA,READLINE(1:70) - 2 FORMAT(/' ONE OF THE LINES IN YOUR .cvs FILE HAS AN ERROR.'/ - 1' IT IS SUPPOSED TO HAVE ',I2,' COMMAS, BUT IT HAS FEWER THAN'/ - 2' 7. THE FOLLOWING LINE SHOWS THE 1ST 70 CHARACTERS OF THE LINE:'/ - 3' ',A70// - 4' THE PROGRAM STOPS.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,2) NCOMMA,READLINE(1:70) - CLOSE(47) - - - - CALL PAUSE - STOP - - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE ORDERHOLD(HOLDMAT,NFIRST,NLAST,IDENTRY,TIMENTRY) - - IMPLICIT REAL*8(A-H,O-Z) - - DIMENSION TIMENTRY(99999),IDENTRY(99999),IZ(99999),IZZ(99999), - 1 DOSTIME(99999) - CHARACTER HOLDMAT(99999)*150,HOLDMAT2(99999)*150 - -C ORDER THE ENTRIES IN HOLDMAT FROM NFIRST TO NLAST, AS FOLLOWS: - -C 1. PUT ALL THE DOSE EVENTS (IDENTRY(.) = 1 OR 4) FIRST, ORDERED BY -C INCREASING TIMENTRY(.). - -C 2. PUT ALL THE OBSERVATION EVENTS (IDENTRY(.) = 0) AFTER THE DOSE -C EVENTS (THEY SHOULD ALREADY BE ORDERED). - - - -C FIRST, STORE THE DOSE ROWS FROM NFIRST TO NLAST IN HOLDMAT TO -C HOLDMAT2, STARTING AT ROW 1 IN HOLDMAT2. - -C ALSO, PUT ALL THE DOSE EVENTS TIMES INTO DOSTIME, AND INITIALIZE - -C VECTOR IZ TO BE -99 IN ALL ITS NDOSE LOCATIONS - - NDOSE = 0 - - DO I = NFIRST,NLAST - - IF(IDENTRY(I) .EQ. 1 .OR. IDENTRY(I) .EQ. 4) THEN - - NDOSE = NDOSE + 1 - - HOLDMAT2(NDOSE) = HOLDMAT(I) - DOSTIME(NDOSE) = TIMENTRY(I) - IZ(NDOSE) = -99 - ENDIF - END DO - -C NOW, FOR EXAMPLE, IF ENTRY 17 IS THE SMALLEST VALUE IN DOSTIME, -C IZ(17) WILL BE SET = 0, AND THE PROGRAM WILL KNOW NOT TO CHECK THE -C 17TH ENTRY AGAIN (SINCE IT HAS ALREADY BEEN SELECTED). IF THE NEXT -C SMALLEST ENTRY HAS INDEX 37, THEN IZ(37) WILL BE SET = 0, ETC. - -C NOTE THAT IZZ WILL BE THE ARRAY WHICH CONTAINS THE ACTUAL ORDERING. -C IN THE EXAMPLE ABOVE, IZZ(1) = 17, IZZ(2) = 37. IT WILL BE EASY TO -C ASSIGN ORDERED VALUES BACK INTO HOLDMAT USING IZZ. IN THE EXAMPLE -C ABOVE, HOLDMAT(1) WILL HAVE DOSE TIME = DOSTIME(IZZ(1)) = -C DOSTIME(17); HOLDMAT(2) WILL HAVE DOSE TIME = DOSTIME(IZZ(2)) = -C DOSTIME(37); ETC. - - -C NOW PUT THE OBSERVATION ROWS FROM NFIRST TO NLAST IN HOLDMAT TO -C HOLDMAT2, STARTING AT ROW NDOSE + 1 IN HOLDMAT2. - - NEXT = NDOSE - - DO I = NFIRST,NLAST - IF(IDENTRY(I) .EQ. 0) THEN - NEXT = NEXT + 1 - HOLDMAT2(NEXT) = HOLDMAT(I) - - ENDIF - END DO - - -C NOW ORDER THE FIRST NDOSE ROWS IN HOLDMAT2 ACCORDING TO THE DOSE -C TIMES, LOW TO HIGH. - - DO IPLACE = 1,NDOSE - -C PUT THE NEXT LOWEST VALUE OF DOSTIME INTO THE IPLACE LOCATION OF -C IZZ. - - -C TEMP IS THE RUNNING VALUE OF THE NEXT VALUE TO BE PLACED INTO -C DOSTIME. INITIALIZE IT TO BE VERY HIGH VALUE SO THE FIRST VALUE -C OF DOSTIME WILL BE SURE TO BE LOWER THAN IT IS. - - TEMP = 1.D50 - - DO I=1,NDOSE - - IF(DOSTIME(I) .LT. TEMP .AND. IZ(I) .EQ. -99) THEN - - TEMP = DOSTIME(I) - IND = I - ENDIF - END DO - - -C AT THIS POINT, IND IS THE INDEX OF THE SMALLEST REMAINING VALUE -C (TEMP) IN DOSTIME. PUT THIS INFORMATION INTO IZZ. ALSO, SET -C IZ(IND) = 0 --> THE IND LOCATION IN DOSTIME HAS BEEN USED. - - IZZ(IPLACE) = IND - IZ(IND) = 0 - - END DO - -C AT THIS POINT IZZ CONTAINS THE ORDERED INDICES (LOW TO HIGH) OF THE -C NDOSE VALUES IN DOSTIME, AND SO GIVES THE ORDER THAT THE NDOSE ROWS -C NOW IN HOLDMAT2 SHOULD BE WRITTEN. - -C WRITE THESE NDOSE DOSE ROWS IN THE CORRECT ORDER INTO HOLDMAT, AND -C THEN WRITE THE REMAINING ROWS (OBSERVATION ROWS) INTO HOLDMAT. - - DO IDOSE = 1,NDOSE - HOLDMAT(NFIRST-1+IDOSE) = HOLDMAT2(IZZ(IDOSE)) - END DO - -C STORE THE OBSERVATION ROWS INTO ENTRIES NFIRST + NDOSE,..., NLAST OF -C HOLDMAT. THEY WERE STORED INTO THE LAST NOBS ROWS OF HOLDMAT2 ABOVE. - - NEXT = NDOSE - - DO IOBS = NFIRST + NDOSE,NLAST - NEXT = NEXT + 1 - HOLDMAT(IOBS) = HOLDMAT2(NEXT) - END DO - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE MAKETMP(TNEXT,MAXOBDIM,ND42) - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION RS(34),YO(MAXNUMEQ),TIM41(594) - CHARACTER READLINE*1000,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - COMMON/TOCALCTP/M41,TIM41 - -C THIS SUBROUTINE, CALLED BY MAIN, READS WORKING COPY FILES 41 -C (TMPFILE1) AND 42 (TMPFILE2) AND MAKES ANOTHER WORKING COPY FILE, -C 43 (TMPFILE) WHICH HAS THE FOLLOWING CHARACTERISTICS: -C IT HAS ALL THE DOSES (BUT NOT THE OBSERVATIONS IN FILE 41). -C IT HAS ALL THE DOSES AND OBSERVATIONS IN FILE 42, BUT WITH EACH OF -C THE CORRESPONDING TIMES INCREASED BY TNEXT. - -C NOTE THAT THIS ROUTINE RETURNS ND42 (THE NO. OF DOSES IN FILE 42), -C WHERE THE DOSES TO BE OPTIMIZED OVER ARE ND41+1 TO ND IN FILE 42, -C WHERE ND41 + ND42 = ND. - - - 1 FORMAT(A1000) - -C WRITE ALL THE LINES FROM FILE 41 TO FILE 43, DOWN TO AND INCLUDING -C THE LINE WITH THE NO. OF DRUGS ON IT. - - 10 READ(41,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF DRUGS') THEN - WRITE(43,1) READLINE - GO TO 10 - ENDIF - - WRITE(43,1) READLINE - -C BACKSPACE AND READ THE NO. OF DRUGS FROM FILE 41, FOLLOWED BY THE -C NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE EVENTS. - - - BACKSPACE(41) - - 3 FORMAT(T2,I5) - READ(41,3) NDRUG41 - - - IF(NDRUG41 .GT. 7) THEN - - WRITE(*,124) NDRUG41 - 124 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ - 1' THE SUBJECT HAS ',I3,' DRUGS, MORE THAN THE ALLOWABLE 7.'// - 2' THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,124) NDRUG41 - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - READ(41,3) NADD41 - -C BACKSPACE FILE 41, AND WRITE THIS LINE (NO. OF ADDTIONAL COVS) TO -C FILE 43. - - BACKSPACE(41) - READ(41,1) READLINE - WRITE(43,1) READLINE - - -C NOW VERIFY THAT FILE 42 HAS THE SAME NO. OF DRUGS AND ADDITIONAL -C COVARIATES AS FILE 41. IF NOT, WRITE MESSAGE TO USER AND STOP. - - 20 READ(42,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 20 - -C BACKSPACE AND READ THE NO. OF DRUGS FROM FILE 42, FOLLOWED BY THE -C NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE EVENTS. - - BACKSPACE(42) - READ(42,3) NDRUG42 - - - IF(NDRUG42 .NE. NDRUG41) THEN - - WRITE(*,126) NDRUG41,NDRUG42 - 126 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ - 1' THE SUBJECT HAS ',I3,' DRUGS, BUT THE FILE WITH THE "FUTURE" '/ - 2' FOR THIS SUBJECT HAS ',I3,' DRUGS. THE NO. OF DRUGS MUST BE'/ - 3' THE SAME IN THESE TWO FILES. THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,126) NDRUG41,NDRUG42 - CLOSE(47) - - CALL PAUSE - STOP - - - ENDIF - -C VERIFY THAT THTE NO. OF DRUGS IS NOT .GT. 7. IF SO, WRITE MESSAGE - -C AND STOP. - - IF(NDRUG41 .GT. 7) THEN - - WRITE(*,123) - 123 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 7'/ - 1' DRUGS. THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,123) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - READ(42,3) NADD42 - - IF(NADD42 .NE. NADD41) THEN - - WRITE(*,127) NADD41,NADD42 - 127 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ - 1' THE SUBJECT HAS ',I3,' ADDITIONAL COVARIATES, BUT THE FILE'/ - 2' WITH THE "FUTURE" FOR THIS SUBJECT HAS ',I3,' ADDITIONAL'/ - 3' COVARIATES. THE NO. OF ADDITIONAL COVARIATES MUST BE THE SAME'/ - 4' IN THESE TWO FILES. THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,127) NADD41,NADD42 - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - -C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND -C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE -C BEYOND THE FIRST 4 ABOVE, AGE, SEX, HEIGHT, AND ETHNICITY FLAG). - - NI = 2*NDRUG41 + NADD41 - - - IF(NI .GT. 34) THEN - - WRITE(*,132) - 132 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY COLUMNS IN '/ - 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ - 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ - 3' NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,132) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - -C BOTH FILE 41 AND FILE 42 ARE AT THE LINE WHERE THE NO. OF DOSE -C EVENTS IS READ. HAVE EACH FILE READ THE NO. OF DOSE EVENTS, AND -C THEN ADD THEM TO GET THE NO. OF DOSE EVENTS FOR FILE 43. - - - READ(41,3) ND41 - READ(42,3) ND42 - ND = ND41 + ND42 - -C WRITE ND AS THE NO. OF DOSE EVENTS TO FILE 43, AFTER VERIFYING THAT -C THIS NO. IS .LE. 5000 (THE MAXIMUM ALLOWED). - - - IF(ND .GT. 5000) THEN - - WRITE(*,133) ND41,ND42 - 133 FORMAT(' THE PATIENT DATA FILE WHICH IS TO CONTAIN THE DOSES '/ - 1' FOR BOTH THE "PAST" HISTORY, AND THE "FUTURE" HAS MORE THAN'/ - 2' 5000 DOSES ... ',I4,' IN THE "PAST", AND ',I4,' IN THE '/ - 3' "FUTURE". THIS IS TOO MANY. THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,133) ND41,ND42 - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - WRITE(43,13) ND - 13 FORMAT(I6,' ... NO. OF DOSE EVENTS') - -C WRITE THE LINES DOWN TO "TIME, IV/PO,.." WHICH STARTS IN COL. 5 -C TO FILE 43. AND THEN WRITE THIS LINE TO FILE 43. - - 30 READ(41,1) READLINE - IF(READLINE(5:15) .NE. 'TIME, IV/PO') THEN - WRITE(43,1) READLINE - GO TO 30 - - ENDIF - - WRITE(43,1) READLINE - -C OF THE ND = ND41 + ND42 DOSE EVENTS, THE FIRST ND41 COME FROM -C FILE 41. WRITE THESE DOSE EVENTS TO FILE 43. - - DO I = 1,ND41 - READ(41,*) SIG,(RS(J),J=1,NI) - WRITE(43,*) SIG,(RS(J),J=1,NI) - END DO - -C AS OF BESTDOS119.FOR, MUST SAVE - -C WRITE THE LAST ND42 DOSE EVENTS (THOSE FROM FILE 42) TO FILE 43, - -C BUT INCREASE EACH TIME BY TNEXT. BUT FIRST READ FILE 42 DOWN TO -C WHERE THE DOSE EVENTS OCCUR. - - 60 READ(42,1) READLINE - IF(READLINE(5:15) .NE. 'TIME, IV/PO') GO TO 60 - - DO I = 1,ND42 - READ(42,*) SIG,(RS(J),J=1,NI) - WRITE(43,*) SIG + TNEXT,(RS(J),J=1,NI) - END DO - - -C ALL 3 FILES ARE AT THE END OF THEIR DOSE EVENTS. WRITE THE LINES -C DOWN TO THE LINE WITH THE TOTAL NO. OF OUTPUT EQS. TO FILE 43, -C INCLUDING THIS LINE. - - 40 READ(41,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') THEN - WRITE(43,1) READLINE - GO TO 40 - ENDIF - - WRITE(43,1) READLINE - -C BACKSPACE FILE 41 AND READ THE NO. OF OUTPUT EQS. - - BACKSPACE(41) - READ(41,3) NUMEQT41 - -C AS OF BESTDOS110.FOR, SAVE THE OBSERVED VALUE TIMES FROM THE -C "PAST" INTO AN ARRAY THAT WILL BE PROVIDED BY COMMON/TOCALCTP TO -C SUBROUTINE CALCTPRED. THESE VALUES ARE NOT NEEDED IN THE WRITING OF -C FILE 43 IN THIS ROUTINE, BUT THEY WILL BE NEEDED IN SUBROUTINE -C CALCTPRED. - - READ(41,3) M41 - - DO I = 1,M41 - READ(41,*) TIM41(I) - END DO - - -C READ THESE SAME VALUES FROM FILE 42. - - 50 READ(42,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 50 - BACKSPACE(42) - READ(42,3) NUMEQT42 - NUMEQT = NUMEQT42 - - READ(42,3) M42 - -C VERIFY THAT FILE 42 HAS THE SAME NO. OF OUTPUT EQS. AS FILE 41. -C IF NOT, WRITE A MESSAGE TO THE USER AND STOP. - - IF(NUMEQT42 .NE. NUMEQT41) THEN - - - - WRITE(*,128) NUMEQT41,NUMEQT42 - 128 FORMAT(' YOUR PATIENT DATA FILE WHICH HAS THE "PAST" HISTORY OF'/ - 1' THE SUBJECT HAS ',I3,' OUTPUT EQS., BUT THE FILE WITH THE'/ - 2' "FUTURE" FOR THIS SUBJECT HAS ',I3,' OUTPUT EQS. THE NO. OF'/ - 3' OUTPUT EQS. MUST BE THE SAME IN THESE TWO FILES. THE PROGRAM'/ - 4' IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,128) NUMEQT41,NUMEQT42 - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - - -C VERIFY THAT THE NO. OF OUTPUT EQS. IS NOT .GT. MAXNUMEQ. - - IF(NUMEQT41 .GT. MAXNUMEQ) THEN - - - - WRITE(*,129) MAXNUMEQ - 129 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY OUTPUT EQUATION'/ - 1' COLUMNS. THIS NO. CANNOT EXCEED ',I2,'. THE PROGRAM IS NOW '/ - 2' STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,129) MAXNUMEQ - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - -C NOTE THAT THE NO. OF OBSERVED VALUES IS M, WHICH -C FOR THIS PATIENT WILL BE M42 (I.E., ONLY THE OBSERVED VALUES FROM -C THE "FUTURE" WILL BE PUT INTO FILE 43). - - M = M42 - -C WRITE M AS THE NO. OF OBSERVED VALUE TIMES TO FILE 43, AFTER -C VERIFYING THAT THIS NO. IS .LE. MAXOBDIM (THE MAXIMUM ALLOWED). - - - IF(M .GT. MAXOBDIM) THEN - - - - WRITE(*,131) M,MAXOBDIM - 131 FORMAT(' THE PATIENT DATA FILE WHICH IS THE "FUTURE" OF THE '/ - 1' SUBJECT HAS ',I4,' OBSERVED VALUES, MORE THAN THE MAXIMUM'/ - 2' ALLOWED VALUE OF ',I4,'. THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,131) M,MAXOBDIM - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - -C WRITE THE LINE WITH THE NO. OF OBSERVED VALUE TIMES TO FILE 43. -C THEN WRITE THE M = M42 OBSERVED VALUES FROM FILE 42, ALONG WITH -C THE CORRESPONDING TIMES, BUT INCREASE EACH TIME BY TNEXT. - - WRITE(43,14) M - 14 FORMAT(I6,' ... NO. OF OBSERVED VALUE TIMES') - - DO I = 1,M - READ(42,*) TIM,(YO(J),J=1,NUMEQT) - WRITE(43,*) TIM + TNEXT,(YO(J),J=1,NUMEQT) - END DO - -C NOW COPY THE REST OF FILE 42 (WHICH INCLUDES THE COVARIATE NAMES, -C AND VALUES, AND THE ASSAY COEFFICIENTS) TO FILE 43. - - - 70 READ(42,1,IOSTAT=IEND) READLINE - IF(IEND .LT. 0) GO TO 100 - WRITE(43,1) READLINE - GO TO 70 - - 100 CLOSE(43) - CLOSE(42) - CLOSE(41) - - RETURN - END - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE INSPECTOBS(MAXOBDIM,IPRIOROBS) - -C INSPECTOBS IS CALLED BY MAIN TO READ FILE 21 AND RETURN 1 IF THERE -C ARE NON-MISSING OBSERVATIONS, AND 0 OTHERWISE. - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - DIMENSION YO(MAXOBDIM,MAXNUMEQ) - CHARACTER READLINE*1000 - - 1 FORMAT(A1000) - 3 FORMAT(T2,I5) - -C READ DOWN TO THE OBSERVATIONS ... TO THE LINE WITH -C 'NO. OF TOTAL' AS ENTRIES 12:23. - - 10 READ(21,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 10 - -C BACKSPACE AND READ THE NO. OF OUTPUT EQS. AND THEN READ THE -C NO. OF OBSERVED VALUE TIMES. - - BACKSPACE(21) - READ(21,3) NUMEQT - READ(21,3) M - - DO I = 1,M - READ(21,*) TIM,(YO(I,J),J=1,NUMEQT) - END DO - -C DEFAULT IPRIOROBS = 0. IT WILL CHANGE TO BE 1 IF ANY OF THE -C OBSERVED VALUES ARE NOT MISSING (I.E., NOT = -99). - -C NOTE THAT ISAME, RETURNED FROM CALL TO THESAME, IS 1 IF THE TWO -C ARGUMENTS ARE WITHIN 1.D-10 OF EACH OTHER (I.E., VIRTUALLY THE SAME -C VALUE); OTHERWISE IT RETURNS AS 0. - - IPRIOROBS = 0 - - DO I =1,M - DO J = 1,NUMEQT - CALL THESAME(YO(I,J),-99.D0,ISAME) - IF(ISAME .EQ. 0) IPRIOROBS = 1 - END DO - END DO - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C -C??? AFTER FINISHING THIS ROUTINE, WILL HAVE TO MODIFY CALCTPRED2 -CIN A SIMILAR WAY I THINK SINCE IT IS ALSO BASED ON FILD37, WHICH -CHAS STEADY STATE DOSE SETS POSSIBLE IN THE PAST. - - - - - SUBROUTINE CALCTPRED(IDELTA,NOBSER,TNEXT,NUMT,TPRED,TPREDREL) -C??? TPREDREL ADDED ABOVE. 7/4. - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION TPRED(72000),TIM(594),SIG(5000),RS(5000,34), - 1 BS(5000,7),YOO(594,MAXNUMEQ),TVECT(72000),TIM41(594), - 2 TPREDREL(72000) -C??? TPREDREL ADDED ABOVE. 7/4. - - COMMON/OBSER/ TIM,SIG,RS,YOO,BS - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/TOCALCTP/M41,TIM41 - -C??? EDITED COMMENTS BELOW. 7/4. -C AS OF BESTDOS119.FOR, THE LOGIC OF CALCTPRED FROM BESTDOS108.FOR -C IS PUT BACK INTO THIS ROUTINE. THAT LOGIC ALLOWED STEADY STATE -C DOSE SETS (AND TIME RESETS, ALTHOUGH THERE WILL BE NO TIME RESETS -C FOR THE TIME BEING AT LEAST). NOTE THERE CAN BE AT MOST 1 STEADY -C STATE DOSE SET, AND IT HAS TO BE AT THE BEGINNING OF THE PATIENT -C FILE IF IT OCCURS. - -C NOTE THAT THE LOGIC OF ADDING OBSERVATION AND DOSE TIMES TO THE -C REGULAR PREDICTED TIMES (WHICH ARE IDELTA/60 HOURS APART) IS -C TEMPORARILY REMOVED ... IT CAN BE PUT BACK IN AFTER VERIFYING THAT -C THE REGULAR PREDICTED TIMES GET PUT IN PROPERLY. - - -C THIS ROUTINE IS CALLED BY MAIN TO CALCULATE THE NUMT TIMES TO BE -C PUT INTO TPRED. THESE WILL BE THE REGULAR PREDICTED -C TIMES WHICH START AT 0, ARE IDELTA/60 HOURS APART, AND CONTINUE UNTIL -C 24 HOURS AFTER THE LAST OBSERVATION TIME, ALONG WITH ALL THE DOSE AND -C ALL THE OBSERVATION TIMES (REDUNDANT TIMES WILL BE IGNORED OF -C COURSE). <-- FOR NOW SKIP THE DOSE AND OBSERVATION TIMES. - -C NOTE THAT THE REGULAR TIMES ARE TO BE IDELTA MINUTES APART, SUBJECT -C TO THE CONSTRAINT THAT THE MAXIMUM NO. OF TIMES BE 72000. -C BUT NOTE BELOW THAT THE TIMES IN TPRED ARE IN HOURS, NOT MINUTES. -C AND NOTE IF A STEADY STATE DOSE SET OCCURS AT THE BEGINNING OF A -C PATIENT FILE (THE ONLY PLACE IT CAN OCCUR IN THIS PROGRAM), TIMES IN -C TPRED WILL START AT THE END OF IT, RATHER THAN AT 0. - -C FOR EXAMPLE, IF THERE IS A STEADY STATE DOSE SET WITH INTERDOSE -C INTERVAL = DOSEINT, THEN THE TIMES WILL START AT 100*DOSEINT -C (SINCE EACH STEADY STATE DOSE SET IS ASSUMED TO HAVE 100 DOSES). -C AS A SPECIFIC EXAMPLE, IF A STEADY STATE DOSE SET WITH INTERDOSE -C INTERVAL OF 2 HOURS STARTS AT TIME 0 AND THE 1ST OBS. TIME IS AT -C 205, IT REALLY MEANS THAT THE OBSERVATIONS START 5 HOURS AFTER THE -C END OF THE STEADY STATE DOSE SET. IN THIS CASE, THE TIMES IN TPRED -C STILL START AT 200. - -C BUT, ALSO ESTABLISH TPREDREL(.) WHICH IS SIMILAR -C TO TPRED, BUT HAS "RELATIVE" INSTEAD OF "REAL" TIMES AFTER STEADY -C STATE DOSES. IN THE EXAMPLE ABOVE WITH AN INTERDOSE INTERVAL OF 2 -C HOURS, THE TPRED(.) VALUES START AT 200 AND THE TPREDREL(.) VALUES -C START AT 0. AND EACH TPREDREL(I) = TPRED(I) - 200. - -C !!! AS OF BESTDOS119.FOR, TPRED VALUES WILL START AT 0 UNLESS THE -C CORRESPONDING DOSES FOR THIS TIME BLOCK START WITH A STEADY STATE -C SET. IN THAT CASE, THE TPRED VALUES WILL START FROM THE END OF THE -C STEADY STATE SET. THE STARTING DOSE TIME IS IN SIG(1). IF -C THIS VALUE IS < 0, IT REPRESENTS THE START OF A STEADY STATE DOSE -C SET, WITH INTERDOSE INTERVAL = -SIG(1). OTHERWISE, SIG(1) SHOULD -C BE 0 (I.E., IF THERE IS NO STEADY STATE SET). - -C NOTE THAT, AS INDICATED ABOVE, THE TPREDREL VALUES WILL ALWAYS START -C AT 0. - - TBEG = 0.D0 - IF(SIG(1) .LT. 0.D0) TBEG = 100.D0*(-SIG(1)) - - - -C THERE ARE NOBSER OBSERVATION TIMES IN TIM. SET TIMMAX TO THE LAST -C ONE, WHICH IS THE LARGEST, AND THEN SET T_END = 24 HOURS AFTER -C TIMMAX. - - TIMMAX = TIM(NOBSER) - T_END = TIMMAX + 24.D0 - -C PUT THE REGULAR TIMES IN TVECT; THEY START AT TBEG AND END AT T_END, -C AND ARE IDELTA/60 HOURS APART. SO THERE WILL BE -C (T_END - TBEG)*60/IDELTA + 1 OF THEM. NOTE THAT IF 60/IDELTA IS NOT -C AN INTEGER, THE ENDING TIME WILL BE A LITTLE DIFFERENT THAN EXACTLY -C 24 HOURS AFTER TIMMAX. - - NUMT2 = (T_END - TBEG)*60/IDELTA - - NUMTT = 1 - TVECT(NUMTT) = TBEG - - - - DO I=1,NUMT2 - NUMTT = NUMTT + 1 - TVECT(NUMTT) = TVECT(NUMTT-1) + IDELTA/60.D0 - END DO - - -C AS IF BESTDOS109.FOR, ADD INTO TVECT ALL THE OBSERVATION AND DOSE -C TIMES. THEN CALL PUTORDER TO ORDER ALL THE TIMES IN TVECT; AND -C FINALLY, REMOVE ALL DUPLICATE TIMES. - - DO I = 1,NOBSER - NUMTT = NUMTT + 1 - TVECT(NUMTT) = TIM(I) - - - END DO - -C ADD IN THE DOSE TIMES, BUT ONLY THOSE THAT OCCUR AFTER TBEG. FOR -C EXAMPLE, IF SIG(1) = -2 (INDICATING A STEADY STATE DOSE SET WHICH -C ENDS AT TBEG = 200, THEN WE WANT TO ADD ONLY THOSE DOSE TIMES THAT -C OCCUR AFTER THE END OF THIS STEADY STATE DOSE SET. - - DO I = 1,ND - IF(SIG(I) .GT. TBEG) THEN - NUMTT = NUMTT + 1 - TVECT(NUMTT) = SIG(I) - ENDIF - END DO - - - -C AS OF BESTDOS110.FOR, ALSO ADD INTO TVECT THE OBSERVATION TIMES -C FROM THE "PAST". - -C NOTE THAT THE NOBSER OBSERVATION TIMES IN TIM(.) ADDED ABOVE TO -C TVECT WERE JUST FROM THE "FUTURE", BECAUSE THESE VALUES WERE -C FILLED IN SUBROUTINE FILRED, WHEN IT READ FILE 37 (AND FILE 37 -C WAS EITHER JUST THE "FUTURE" IF INCLUDPAST = 0 IN MAIN; OR -C WAS "BOTHFILES.ZPJ", CREATED BY SUBROUTINE MAKETMP IF THERE WAS -C A "PAST", AND "BOTHFILES.ZPJ DOES NOT INCLUDE "PAST" OBSERVATIONS). - -C NOTE THAT IF INCLUDPAST = 0 IN MAIN, THEN M41 WAS SET = 0. IN THIS -C CASE, OF COURSE, THERE ARE NO TIMES TO ADD SINCE THERE WAS NO -C "PAST" HISTORY.N - -C NOTE THAT SIG(1) = 0 MEANS THAT THE PATIENT DOES NOT HAVE ITS -C REGIMEN BEGINNING WITH A STEADY STATE DOSE SET. BUT SIG(1) < 0 -C MEANS THAT THE REGIMEN DOES BEGIN WITH A STEADY STATE DOSE SET. -C IN THIS CASE, THE TIM41(.) VALUES REFER TO TIMES AFTER THE END OF -C THE STEADY STATE DOSES. I.E., THEY SHOULD BE INCREASED BY -C 100*(-SIG(1)). - -C EX: SIG(1) = -2.0 AND TIM(.) = 5, 10, 20 --> THESE TIMES ARE -C ACTUALLY AT REAL TIMES 205, 210, AND 220. -C SO ADD 100*(-SIG(1)) TO ALL OBS. TIMES IN TIM41(.) IF SIG(1) < 0. - - - - IF(M41 .GT. 0) THEN - DO I = 1,M41 - NUMTT = NUMTT + 1 - IF(SIG(1) .LT. 0.D0) TVECT(NUMTT) = TIM41(I) - 100.D0*SIG(1) - IF(SIG(1) .GE. 0.D0) TVECT(NUMTT) = TIM41(I) - END DO - ENDIF - -C ADD IN THE TIME WHICH STARTS THE "FUTURE". THIS IS TNEXT IF -C THERE IS NO STEADY STATE DOSE SET TO START THE PATIENT FILE, OR -C TNEXT + 100*(-SIG(1)) OTHERWISE. ACTUALLY THIS LATTER FORMULA -C WORKS REGARDLESS, SINCE SIG(1) = 0 IF THESE IS NO STEADY STATE -C DOSE SEST. - - NUMTT = NUMTT + 1 - TVECT(NUMTT) = TNEXT - 100.D0*SIG(1) - -C ORDER ALL THE TIMES IN TVECT. - - CALL PUTORDER(NUMTT,TVECT) - -C THE NUMTT VALUES ARE NOW ORDERED IN TVECT. NOW REMOVE DUPLICATE -C TIMES BELOW. NUMT WILL BE THE RUNNING NO. OF TIMES CURRENTLY -C STORED INTO TVECT, WHEN DUPLICATE TIMES ARE IGNORED. - - TIMELAST = -1.D39 - - NUMT = 0 - - DO I = 1,NUMTT - - TIME = TVECT(I) - CALL THESAME(TIME,TIMELAST,ISAME) - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TIME = TIMELAST (OR AT -C LEAST, THEY ARE WITHIN 1.D-10), AND THIS TIME CAN BE IGNORED SINCE IT -C WAS ALREADY PUT INTO TVECT BY A PREVIOUS TIME. - - IF(ISAME .EQ. 1) GO TO 30 - -C TO GET HERE, ISAME = 0, WHICH MEANS THIS IS A NEW TIME. SO PUT -C TIME INTO TVECT. THEN SET TIMELAST = TIME AND CONTINUE THE LOOP. - - NUMT = NUMT + 1 - TVECT(NUMT) = TIME - TIMELAST = TIME - - 30 CONTINUE - - END DO -C THE ABOVE END DO IS FOR THE DO I = 1,NUMTT LOOP. - - -C NOW STORE THESE NUMT TIMES INTO TPRED, BUT IF NUMT IS > 72000, -C ONLY STORE THE FIRST 72000, AND WRITE MESSAGE TO THE SCREEN AND -C THE OUTPUT FILE. ALSO ESTABLISH TPREDREL(.) WHICH ARE THE TIMES -C RELATIVE TO THE END OF A STEADY STATE DOSE SET IF THERE IS ONE. - - IF(NUMT .GT. 72000) THEN - - DO I = 1,72000 - TPRED(I) = TVECT(I) - TPREDREL(I) = TPRED(I) - TBEG - END DO - - WRITE(*,2031) - WRITE(56,2031) - - - 2031 FORMAT(//' THE MAXIMUM NO. OF PREDICTED VALUES HAS BEEN REACHED.'/ - 1' THIS MEANS THERE WILL NOT BE A COMPLETE SET OF PREDICTED '/ - 2' VALUES FOR EACH GRID PT. IN THE OUTPUT FILE.'/) - - NUMT = 72000 - RETURN - - ENDIF -C THE ABOVE ENDIF IS FOR THE IF(NUMT .GT. 72000) CONDITION. - - -C NOW ASSIGN TPRED VALUES IF NUMT .LE. 72000. IN THIS CASE, THERE WILL - -C BE NO WARNING MESSAGE TO THE SCREEN OR THE OUTPUT FILE. - - - DO I = 1,NUMT - TPRED(I) = TVECT(I) - TPREDREL(I) = TPRED(I) - TBEG - END DO - - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE CALCTPRED2(NOBSER,TNEXT,IDELTA,NUMT,TPRED) - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION TPRED(72000),TIM(594),SIG(5000),RS(5000,34), - 1 BS(5000,7),YOO(594,MAXNUMEQ),TVECT(72000),TIM41(594) - - CHARACTER ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - COMMON/OBSER/ TIM,SIG,RS,YOO,BS - -C THIS ROUTINE IS CALLED BY WSUMSQ TO CALCULATE THE NUMT TIMES TO BE -C PUT INTO TPRED. THESE SHOULD BE A RICH SET OF TIMES BETWEEN TBEG AND -C THE LAST OBSERVED VALUE TIME, ALONG WITH ALL THE NOBSER OBSERVATION -C TIMES (REDUNDANT TIMES WILL BE IGNORED OF COURSE). - -C NOTE THAT THE TIMES IN TPRED WILL BE IDELTA MINUTES APART, BETWEEN -C TBEG AND THE LAST OBS. TIME, ALONG WITH THE OBS. TIMES THEMSELVES. - -C !!! AS OF BESTDOS119.FOR, THE CODE WILL ALLOW FOR A STEADY STATE -C DOSE SET AT THE BEGINNING OF THE PATIENT FILE. SO TPRED VALUES WILL -C START AT 0 UNLESS THE CORRESPONDING DOSES FOR THIS TIME BLOCK START -C WITH A STEADY STATE SET. IN THAT CASE, THE TPRED VALUES WILL START -C FROM THE END OF THE STEADY STATE SET. THE STARTING DOSE TIME IS IN -C SIG(1). IF THIS VALUE IS < 0, IT REPRESENTS THE START OF A STEADY -C STATE DOSE SET, WITH INTERDOSE INTERVAL = -SIG(1). OTHERWISE, SIG(1) -C SHOULD BE 0 (I.E., IF THERE IS NO STEADY STATE SET). - -C THE LAST OBSERVATION TIME IS TIM(NOBSER). SINCE THE TIMES IN TPRED -C WILL BE IDELTA MINUTES APART, THE NO. OF TIMES WILL BE -C TIM(OBSER)*60/IDELTA + 1, ALONG WITH ANY ADDITIONAL OBSERVATION -C TIMES. - - TBEG = 0.D0 - IF(SIG(1) .LT. 0.D0) TBEG = 100.D0*(-SIG(1)) - -C THERE ARE NOBSER OBSERVATION TIMES IN TIM. SET TIMMAX TO THE LAST -C ONE, WHICH IS THE LARGEST. - - TIMMAX = TIM(NOBSER) - -C PUT THE REGULAR TIMES IN TVECT; THEY START AT TBEG AND END AT -C TIMMAX, AND ARE IDELTA/60 HOURS APART. SO THERE WILL BE -C (TIMMAX - TBEG)*60/IDELTA + 1 OF THEM. NOTE THAT IF 60/IDELTA IS NOT -C AN INTEGER, THE ENDING TIME WILL BE A LITTLE DIFFERENT THAN EXACTLY -C TIMMAX. - - NUMT2 = (TIMMAX - TBEG)*60/IDELTA - NUMTT = 1 - TVECT(NUMTT) = TBEG - - DO I=1,NUMT2 - NUMTT = NUMTT + 1 - TVECT(NUMTT) = TVECT(NUMTT-1) + IDELTA/60.D0 - END DO - - -C NOW ADD INTO TVECT ALL THE OBSERVATION TIMES. - - DO I = 1,NOBSER - NUMTT = NUMTT + 1 - TVECT(NUMTT) = TIM(I) - END DO - - -C ADD IN THE TIME WHICH STARTS THE "FUTURE". THIS IS TNEXT IF -C THERE IS NO STEADY STATE DOSE SET TO START THE PATIENT FILE, OR -C TNEXT + 100*(-SIG(1)) OTHERWISE. ACTUALLY THIS LATTER FORMULA -C WORKS REGARDLESS, SINCE SIG(1) = 0 IF THESE IS NO STEADY STATE -C DOSE SEST. - - NUMTT = NUMTT + 1 - TVECT(NUMTT) = TNEXT - 100.D0*SIG(1) - - -C CALL PUTORDER TO ORDER ALL THE TIMES IN TVECT. - - CALL PUTORDER(NUMTT,TVECT) - -C THE NUMTT VALUES ARE NOW ORDERED IN TVECT. NOW REMOVE DUPLICATE -C TIMES BELOW. NUMT WILL BE THE RUNNING NO. OF TIMES CURRENTLY -C STORED INTO TVECT, WHEN DUPLICATE TIMES ARE IGNORED. - - TIMELAST = -1.D39 - - NUMT = 0 - - DO I = 1,NUMTT - - TIME = TVECT(I) - CALL THESAME(TIME,TIMELAST,ISAME) - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TIME = TIMELAST (OR AT -C LEAST, THEY ARE WITHIN 1.D-10), AND THIS TIME CAN BE IGNORED SINCE IT -C WAS ALREADY PUT INTO TVECT BY A PREVIOUS TIME. - - IF(ISAME .EQ. 1) GO TO 30 - -C TO GET HERE, ISAME = 0, WHICH MEANS THIS IS A NEW TIME. SO PUT -C TIME INTO TVECT. THEN SET TIMELAST = TIME AND CONTINUE THE LOOP. - - NUMT = NUMT + 1 - -C IF NUMT > 72000, STOP THE PROGRAM WITH A MESSAGE TO THE USER. - - IF(NUMT .GT. 72000) THEN - - WRITE(*,2031) - WRITE(56,2031) - 2031 FORMAT(//' THE MAXIMUM NO. OF PREDICTED VALUES HAS BEEN REACHED'/ - 1' IN SUBROUTINE CALCTPRED2. THE PROGRAM STOPS. PLEASE RERUN '/ - 2' AFTER SETTING IDELTA TO A LARGER NUMBER, OR REDUCING THE '/ - 3' LAST OBSERVATION TIME IN THE "FUTURE" FILE.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,2031) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - - TVECT(NUMT) = TIME - TIMELAST = TIME - - 30 CONTINUE - - END DO -C THE ABOVE END DO IS FOR THE DO I = 1,NUMTT LOOP. - - -C NOW STORE THESE NUMT TIMES INTO TPRED. - - DO I = 1,NUMT - TPRED(I) = TVECT(I) - END DO - - - RETURN - END - -C This file contains source code for the BLAS routines that are used by BIGNPAG -C These are separated out here since it may be more efficient to just compile -C bignpag.f and link to an optimized math library containing the BLAS than to -C compile bignpag.f and this file blasnpag.f together. -C contents: -c dgemm: blas level 3 -c dgemv: blas level 2 -c dsyrk: blas level 3 -c dtrsm: blas level 1 -c dcopy: blas levle 1 -c dscal: blas level 1 -c daxpy: blas level 1 -c ddot: blas level 1 -c idamax: blas level 1 -c dswap: blas level 1 -c dasum: blas level 1 -c dnrm2: blas level 1 - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X', -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* Parameters -* ========== -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n', op( A ) = A. -* -* TRANSA = 'T' or 't', op( A ) = A'. -* -* TRANSA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANSB - CHARACTER*1. -* On entry, TRANSB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANSB = 'N' or 'n', op( B ) = B. -* -* TRANSB = 'T' or 't', op( B ) = B'. -* -* TRANSB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix -* op( A ) and of the matrix C. M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix -* op( B ) and the number of columns of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of columns of the matrix -* op( A ) and the number of rows of the matrix op( B ). K must -* be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And if alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* Form C := alpha*A*B' + beta*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END - SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END - SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK . -* - END - SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END - subroutine dcopy(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - end - -C----------------------------------------------------------------------- - - subroutine dscal(n,da,dx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision da,dx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dx(i) = da*dx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dx(i) = da*dx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dx(i) = da*dx(i) - dx(i + 1) = da*dx(i + 1) - dx(i + 2) = da*dx(i + 2) - dx(i + 3) = da*dx(i + 3) - dx(i + 4) = da*dx(i + 4) - 50 continue - return - end - -C----------------------------------------------------------------------- - - subroutine daxpy(n,da,dx,incx,dy,incy) -c -c constant times a vector plus a vector. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),da - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if (da .eq. 0.0d0) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dy(iy) + da*dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dy(i) + da*dx(i) - 30 continue - if( n .lt. 4 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,4 - dy(i) = dy(i) + da*dx(i) - dy(i + 1) = dy(i + 1) + da*dx(i + 1) - dy(i + 2) = dy(i + 2) + da*dx(i + 2) - dy(i + 3) = dy(i + 3) + da*dx(i + 3) - 50 continue - return - end - -C----------------------------------------------------------------------- - - double precision function ddot(n,dx,incx,dy,incy) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - ddot = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dtemp + dx(ix)*dy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - ddot = dtemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dx(i)*dy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + - * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) - 50 continue - 60 ddot = dtemp - return - end - - -C----------------------------------------------------------------------- - - integer function idamax(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmax - integer i,incx,ix,n -c - idamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamax = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamax = i - dmax = dabs(dx(i)) - 30 continue - return - end - -C----------------------------------------------------------------------- - - subroutine dswap (n,dx,incx,dy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dx(ix) - dx(ix) = dy(iy) - dy(iy) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - dtemp = dx(i + 1) - dx(i + 1) = dy(i + 1) - dy(i + 1) = dtemp - dtemp = dx(i + 2) - dx(i + 2) = dy(i + 2) - dy(i + 2) = dtemp - 50 continue - return - end - double precision function dasum(n,dx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dtemp - integer i,incx,m,mp1,n,nincx -c - dasum = 0.0d0 - dtemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dtemp = dtemp + dabs(dx(i)) - 10 continue - dasum = dtemp - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,6) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dabs(dx(i)) - 30 continue - if( n .lt. 6 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,6 - dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) - * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) - 50 continue - 60 dasum = dtemp - return - end - DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE IF( N.EQ.1 )THEN - NORM = ABS( X( 1 ) ) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SSQ = ONE + SSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END -C CALCBST15.FOR 7/7/14 - -C CALCBST15 HAS THE FOLLOWING CHANGES FROM CALCBST14: - -C 1. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN -C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx -C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING -C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT -C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT -C USING COMMON/ERR/ERRFIL. - -C 2. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, -C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET -C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED -C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT -C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS -C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL -C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 -C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO -C MAXNUMEQ. - -C 3. IN SUBROUTINE GETPRED, THE DIMENSIONS OF 6 IN XSTORE AND XPRED -C HAVE BEEN CHANGED TO 20, AS THEY SHOULD HAVE BEEN ALL ALONG (I.E., -C THIS REPRESENTS THE MAXIMUM NO. OF COMPARTMENTS ALLOWED). - -C 4. THE TWO WRITE STATEMENTS TO FILE 25 ARE REMOVED, SINCE FILE 25 IS -C NOT ACTIVE IN THIS PROGRAM. - -C 5. IN SUBROUTINE GETPRED, COMMON/ERROR/ERRFIL IS ADDED; ERRFIL IS -C DECLARED CHARACTER*20; AND FORMAT 111 AND SIG(.) ARE WRITTEN TO -C ERRFIL JUST BEFORE THE PROGRAM STOPS IF THE PATIENT DATA FILE -C HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE -C RESET ROW. - -C 6. A BUG IS FIXED IN SUBROUTINE WSUMSQ.IN THE IF(ITARGET .EQ. 2) -C PORTION OF THE CODE, AUC IS NO LONGER SET BACK TO 0 IF -C TPRED(I) = TNEXT ... SINCE AUCs ARE CUMULATIVE FROM TIME 0 IN THE -C "PAST", AS OF BESTDOS118.FOR. THIS BUG EXISTED ONLY IN -C BESTDOS118.FOR, AND IS NOW FIXED IN BESTDOS119.FOR, WHICH IS THE -C FIRST PROGRAM TO USE CALCBST15.FOR. - -C----------------------------------------------------------------------- - -C CALCBST14.FOR 11/4/13 - -C CALCBST14 HAS THE FOLLOWING CHANGE TO CALCBST13. "XLAM" IS REPLACED -C BY "BIASWEIGHT". THIS IS DONE TO REMOVE ANY CONFUSION WITH LAMBDA, -C WHICH IS A TERM USED IN THE ASSAY ERROR FUNCTION. - -C CALCBST14.FOR IS A MODULE IN THE NEW BESTDOS117.FOR PROGRAM. - -C----------------------------------------------------------------------- - -C CALCBST13.FOR 10/16/13 - -C CALCBST13 HAS THE FOLLOWING CHANGES TO CALCBST12: - -C IF THE USER SELECTS ITARGET = 2 (SEE BELOW), THE AUCs NOW WILL BE -C RELATIVE TO TIME 0 IN THE "FUTURE", AS OPPOSED TO TIME 0 IN THE -C "PAST". - -C THIS REQUIRES CHANGES IN SUBROUTINE WSUMSQ. THE AUC AT TIME TNEXT -C (WHICH IS THE BEGINNING TIME FOR THE "FUTURE") IS RESET BACK TO 0. - -C NOTE ALSO THAT TNEXT IS NOW INCLUDED IN COMMON/TOSUMSQ, SO THAT -C IT CAN BE ADDED TO THE TIMES WHICH ARE ESTABLISHED BY ROUTINE -C CALCTPRED2. - -C NOTE THAT THIS PROGRAM IS NOW LINKED WITH BESTDOS116.FOR. - -C----------------------------------------------------------------------- - -C CALCBST12.FOR 10/6/13 - -C CALCBST12 HAS THE FOLLOWING CHANGES FROM CALCBST11: - -C 1. THERE ARE A NUMBER OF CHANGES IN SUBROUTINE WSUMSQ TO ALLOW FOR -C THE NEW CASE THAT THE OBSERVED VALUES COULD BE TARGET AUCs, RATHER -C THAN TARGET CONCENTRATIONS. - -C NOTE ALSO THAT THE NEW COMMON/TOSUMSQ PROVIDES INFO NEEDED BY -C WSUMSQ FROM MAIN. - -C 2. THE DIMENSION 71281 FOR YYPRED AND TPRED HAS BEEN CHANGED TO -C 72000 TO BE CONSISTENT WITH THTE DIMENSIONS NOW IN BESTDOS115.FOR. - -C 3. NOTE THAT XLAM HAS BEEN MOVED IN FRONT OF THE INTEGER ARGUMENTS -C IN COMMON/TOCALC TO AVOID A WARNING WHEN THIS PROGRAM IS COMPILED -C WITH gfortran. - -C THIS MODULE IS PART OF THE NEW PROGRAM, BESTDOS115.FOR. - -C----------------------------------------------------------------------- - -C CALCBST11.FOR 9/16/13 - -C CALCBST11 HAS THE FOLLOWING CHANGES TO CALCBST10: - -C 1. THE COST FUNCTION TO BE MINIMIZED IN SUBROUTINE CALCS IS CHANGED -C TO NOW INCLUDE A BIAS TERM ALSO. THIS REQUIRES SEVERAL CHANGES IN -C SUBROUTINES CALCS AND WSUMSQ. AND IT REQUIRES XLAM TO BE PROVIDED -C TO CALCS VIA COMMON/TOCALC. - -C 2. IN WHAT IS NOW THE FIRST PART OF THE COST FUNCTION, THE -C WEIGHT(.,.) ARRAY IS ELIMINATED. I.E., NOW THAT PART OF THE COST -C FUNCTION WILL NO LONGER BE WEIGHTED BY THE ASSAY NOISE. - -C 3. EXTRA/NEW VALUES ARE RETURNED TO MAIN VIA COMMON/PREDVAL. INSTEAD -C OF JUST PREDMIN AND SUMM, NOW PREDMIN, EEXPSUMMIN, SUMMIN, AND -C BIASMIN ARE RETURNED. - -C----------------------------------------------------------------------- - -C CALCBST10.FOR 3/26/13 - -C CALCBST10 HAS THE FOLLOWING CHANGES FROM CALCBST9: - -C THE CODE IN CALCPRED/GETPRED IS NOW BASED IN idm1x14.f, RATHER THAN -C idm1x6.f. THIS BRINGS THE BESTDOS106/CALCBST10 PROGRAM UP TO THE -C LEVEL OF THE NPAG AND IT2B PROGRAMS, EXCEPT THAT THIS PROGRAM STILL -C DOES NOT ACCOMMODATE STEADY STATE DOSE SETS --> THERE IS EXTRA UNUSED -C CODE RELATED TO STEADY STATE DOSE SETS IN GETPRED (WHICH MAY BE USED -C IN A LATER VERSION). - -C NOTE, IN PARTICULAR, THAT ALL DIMENSIONS OF 500 RELATED TO THE NO. OF -C DOSES ARE NOW CHANGED TO 5000. - -C----------------------------------------------------------------------- - -C CALCBST9.FOR 3/2/13 - -C CALCBST9 HAS THE FOLLOWING CHANGES FROM CALCBST8: - -C 1. COMMON/TOCALC, SUPPLIED TO SUBROUTINE CALCS, NOW INCLUDES AN -C EXTRA ARGUMENT, NDD41, AND THIS ARGUMENT (WITH NAME CHANGED TO -C ND41) IS SUPPLIED TO SUBROUTINE WSUMSQ. IN THAT ROUTINE, IT IS USED -C TO CHANGE THE DO I = 1,ND LOOP TO DO I = ND41+1,ND. - -C 2. THIS MODULE IS A PART OF THE NEW PROGRAM, BESTDOS105.FOR. - -C----------------------------------------------------------------------- - -C CALCBST8.FOR 2/13/13 - -C CALCBST8 HAS THE FOLLOWING CHANGES FROM CALCBST7: - -C IT OPTIMIZES OVER ALL DOSES IN THE PATIENT FILE, BOLUSES AS WELL -C AS IV RATES (CALCBST7 ASSUMED THAT THE BOLUSES WERE FIXED, AND ONLY -C OPTIMIZED OVER THE IV RATES). CALCBST8 IS USED WITH THE NEW MAIN -C PROGRAM, BESTDOS104.FOR. - -C NOTE THAT THE ONLY CHANGES REQUIRED ARE IN SUBROUTINE WSUMSQ. - -C----------------------------------------------------------------------- - -C CALCBST7.FOR 6/17/11 - -C CALCBST7 IS THE SAME AS CALCBST6 EXCEPT THAT ROUTINES USERANAL -C AND JACOB HAVE BEEN REMOVED (SINCE THEY ARE NOW PROVIDED IN THE -C NEW MODULE IDM1X6.FOR FOR THE BESTDOS101.FOR PROGRAM). - -C----------------------------------------------------------------------- - -C CALCBST6.FOR 1/27/11 - -C CALCBST6 HAS THE CHANGES FROM CALCBST5 (IN SUBROUTINE GETPRED) that -C idm1x6.f HAS FROM idm1x3.f. THESE CHANGES, IN ADDITION TO CORRECTING -C A COUPLE OF BUGS, MAKE THIS PROGRAM NOW COMPATIBLE WITH MODEL -C TEMPLATE FILE, TSTMULTH.FOR (UPDATED FROM TSTMULTG.FOR). THIS MODULE -C IS LINKED FIRST WITH MAIN MODULE, BESTDOS8.FOR. - -C----------------------------------------------------------------------- - -C CALCBST5.FOR 10/15/09 - -C CALCBST5 HAS THE FOLLOWING CHANGES FROM CALCBST4: - -C 1. IT IS A MODULE IN THE BESTDOS7.FOR PROGRAM. THIS PROGRAM IS -C AT THE "LEVEL" OF THE NPBIG15C.FOR PROGRAM. I.E., IT ALLOWS MULTIPLE -C DRUGS AND MULTIPLE OUTPUTS. - -C 2. CODE CHANGES, AND DIMENSION CHANGES OCCUR IN SUBROUTINES -C WSUMSQ, CALCPRED, GETPRED, USERANAL (ONLY CHANGE IS THAT WARNING -C STATEMENT IS SUPPRESSED) AND MAKEVEC. - -C NOTE THAT THE MODEL FILE CONSISTENT WITH THIS PROGRAM IS NOW -C TSTMULTG.FOR. NOTE ALSO, THAT THE SHIFT MODULE COMPILED AND -C LINKED WITH THIS PROGRAM IS NOW SHIFT5.F. - -C----------------------------------------------------------------------- - -C CALCBST4.FOR 3/1/08 - -C CALCBST4 HAS THE FOLLOWING CHANGES FROM CALCBST3: - -C 1. IN SUBROUTINE CALCS, ANY CANDIDATE VECTOR OF DOSES WHICH INCLUDES -C A NEGATIVE VALUE IS IMMEDIATELY REJECTED BY RETURNING A LARGE -C (UNATTRACTIVE) VALUE FOR THE OBJECTIVE FUNCTION, EXPSUM. THIS -C REQUIREMENT SHOULD HAVE BEEN IN PLACE ALL ALONG. - -C 2. IT IS LINKED WITH THE BESTDOS6 PROGRAM. - -C----------------------------------------------------------------------- - -C CALCBST3.FOR 11-14-02 - -C CALCBST3 IS A MAJOR VARIATION TO CALCBST2.FOR. THE MAJOR CHANGE IS -C THAT THIS MODULE IS LINKED WITH BESTDOS4.FOR, WHEREAS CALCBST2 IS -C LINKED WITH BESTDOS3.FOR. BESTDOS4.FOR/CALCBST3.FOR ALLOW GENERAL -C MODELS WHICH CAN BE DESCRIBED BY DIFFERENTIAL EQUATIONS AND OUTPUT -C EQUATION(S) CODED BY THE USER INTO SUBROUTINES DIFFEQ, OUTPUT, AND -C SYMBOL OF FILE, npemdriv.f. I.E., THE MODEL IS NO LONGER LIMITED TO -C THE STANDARD 3-COMPARTMENT LINEAR MODEL. - -C THE MAJOR CODING CHANGES REQUIRED ARE AS FOLLOWS: - -C 1. SUBROUTINES PARNAM AND PARNAM2 HAVE BEEN REMOVED - THEY ARE -C NOT APPLICABLE NOW SINCE THE MENU 1/2 CODE HAS BEEN REMOVED -C FROM THIS PROGRAM. - -C 2. SEVERAL DIMENSIONS HAVE BEEN CHANGED TO BE CONSISTENT ACROSS -C ALL ROUTINES WHICH HAVE THE SAME COMMONS. E.G., TIM(150) HAS -C BE CHANGED TO TIM(594) AND YO(150,4) HAS BEEN CHANGED TO -C YO(594,6). BOTH OF THESE ARE IN COMMON/OBSER. - -C 3. M HAS BEEN REMOVED FROM THE ARGUMENT LIST OF SUBROUTINE GETPRED; -C IT WILL BE PASSED VIA COMMON/SUM2 - -C 4. NVAR WAS REMOVED AS AN ARGUMENT TO SUBROUTINES WSUMSQ AND -C CALCPRED. IT WILL BE REPLACED BY NP (TOTAL NO. OF BOTH RANDOM -C AND FIXED PARAMETERS IN CALCPRED). - -C 5. SUBROUTINE CALCPRED WAS CHANGED TO BE LIKE MAIN OF idfix5f.f. - -C 6. SUBROUTINE GETPRED WAS CHANGED TO BE ESSENTIALLY LIKE SUBROUTINE -C FUNC OF MODULE, idfix5f.f. - -C 7. SUBROUTINES ANAL3, CASE1,...,CASE4 HAVE BEEN REMOVED. - -C 8. SUBROUTINES USERANAL AND JACOB ARE PUT IN FROM idfix5f.f. -C SUBROUTINE MAKEVEC IS PUT IN FROM bignpaglap1.f. MAKEVEC IS -C CALLED BELOW TO PUT INTO ONE VECTOR ALL THE PARAMETER VALUES -C (RANDOM AND FIXED) FOR EACH GRID POINT. - -C 9. NEW COMMON/FROMBEST PROVIDES THE VALUES NEEDED IN THE CALL TO -C NEW SUBROUTINE MAKEVEC (SEE ABOVE). - -C 10. THE MODULES, npemdriv.f (EDITED AS DESIRED BY THE USER) AND -C vodtot.f, WILL ALSO BE LINKED WITH THIS MODULE TO BE PART OF THE -C BESTDOS4.FOR PROGRAM. vodtot.f MUST BE LINKED SINCE SUBROUTINE DVODE -C IS CALLED BY SUBROUTINE USERANAL. - -C 11. SUBROUTINE OUTPUT HAS BEEN REMOVED SINCE IT WILL NOW BE A PART -C OF MODULE, npemdriv.f, WHICH WILL BE EDITED BY THE USER. - -C 12. THE MAXIMUM NO. OF GRID POINTS WHICH CAN BE USED (I.E., THE NO. -C OF GRID POINTS READ IN FROM THE MATLAB FILE BY BESTDOS4.FOR) IS -C CURRENTLY SET = MAXGRD = 5003. - -C----------------------------------------------------------------------- - -C CALCBST2.FOR 9-29-01 - -C CALCBST2 IS A SLIGHT EXTENSION TO CALCBEST. THE DIFFERENCE IS THAT, -C FOR EACH GRID POINT IN THE INPUT DENSITY, THE ACHIEVED CONCENTRATIONS -C FOR THE CURRENT BEST SET OF DOSES (I.E., THOSE GIVING THE MINIMUM -C EXPSUM IN SUBROUTINE CALCS) ARE STORED IN COMMON/PREDVAL, WHICH WILL -C BE USED IN MAIN. - -C----------------------------------------------------------------------- - -C CALCBEST.FOR 8-25-01 - -C CALCBEST (SUBROUTINE CALCS) IS A VARIATION OF CALCS.FOR ... TO BE -C USED WITH BESTDOSE.FOR. BESTDOSE CALLS ELDERY (WHICH USES THE -C NELDER MEED ALGORITHM) TO FIND THE BEST SET OF NDOS DOSES (AT THE -C TIMES READ IN FROM THE PATIENT DATA FILE BY SUBROUTINE FILRED - -C THESE TIMES ARE PUT INTO COMMON BY FILRED) TO MINIMIZE THE EXPECTED -C WEIGHTED SUM OF SQUARES OF DIFFERENCES BETWEEN OBSERVED AND TARGET - - -C CONCENTRATIONS (THE OBSERVATION TIMES AND TARGET CONCENTRATIONS ARE -C ALSO READ IN BY FILRED AND PUT INTO COMMONS TO BE USED BY SUBROUTINE -C CALCS). THE EXPECTED VALUE IS OVER THE PRIOR DENSITY (HAVING -C PARAMETER VALUES AND CORRESPONDING DENSITIES). - -C----------------------------------------------------------------------- - - SUBROUTINE CALCS(NDOS,DOSES,EXPSUM) - - PARAMETER(MAXGRD=5003, MAXDIM=25) - PARAMETER(MAXNUMEQ=7) - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION DOSES(5000),DENSITY(MAXGRD,MAXDIM+1),THETA(30), - 1 PRED(594,MAXNUMEQ),GRIDPRED(MAXGRD,594,MAXNUMEQ), - 2 YBAR(594,MAXNUMEQ),YOO(594,MAXNUMEQ), - 3 PREDMIN(MAXGRD,594,MAXNUMEQ),IRAN(32),VALFIX(20),PX(32) - - DATA EXPSUMMIN/1.D38/ - - COMMON/PREDVAL/PREDMIN,EEXPSUMMIN,SUMMIN,BIASMIN - COMMON/TOCALC/DENSITY,BIASWEIGHT,NOBSER,NUMEQT,NGRD,NVAR,NDD41 - COMMON/FROMBEST/NOFIX,IRAN,VALFIX - -C COMMON/PREVAL CONTAINS PREDMIN WHICH CONTAINS THE PREDICTED VALUES -C FOR EACH GRID POINT FOR THE BEST SET OF DOSES SO FAR (I.E., THOSE -C FOR WHICH THE EXPSUM IS MINIMUM SO FAR). ALSO, SUMM IS THE MINIMUM -C ACHIEVED VALUE OF EXPSUM SO FAR, AND CORRESPONDS TO PREDMIN VALUES. - -C COMMON/TOCALC CONTAINS THE FOLLOWING INFO: - -C 1. NOBSER = NO. OF OBSERVED VALUE TIMES IN THE PATIENT DATA FILE. -C 2. NGRD = NO. OF GRID POINTS OVER WHICH THE ABOVE EXPECTED VALUE -C IS TO BE CALCULATED. -C 3. NVAR = NO. OF DIMENSIONS IN THE RANDOM PARAMETER VECTOR. -C 4. DENSITY(I,J) = VALUE OF THE JTH RANDOM VARIABLE FOR GRID POINT I, -C J=1,NVAR; I=1,NGRD. -C DENSITY(I,NVAR+1) = DISCRETE DENSITY ASSOCIATED WITH GRID PT. I. -C 5. BIASWEIGHT = WEIGHT ASSIGNED TO THE BIAS TERM IN CALCULATION OF -C EXPSUM; 1 - BIASWEIGHT = WEIGHT ASSIGNED TO THE MEAN SQUARE ERROR -C TERM IN THE CALCULATION. -C 6. NUMEQT = NO. OF OUTPUT EQUATIONS IN THE PATIENT DATA FILE. -C 7. NDD41 = NO. OF DOSE EVENTS IN THE "PAST". - -C COMMON/FROMBEST PROVIDES THE VALUES TO THIS ROUTINE WHICH ARE -C IN THE CALL TO MAKEVEC BELOW. - - -C THIS ROUTINE, CALLED BY ELDERY, FINDS THE FUNCTIONAL VALUE, EXPSUM - - -C FOR THE SUPPLIED VARIABLE VECTOR, DOSES(I),I=1,NDOS. - -C EXPSUM CONSISTS OF TWO TERMS: - -C THE FIRST IS THE EXPECTED SUM OF SQUARES OF DIFFERENCES BETWEEN -C OBSERVED AND TARGET VALUES (THE OBSERVATION TIMES AND TARGET -C VALUES ARE READ IN BY FILRED AND PUT INTO COMMONS -C TO BE USED BY OTHER ROUTINES CALLED BY THIS ROUTINE). THE -C EXPECTED VALUE IS OVER THE PRIOR DENSITY (HAVING PARAMETER VALUES -C AND CORRESPONDING DENSITIES). - -C THE SECOND IS THE EXPECTED SUM OF SQUARES OF DIFFERENCES BETWEEN -C THE MEAN RESPONSES AND THE TARGETS (THIS IS ALSO CALLED THE -C BIAS TERM). - - - -C 1ST CHECK THAT ALL THE ENTRIES IN DOSES ARE NON-NEGATIVE. IF ANY - -C ISN'T, RETURN A LARGE POSITIVE VALUE (AN UNATTRACTIVE VALUE) FOR -C EXPSUM. THIS CHECK IS ADDED AS OF CALCBST4.FOR (IT SHOULD HAVE BEEN -C IN PLACE ALL ALONG). - - DO I=1,NDOS - IF(DOSES(I) .LT. 0.D0) THEN - EXPSUM = 1.D38 - RETURN - ENDIF - END DO - - -C CALCULATE EXPSUM AS DEFINED ABOVE. - -C INITIALIZE THE MEAN RESPONSE AT EACH OUTPUT TIME, FOR EACH -C OUTPUT EQ. TO BE 0. AT THE END OF THE DO IGRD LOOP, YBAR(I,J) -C WIL BE THE MEAN RESPONSE OVER ALL THE GRID PTS. FOR OBS. I -C AND OUTPUT EQ. J. - - - - DO I=1,NOBSER - DO J=1,NUMEQT - YBAR(I,J) = 0.D0 - END DO - END DO - - - SUM = 0.D0 - - DO IGRD = 1,NGRD - -C STORE INTO THETA THE PARAMETER VALUES FOR GRID POINT IGRD. - - DO J=1,NVAR - THETA(J) = DENSITY(IGRD,J) - END DO - -C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO -C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL -C MAKEVEC TO DO THIS. - - CALL MAKEVEC(NVAR,NOFIX,IRAN,THETA,VALFIX,PX) - - ND41 = NDD41 - -C MUST CHANGE THE NAME OF NDD41 TO ND41 SINCE IT IS SUPPLIED AS AN -C ARGUMENT TO WSUMSQ. - - CALL WSUMSQ(NOBSER,PX,NDOS,DOSES,WSS,PRED,ND41,YOO) - - -C STORE THE VALUES IN PRED INTO GRIDPRED IN CASE THE EXPSUM BELOW -C TURNS OUT TO BE THE MINIMUM SUM SO FAR, IN WHICH CASE ALL THESE -C PREDICTED VALUES WILL BE STORED INTO COMMON/PREDVAL FOR USE BY -C MAIN. - - DO I=1,NOBSER - DO J=1,NUMEQT - GRIDPRED(IGRD,I,J) = PRED(I,J) - END DO - END DO - -C ADD DENSITY(IGRD,NVAR+1)*PRED(.,.) TO YBAR(.,.). - - DO I=1,NOBSER - DO J=1,NUMEQT - YBAR(I,J) = YBAR(I,J) + DENSITY(IGRD,NVAR+1)*PRED(I,J) - END DO - END DO - - -C WSS RETURNS AS THE SUM OF SQUARES OF DIFFERENCES BETWEEN -C THE TARGET AND OBSERVED VALUES GIVEN INPUT INFO. - - SUM = SUM + DENSITY(IGRD,NVAR+1)*WSS - - - END DO - -C THE ABOVE END DO IS FOR THE DO IGRD = 1,NGRD LOOP. - - -C NOW YBAR(I,J) IS THE WEIGHTED MEAN RESPONSE FOR THE ITH TIME AND -C THE JTH OUTPUT EQ. CALCULATE THE MEAN-SQUARE BIAS ERROR AS THE -C SUM OF SQUARES OF DIFFERENCES BETWEEN YBAR(.,.) AND THE TRUE -C OBSERVED VALUES, YO(I,J). - - BIAS = 0.D0 - - DO I=1,NOBSER - DO J=1,NUMEQT - BIAS = BIAS + (YBAR(I,J) - YOO(I,J))**2.D0 - END DO - END DO - - - EXPSUM = (1.D0 - BIASWEIGHT)*SUM + BIASWEIGHT*BIAS - -C IF THIS EXPSUM IS LESS THAN THE CURRENT EXPSUMMIN THEN STORE THE -C VALUES IN GRIDPRED INTO PREDMIN WHICH IS PUT INTO COMMON/PREDVAL. -C ALSO STORE THESE BEST VALUES OF EXPSUMMIN, SUMMIN, AND BIASMIN. - - IF(EXPSUM .LT. EXPSUMMIN) THEN - EXPSUMMIN = EXPSUM - SUMMIN = SUM - BIASMIN = BIAS - DO IGRD = 1,NGRD - DO I=1,NOBSER - DO J=1,NUMEQT - PREDMIN(IGRD,I,J) = GRIDPRED(IGRD,I,J) - END DO - END DO - END DO - ENDIF - - EEXPSUMMIN = EXPSUMMIN - - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE WSUMSQ(NOBSER,PX,NDOS,DOSES,WSS,PRED,ND41,YOO) - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION DOSES(5000),TIM(594),SIG(5000),YOO(594,MAXNUMEQ), - 1 RS(5000,34),YO(594,MAXNUMEQ),BS(5000,7),PRED(594,MAXNUMEQ), - 2 PX(32),YYPRED(72000,MAXNUMEQ),TPRED(72000) - - COMMON/OBSER/ TIM,SIG,RS,YO,BS - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/CNST2/ NPL,NUMEQT,NDRUG,NADD - COMMON/TOSUMSQ/ITARGET,NVAR,NOFIX,NDIM,IDELTA,TNEXT - -C NOTE THAT COMMON/TOSUMSQ VALUES ARE PROVIDED TO THIS ROUTINE VIA -C MAIN. - - -C THIS ROUTINE IS CALLED BY SUBROUTINE CALCS TO CALCULATE WSS, WHICH IS -C THE SUM OF SQUARES OF DIFFERENCES BETWEEN TARGET AND ACTUAL VALUES, -C GIVEN PARAMETER VALUES (RANDOM AND FIXED) IN PX, AND THE DOSE AMOUNTS -C IN THE DOSES VECTOR. - -C FIRST STORE THE DOSES INTO RS. NOTE THAT THOSE DOSES WHICH ARE -C NOT OPTIMIZED OVER CONTINUE TO BE THEIR ORGINAL VALUES. AND NOTE THAT -C THE ONLY DOSES OPTIMIZED OVER ARE THE NON-0 ONES THAT OCCUR IN THE -C "FUTURE" (I.E, FROM DOSE EVENT ND41+1 TO ND). - - IDOS = 0 - - DO I = ND41+1,ND - DO J = 1,NDRUG - IF(RS(I,2*J-1) .GT. 0.D0) THEN - IDOS = IDOS + 1 - RS(I,2*J-1) = DOSES(IDOS) - ENDIF - IF(RS(I,2*J) .GT. 0.D0) THEN - IDOS = IDOS + 1 - RS(I,2*J) = DOSES(IDOS) - ENDIF - END DO - END DO - -C AS OF BESTDOS104.FOR/CALCBST8.FOR, MUST REESTABLISH THE BOLUS -C VALUES HERE SINCE THEY WERE ASSIGNED THEIR VALUES FROM THE CALL TO -C FILRED WHICH OCCURRED BEFORE ELDERY WAS CALLED. BUT NOW ELDERY CAN -C OPTIMIZE OVER BOLUS VALUES ALSO, WHICH MEANS THAT IT COULD CHANGE -C THE BOLUS VALUES, AND SO THEY MUST BE REESTABLISHED HERE. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - -C NOTE THAT YO(I,J); I=1,NOBSER; J=1,NUMEQT ARE THE "TARGET" OBSERVED -C VALUES WHICH WERE READ FROM THE PATIENT DATA FILE BY SUBROUTINE -C FILRED (AND PLACED INTO COMMON/OBSER). - -C PRIOR TO CALCBST12.FOR, THESE Y0(.,.) VALUES WERE ALWAYS -C CONCENTRATIONS. BUT AS OF CALCBST12 ... -C IF ITARGET = 1, THESE OBSERVED VALUES ARE CONCENTRATIONS; -C IF ITARGET = 2, THESE OBSERVED VALUES ARE AUCs. - -C SO IF ITARGET = 1, CALL CALCPRED TO GET PRED(.,.), JUST AS IN -C CALCBST11.FOR AND PRIOR PROGRAMS. - -C BUT IF ITARGET = 2, CALL CALCTPRED2 TO GET A RICH SUPPLY OF PREDICTED -C TIMES OVER WHICH CONCENTRATIONS CAN BE FOUND, AND FROM WHICH ACCURATE -C AUCs CAN BE CALCULATED (SEE BELOW). - - IF(ITARGET .EQ. 1) THEN - -C CALL CALCPRED, WHICH CALCULATES THE ACTUAL PREDICTED VALUES ASSUMING -C THE DOSE AMOUNTS, DOSES(I),I=1,NDOS (WHICH OCCUR AT THE TIMES WHICH -C WERE STORED INTO SIG(I),I=1,ND IN COMMON/OBSER BY SUBROUTINE FILRED -C PREVIOUSLY), AND THE PARAMETER VALUES STORED INTO PX. - - - CALL CALCPRED(PX,PRED) - - ENDIF - - - IF(ITARGET .EQ. 2) THEN - -C NOTE THAT THE SUM OF SQUARES, WSS, WILL BE CALCULATED OVER THE -C NOBSER x NUMEQT OBSERVED VALUES, WHICH OCCUR AT TIMES, -C TIM(I),I=1,NOBSER. THESE OBSERVED VALUES ARE TARGET AUCs. IN ORDER -C TO CALCULATE ACCURATE AUCs, USING THE TRAPEZOIDAL RULE, IT IS -C NECESSARY TO HAVE A RELATIVELY RICH SET OF CONCENTRATIONS (I.E., THE -C TRAPEZOIDAL RULE GIVES AN ACCURATE ESTIMATE OF THE TRUE INTEGRAL AS -C LONG AS THE DELTA BETWEEN 2 CONSECUTIVE CONCENTRATION TIMES IS SMALL, -C SO THAT THE CURVE RUNNING THROUGH THESE CONCENTRATIONS CAN BE -C REASONABLY WELL APPROXIMATED BY A STRAIGHT LINE). - -C CALL SUBROUTINE CALCTPRED2 TO ESTABLISH THE RICH SET OF TIMES -C TO BE USED TO CALCULATE THE AUCs. - - CALL CALCTPRED2(NOBSER,TNEXT,IDELTA,NUMT,TPRED) - - - -C CALL SUBROUTINE IDCALCYY FOR THE PARAMETERS IN PX. -C THIS IS A VERSION OF THE ID PROGRAM WHICH CALCULATES THE PREDICTED -C VALUES OF Y(I,J) (OUTPUT CONCENTRATION OF THE JTH OUTPUT EQ. AT TIME -C TPRED(I),I=1,NUMT), ASSUMING THE GIVEN GRID PT. NOTE THAT IN -C DCALCYY, THE PREDICTED VALUES ARE SUPPLIED IN TPRED, RATHER THAN -C INPUT VIA COMMON/OBSER FROM THE PATIENT'S DATA FILE. ALSO, THE NO. -C OF OBSERVED TIMES IS NUMT, RATHER THAN M WHICH IS SUPPLIED VIA -C COMMON/SUM2. AND NOTE THAT NUMT AND TPRED(.) ARE FOUND FROM THE CALL -C TO CALCTPRED2 ABOVE. - - CALL IDCALCYY(NVAR+NOFIX,NDIM,PX,TPRED,NUMT,YYPRED,NUMEQT) - - DO J = 1,NUMEQT - -C INEXTTIM WILL BE THE INDEX OF THE NEXT OBSERVATION TIME. INITIALIZE -C IT TO BE 1. - - INEXTTIM = 1 - -C THE AUC STARTS AT 0 AT TPRED(1), WHICH WILL BE 0. THEN IT WILL -C BE UPDATED FOR EACH INTERVAL, USING THE TRAPEZOIDAL RULE. - - DO I = 1,NUMT - - IF(I .EQ. 1) AUC = 0.D0 - -C AS OF BESTDOS116.FOR, AUCs IN THE "FUTURE" ARE RELATIVE TO THE -C BEGINNING OF THE "FUTURE", WHICH OCCURS AT TNEXT. SO SET AUC BACK -C TO 0 AT TIME TNEXT. - -C NO! AS OF BESTDOS118.FOR, THE AUCs WILL BE CUMULATIVE FROM TIME 0 IN -C THE "PAST". SO COMMENT OUT THE CODE BELOW TO CALL THESAME, AND -C COMMENT OUT THE RESETTING OF AUC IF ISAME = 1. - -C CALL THESAME(TPRED(I),TNEXT,ISAME) - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TPRED(I) = TNEXT, -C OR AT LEAST, THEY ARE WITHIN 1.D-10 OF EACH OTHER. IN THIS CASE, -C SET AUC BACK TO 0. - - IF(I .GT. 1) THEN - DELTA = TPRED(I) - TPRED(I-1) - AUC = AUC + (YYPRED(I,J) + YYPRED(I-1,J))/2.D0 * DELTA -C IF(ISAME .EQ. 1) AUC = 0 - ENDIF - -C IF THE CURRENT TPRED(I) IS THE NEXT OBSERVATION TIME, THEN STORE THE -C AUC INTO PRED(I,J). - - CALL THESAME(TPRED(I),TIM(INEXTTIM),ISAME) - -C IF ISAME RETURNS FROM SUBROUTINE THESAME AS 1, TPRED(I) = THE NEXT -C OBSERVATION TIME, TIM(INEXTTIM), OR AT LEAST, THEY ARE WITHIN 1.D-10 -C OF EACH OTHER. IN THIS CASE, STORE THE AUC INTO PRED(INEXTTIM,J). - - IF(ISAME .EQ. 1) THEN - PRED(INEXTTIM,J) = AUC - INEXTTIM = INEXTTIM + 1 - END IF - - END DO -C THE ABOVE END DO IS FOR THE DO I = 1,NUMT LOOP. - - END DO -C THE ABOVE END DO IS FOR THE DO J = 1,NUMEQT LOOP. - - - ENDIF -C THE ABOVE ENDIF IS FOR THE IF(ITARGET .EQ. 2) CONDITION. - - -C NOW CALCULATE WSS. - -C NOTE THAT YO(I,J),I=1,NOBSER; J=1,NUMEQT ARE THE "TARGET" OBSERVED -C VALUES WHICH WERE READ FROM THE PATIENT DATA FILE BY SUBROUTINE -C FILRED (AND PLACED INTO COMMON/OBSER). MUST CHECK YO VALUES FOR -99 - -C (MISSING VALUE CODE), AND IGNORE ANY IN THE FOLLOWING LOOPS. -C ALSO NOTE THAT YOO(.,.) IS SET = YO(.,.) IN THE LOOPS BELOW SO YOO -C CAN BE PASSED BACK TO SUBROUTINE CALCS. - - - SUM = 0.D0 - DO I=1,NOBSER - DO J=1,NUMEQT - IF(YO(I,J) .NE. -99) - 1 SUM = SUM + (PRED(I,J) - YO(I,J))**2.D0 - YOO(I,J) = YO(I,J) - END DO - END DO - - WSS = SUM - - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE CALCPRED(PX,PRED) - -C THIS ROUTINE IS CALLED BY SUBROUTINE WSUMSQ TO CALCULATE PRED, THE -C ARRAY OF PREDICTED CONCENTRATIONS, BASED ON THE DOSES, DOSE TIMES, -C AND OBSERVATION TIMES IN COMMON/OBSER, AND THE PARAMETER VECTOR -C PX, WHICH INCLUDES BOTH RANDOM AND FIXED VALUES. - -C INPUT ARE: - -C PX = VECTOR OF RANDOM AND FIXED PARAMETER VALUES. - -C INFORMATION FROM A SUBJECT DATA FILE WHOSE INFO IS PASSED TO THE -C ROUTINES IN THIS MODULE VIA COMMONS /OBSER/, /CNST/, /CNST2/, AND -C /SUM2/. - - -C OUTPUT IS: - -C PRED(I,J),I=1,M; J=1,NUMEQT THE PREDICTED CONCENTRATION VALUES -C (SEE ABOVE). - -C----------------------------------------------------------------------- -C NOTE: CALCPRED IS A VARIATION OF THE MAIN ROUTINE IN idm1x3.f. - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION PX(32),P(32),PRED(594,MAXNUMEQ) - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/PARAMD/ P - -C*****INITIALIZE PROGRAM***** - - CALL SYMBOL - -C THE ABOVE CALL OBTAINS N AND NP AND NTLAG VIA COMMON/CNST ... - -C PUT MODEL PARAMETER VALUES (RANDOM AND FIXED) INTO P. - - DO I=1,NP - P(I) = PX(I) - END DO - - CALL GETPRED(PRED) - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE GETPRED(PRED) - -C PROGRAM TO DETERMINE PRED(I) = PREDICTED CONCENTRATION AT TIME I, -C GIVEN P IN COMMON/PARAMD. - -C NOTE THAT THIS ROUTINE IS BASED ON idm1x14.f IN THE NPAG PROGRAM. - - IMPLICIT REAL*8(A-H,O-Z) - COMMON/BOLUSCOMP/NBCOMP - COMMON/SUM2/ M,NPNL - COMMON/OBSER/ TIM,SIG,RS,YO,BS - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/INPUT/ R,B - COMMON/PARAMD/ P - COMMON/CNST2/ NPL,NOS,NDRUG,NADD - COMMON/STATE/ X - COMMON/ERROR/ERRFIL - PARAMETER(MAXNUMEQ=7) - -C COMMON/ERR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. - - - DIMENSION X(20),P(32),TIM(594),SIG(5000),SIGO(5000),R(37), - 1 RS(5000,34),RSO(5000,34),YT(MAXNUMEQ),YO(594,MAXNUMEQ), - 2 BS(5000,7),Y(594,MAXNUMEQ),B(20),NBCOMP(7), - 3 PRED(594,MAXNUMEQ),FA(7),TLAG(7),XSTORE(100,20),XPRED(20) - - CHARACTER ERRFIL*20 - - -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - -C NOTE THAT AS OF CALCBST15.FOR, THE DIMENSIONS OF 6 IN XSTORE AND -C XPRED HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN -C ALL ALONG (I.E., THE SAME AS FOR X). - -C NOTE THAT THE DIMENSIONS RELATED TO THE NO. OF OUTPUT EQS. IN -C YO, YT, Y AND PRED ARE CHANGED TO MAXNUMEQ (FROM 6). NUMEQT COULD NOT -C BE USED BECAUSE THESE ARRAYS WERE NOT PASSED TO THIS ROUTINE AS -C DUMMY ARGUMENTS. - -C NOTE THAT "7" IN THE ABOVE ARRAYS INDICATE THE NO. OF DRUGS ALLOWED. - -C R(7) CHANGED TO R(20) <-- No. of 'rate inputs' -C B(3) CHANGED TO B(20) <-- No. of different bolus inputs -C CHANGED X(3) TO X(20) <-- No. of compartments -C IC(10) CHANGED TO IC(20) <-- Initial conditions in compartments; -C should have been changed to 20 previously (like X,B). -C NBCOMP(10) CHANGED TO NBCOMP(20) <-- Same remarks as for IC. -C P(10) CHANGED TO P(32) <-- No. of parameters - - -C*****ODE CONSTANTS AND INITIALIZATION***** - - KNS=1 - KNT=1 - -C NOTE THAT KNT IS THE RUNNING INDEX OF THE NEXT OBSERVATION TIME, -C AND KNS IS THE RUNNING INDEX OF THE NEXT DOSAGE TIME. - - T=0.0D0 - -C INITIALIZE ISKIPBOL = 0. SEE CODE BELOW. IT IS ONLY NEEDED FOR A -C STEADY STATE DOSE SET WHICH HAS BOLUS DOSES. - - ISKIPBOL = 0 - - - - DO I = 1,NDRUG - R(2*I-1) = 0.D0 - END DO - -c AS OF idm1x7.f, instead of R(1) = 0, the code has been changed to -c set R(2*I-1) = 0, for I = 1,NDRUG. I.E., All IV rates for all NDRUG -c drugs are initialized to be 0 ... in case the 1st obs. time is 0, -c which means that OUTPUT is called before the R(I) are set below. - - -C CALL SUBROUTINE GETFA IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETFA IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF FA FOR EACH -C OF THE NDRUG DRUGS. - -C AS OF idm1x13.f, BEFORE CALLING GETFA, MUST SET -C THE R(.) IN CASE ANY OF THE FA(.) ARE FUNCTIONS OF THE -C COVARIATES WHICH ARE ESTABLISHED FROM THE R(.) VALUES IN -C GETFA. - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - CALL GETFA(FA) - - -C NOTE THAT NBCOMP(I),I=1,NDRUG WAS SET IN SUBROUTINE SYMBOL AND - -C PASSED TO THIS ROUTINE VIA COMMON/BOLUSCOMP. - - -C As of idm1x12.f, the code to save ND0, SIGO, RSO, is moved to before -c the IF(N .EQ. 0) GO TO 75 statement. The reason is that before this -c routine returns, ND, SIG, and RS are reset back to these values, -c even if N = 0, and so they must be established at this time. - -C AS OF idm1x9.f, SAVE ND, SIG, AND RS WHETHER OR NOT NTL = 1, SINCE -C IF THERE ARE STEADY STATE DOSE SETS, THE FIRST SIG(.) VALUE IN EACH -C SET WILL BE CHANGED TO BE 0 BELOW. - - NDO = ND - DO I=1,ND - SIGO(I) = SIG(I) - DO J=1,NI - RSO(I,J) = RS(I,J) - END DO - END DO - - -C IF N = 0, THE OUTPUT EQUATION(S) FOR Y ARE CODED EXPLICITLY INTO -C SUBROUTINE OUTPUT, AND NO D.E. SOLUTIONS (VIA USERANAL/DIFFEQ) ARE - -C TO BE USED. IN THIS CASE, SKIP THE CODE REGARDING INITIAL CONDITIONS -C OF THE COMPARTMENTS, SINCE THEY ARE IRRELEVANT (I.E., THE COMPARTMENT -C AMOUNTS DON'T NEED TO BE INITIALIZED SINCE THEY WON'T BE UPDATED BY -C INTEGRATING D.E.'S). IN FACT, COULD PROBABLY SKIP TIMELAGS TOO, -C SINCE THEY CHANGE THE TIME THAT BOLUS DOSES ARE GIVEN, AND THIS -C THEORETICALLY ONLY AFFECTS COMPARTMENT AMOUNTS (WHICH ARE NOT USED - -C IF N = 0), BUT JUST SKIP INITIAL CONDITIONS FOR NOW. - - IF(N .EQ. 0) GO TO 75 - - -C CALL SUBROUTINE GETIX IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETIX IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF X (THE INITIAL -C COMPARTMENT AMOUNT) FOR EACH OF THE N COMPARTMENTS. - - CALL GETIX(N,X) - - - -C CALL SUBROUTINE GETTLAG IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETTLAG IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF THE TIMELAG -C FOR EACH OF THE NDRUG DRUGS. - - 75 CALL GETTLAG(TLAG) - -C IF ANY TLAG(.) VALUES RETURN AS .NE. 0, THEN, CALL SUBROUTINE SHIFT -C TO ADJUST THE DOSAGE REGIMEN APPROPRIATELY. - - NTL = 0 - DO ID = 1,NDRUG - IF(TLAG(ID) .NE. 0) NTL = 1 - END DO - - IF(NTL .EQ. 1) THEN - -C STORE INCOMING VALUES IN ND, SIG, AND RS (WHICH CONTAINS BS VALUES) -C SINCE THEY WILL BE CHANGED IN THE CALL TO SUBROUTINE SHIFT, WHICH -C "SHIFTS" THE DOSAGE REGIMEN MATRIX TO ACCOUNT FOR THE TIMELAG -C PARAMETER(S), TLAG(I). AT THE END OF THIS ROUTINE, THE VALUES IN ND, -C SIG, AND RS WILL BE RESET TO THEIR INCOMING VALUES - TO BE READY FOR -C THE NEXT CALL TO THIS ROUTINE WITH POSSIBLY DIFFERENT VALUES FOR -C TLAG(I). - - - CALL SHIFT(TLAG,ND,SIG,NDRUG,NADD,RS) - - -C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NTL .EQ. 1) CONDITION. - - IF(TIM(KNT).GE.SIG(KNS)) GO TO 12 - IF(TIM(KNT).NE.0.0D0) GO TO 45 - -C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) -C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. - - CALL OUTPUT(0.D0,YT) - DO 2000 I=1,NOS -2000 Y(KNT,I)=YT(I) - KNT=KNT+1 - GO TO 45 - -12 IF(TIM(KNT).GT.SIG(KNS)) GO TO 13 - IF(TIM(KNT).NE.0.0D0) GO TO 45 - -C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) -C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. - - CALL OUTPUT(0.D0,YT) - DO 2005 I=1,NOS -2005 Y(KNT,I)=YT(I) - KNT=KNT+1 - -13 IF(SIG(KNS) .GT. 0.0D0) GO TO 45 - -C CHECK TO SEE IF SIG(KNS) < 0. IF SO, IT MEANS THAT 100 STEADY STATE -C DOSES SHOULD NOW BE APPLIED WITH AN INTERDOSE INTERVAL EQUAL TO -C -SIG(KNS). - - ISTEADY = 0 - - IF(SIG(KNS) .LT. 0.D0) THEN - - ISTEADY = 1 - NSET = 1 - -C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE -C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 -C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... -C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. -C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE -C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE -C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE -C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC -C OF PREDLAST3 REQUIRES). - -C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT -C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS -C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF -C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE -C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. - -C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF -C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL -C INTEGRATED THROUGH, WHICHEVER COMES FIRST. - - DOSEINT = -SIG(KNS) - -C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START -C OF 100 DOSE SETS THAT BEGIN AT TIME 0. - - - SIG(KNS) = 0 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. - - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - IF(NDRUG .EQ. 0) GO TO 81 - -C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT -C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED -C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. - - CALL GETFA(FA) - - - IF(N .EQ. 0) GO TO 120 - - DO I=1,NDRUG - X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS,I)*FA(I) - END DO - -C NOTE THAT FA(I) IS THE FRACTION OF DRUG AVAILABLE FROM A BOLUS INPUT -C FOR DRUG I INTO ITS ABSORPTIVE COMPARTMENT. - - GO TO 81 - -120 DO I=1,NDRUG - B(I)=BS(KNS,I)*FA(I) - END DO - -81 KNS = KNS+1 - - -C*****INTEGRATION OF EQUATIONS***** - - -C DETERMINE IF, OBSER(ID=0), OR DOSE(ID=1), OR BOTH(ID=2). - -45 IF(KNS .GT. ND) GO TO 15 - - -C CODE CHANGE BELOW FOR idm1x8.f. - - IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) THEN - -C AS OF idm1x7.f, A TIME RESET NO LONGER REQUIRES ALL INITIAL -C COMPARTMENT AMOUNTS TO BE RESET TO 0. THIS IS BECAUSE A TIME RESET -C NO LONGER HAS TO MEAN THAT AN "INFINITE" AMOUNT OF TIME HAS OCCURRED -C WITH NO DOSING; IT CAN ALSO NOW MEAN THAT AN "INFINITE" AMOUNT OF -C TIME HAS OCCURRED WITH UNKNOWN DOSING (IN THIS CASE, SUBROUTINE -C GETIX WILL BE CALLED BELOW TO ESTABLISH INITIAL CONDITIONS FOR THIS -C TIME PERIOD). - -C ADVANCE KNS TO THE NEXT VALUE THAT HAS SIG(KNS) .LE. 0. I.E., ONCE -C TIMN(KNT) = 0, IT MEANS THAT WE ARE DONE WITH THE OUTPUT OBS. -C TIMES IN THE PREVIOUS SECTION --> THERE IS NO POINT IN CONTINUING -C TO INTEGRATE TILL THE END OF THE DOSES IN THE PREVIOUS SECTION -C (IF THERE ARE ANY). - - DO IKNS = KNS,ND - IF(SIG(IKNS) .LE. 0.D0) GO TO 110 - END DO - - -C TO GET HERE MEANS THAT NO VALUE IN SIG(.) FROM KNS TO ND HAS A -C VALUE .LE. 0, AND THIS IS AN ERROR. IT MEANS THAT THE PATIENT DATA -C FILE HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING -C DOSE RESET ROW. TELL THE USER AND STOP. - - WRITE(*,111) ND,KNS,SIG(KNS) -111 FORMAT(//' IN SUBROUTINE GETPRED, THE CURRENT SUBJECT HAS AN'/ - 1' OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE'/ - 2' RESET ROW. THE PROGRAM NOW STOPS. '// - 3' REVIEW YOUR PATIENT FILES AND CORRECT THE ERROR.'// - 4' NOTE THAT THE ',I4,' DOSE TIMES (POSSIBLY ALTERED BY TIMELAGS'/ - 5' ARE THE FOLLOWING (AND THERE IS NO TIME .LE. 0 AFTER TIME'/ - 6' NO. ',I4,' WHICH HAS CORRESPONDING TIME ',F15.4,'):') - - - DO I = 1,ND - WRITE(*,*) SIG(I) - END DO - - OPEN(47,FILE=ERRFIL) - WRITE(47,111) ND,KNS,SIG(KNS) - DO I = 1,ND - WRITE(47,*) SIG(I) - END DO - CLOSE(47) - - - CALL PAUSE - STOP - - - 110 KNS = IKNS - - -C THERE ARE TWO POSSIBILITES AT THIS POINT, EITHER SIG(KNS) = 0 -C OR SIG(KNS) < 0. - -C IF SIG(KNS) = 0, THIS REPRESENTS A TIME RESET (T WILL BE SET = 0 -C BELOW) WITH A SINGLE DOSE LINE TO START. IN THIS CASE, CALL GETIX -C AGAIN (JUST AS WAS DONE NEAR THE TOP OF THIS ROUTINE) TO OBTAIN -C INITIAL COMPARTMENT AMOUNTS. NOTE THAT BY DEFAULT, IN GETIX, ALL -C COMPARTMENT AMOUNTS ARE SET = 0 (WHICH WOULD BE THE CASE IF IN THE -C LONG TIME PERIOD BETWEEN THE LAST SET OF DOSES AND THIS NEW -C BEGINNING, NO DOSES HAVE BEEN GIVEN). BUT THE USER MAY ALSO HAVE -C CODED INTO GETIX EQUATIONS THAT SET ONE OR MORE OF THE X(I) TO -C FUNCTIONS OF COVARIATE AND PARAMETER VALUES (WHICH WOULD BE THE -C SITUATION IF AN UNKNOWN DOSING REGIMEN HAS TAKEN PLACE BUT IT -C DOESN'T MATTER WHAT IT WAS BECAUSE THE PATIENT COMES TO A LAB AND -C SIMPLY HAS HIS COMPARTMENT VALUES ESTABLISHED BEFORE CONTINUING -C WITH THE OTHER VALUES IN HIS PATIENT FILE). - -C IF SIG(KNS) < 0, THIS REPRESENTS A TIME RESET WITH A STEADY STATE -C SET OF 100 DOSES ABOUT TO BEGIN. IN THIS CASE, WE ASSUME THAT THE -C PATIENT IS ABOUT TO GET 100 SETS OF DOSES SO THAT HIS COMPARTMENT -C AMOUNTS WILL ACHIEVE STEADY STATE VALUES. THESE STEADY STATE VALUES -C WILL BE ESTIMATED IN THE BLOCK OF CODE BELOW THAT STARTS WITH -C IF(ISTEADY .EQ. 1). IN THIS CASE, WE WILL STILL CALL GETIX TO -C MAKE SURE THAT ANY RESIDUAL COMPARTMENT AMOUNTS FROM A PREVIOUS -C SET OF DOSES IS ZEROED OUT (OR SET = VALUES AS DETERMINED BY -C SUBROUTINE GETIX). - -C AS OF idm1x14.f, BEFORE CALLING GETIX, MUST SET -C THE R(.) IN CASE ANY OF THE INITIAL CONDITIONS FOR THE X(.) -C ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM THE -C R(.) VALUES IN GETFA. - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - - - CALL GETIX(N,X) - -C MUST ALSO RESET T = 0 SINCE THE INTEGRATION WILL AGAIN START FROM -C TIME 0. - - T = 0.D0 - -C IF SIG(KNS) .LT. 0, THIS IS NOT ONLY A TIME RESET, IT IS THE -C BEGINNING OF A STEADY STATE DOSE SET. IN THIS CASE, APPLY 100 -C STEADY STATE DOSES WITH AN INTERDOSE INTERVAL EQUAL TO -SIG(KNS). - - ISTEADY = 0 - - IF(SIG(KNS) .LT. 0.D0) THEN - - ISTEADY = 1 - NSET = 1 - -C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE -C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 -C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... -C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. -C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE -C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE - -C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE -C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC -C OF PREDLAST3 REQUIRES). - - -C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT -C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS -C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF -C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE -C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. - -C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF -C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL -C INTEGRATED THROUGH, WHICHEVER COMES FIRST. - - DOSEINT = -SIG(KNS) - -C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START -C OF 100 DOSE SETS THAT BEGIN AT TIME 0. - - SIG(KNS) = 0 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) CONDITION. - - - - IF(TIM(KNT) .NE. SIG(KNS)) GO TO 20 - ID=2 - TOUT=TIM(KNT) - KNT=KNT+1 - KNS=KNS+1 - - IF(N .EQ. 0) GO TO 31 - GO TO 30 - -20 IF(TIM(KNT) .GT. SIG(KNS) .AND. SIG(KNS) .GT. 0) GO TO 25 - - -15 ID=0 - TOUT=TIM(KNT) - KNT=KNT+1 - IF(N .EQ. 0) GO TO 31 - GO TO 30 - -25 ID=1 - TOUT=SIG(KNS) - KNS=KNS+1 - IF(N .EQ. 0) GO TO 31 - -30 CONTINUE -32 IF(N .NE. -1) CALL USERANAL(X,T,TOUT) - IF(N .EQ. -1) CALL ANAL3(X,T,TOUT) - - - -C IF ISTEADY = 1, THIS IS INSIDE A STEADY STATE DOSE SET. CHECK TO SEE -C IF TOUT IS A MULTIPLE OF DOSEINT. IF SO, RECORD THE COMPARTMENT -C AMOUNTS. THEN, AFTER COMPARTMENT AMOUNTS HAVE BEEN STORED FOR AT -C LEAST THE 1ST 5 MULTIPLES OF DOSEINT, STOP AND CALL SUBROUTINE -C PREDLAST3 WHICH PREDICTS THE FINAL (STEADY STATE) COMP. AMOUNTS -C AFTER THE LAST (100TH) DOSE SET. - -C IF PREDLAST3 HAS PREDICTED VALUES WHICH "CONVERGE", ASSIGN THE -C PREDICTED VALUES TO X, INCREASE KNS TO BE THE INDEX OF THE FIRST -C DOSE EVENT WHICH OCCURS AFTER THE STEADY STATE DOSE SET ENDS AND -C CONTINUE. - -C IF PREDLAST3 VALUES DON'T CONVERGE, CONTINUE THE PROCESS WITH -C COMPARTMENT AMOUNTS FOR MULTIPLES 2 - 6 OF DOSEINT, TEST FOR -C "CONVERGENCE", ETC. THIS PROCESS CONTINUES UNTIL "CONVERGENCE" IS -C ACHIEVED FOR A SET OF 5 COMPARTMENT AMOUNTS (OR SETS OF AMOUNTS IF -C NDRUG IS > 1), OR UNTIL ALL 100 DOSE SETS IN THE STEADY STATE -C REGIMEN HAVE FINISHED. - - IF(ISTEADY .EQ. 1) THEN - - -C THE NEXT DOSE SET END TIME IS DOSEINT*NSET. IF TOUT = DOSEINT*NSET, -C STORE THE COMPARTMENT AMOUNTS. IF NSET .GE. 5, CALL PREDLAST3 AND -C PROCEED AS INDICATED ABOVE. - - CALL THESAME(TOUT,DOSEINT*NSET,ISAME) - - IF(ISAME .EQ. 1) THEN - - NN = N - IF(N .EQ. -1) NN = 3 - - DO J = 1,NN - XSTORE(NSET,J) = X(J) - END DO - - - IF(NSET .GE. 5) THEN - - CALL PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) - - - IF(ICONV .EQ. 1) THEN - -C SINCE THE PREDICTED VALUES ARE CONSIDERED ACCURATE (I.E., -C "CONVERGENCE WAS ACHIEVED IN PREDLAST), RESET ISTEADY TO 0, -C WHICH MEANS THAT THE STEADY STATE DOSES ARE FINISHED; ASSIGN THE -C COMPARTMENT AMOUNTS TO BE THE PREDICTED VALUES; AND SET KNS TO THE -C FIRST DOSE EVENT AFTER THE END OF THE STEADY STATE DOSE SET. ALSO, -C SET T = THE ENDING TIME OF THE STEADY STATE DOSE SET = 100*DOSEINT, -C SINCE THAT IS WHAT IT WOULD HAVE BEEN HAD ALL 100 DOSE SETS BEEN -C RUN. - - ISTEADY = 0 - - DO J = 1,NN - X(J) = XPRED(J) - END DO - - T = 100.D0*DOSEINT - - -C ADVANCE KNS TO BE THE FIRST DOSE PAST THE 100 DOSE SETS IN THIS -C STEADY STATE SET. NOTE THAT THIS SET ENDS BEFORE 100*DOSEINT, SO -C FIND THE FIRST SIG(.) THAT IS .GE. 100*DOSEINT, OR THAT IS = 0 -C (WHICH SIGNIFIES A TIME RESET) OR THAT IS < 0 (WHICH SIGNIFIES -C ANOTHER STEADY STATE SET). - - DO I = KNS,ND - IF(SIG(I) .GE. 100.D0*DOSEINT .OR. SIG(I) .LE. 0.D0) THEN - KNSNEW = I - GO TO 100 - - ENDIF - END DO - -C TO GET HERE MEANS THAT THERE ARE NO DOSE TIMES PAST THE END OF THIS -C STEADY STATE DOSE SET. IN THIS CASE, SET KNS TO ND+1. - - KNS = ND+1 - GO TO 200 - - 100 KNS = KNSNEW - 200 CONTINUE - - -C SET ISKIPBOL = 1 WHENEVER CONVERGENCE OCCURS IN -C THE STEADY STATE DOSES SINCE IN THIS CASE, WE DON'T WANT TO -C REAPPLY THE LAST BOLUS FROM THE STEADY STATE SET BELOW LABEL 83. - - ISKIPBOL = 1 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICONV .EQ. 1) CONDITION. - -C IF ICONV = 0, ISTEADY IS STILL = 1, -C WHICH MEANS THAT THE ATTEMPT TO PREDICT THE FINAL (STEADY STATE) -C COMPARTMENT AMOUNTS CONTINUES. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NSET .GE. 5) CONDITION. - -C SINCE ISAME = 1, THE END OF THE SET NO. NSET HAS OCCURRED --> -C INCREASE NSET BY 1. - - - NSET = NSET + 1 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISTEADY .EQ. 1) CONDITION. - - - -31 CONTINUE - -C RECORD OBSERVATION AND SUPPLY NEW DOSE - - IF(ID .EQ. 1) GO TO 35 - KNTM1=KNT-1 - -C NOTE THAT THE TIME AT WHICH THE OUTPUT IS DESIRED IS TIM(KNTM1); THIS -C IS CLEAR SINCE THE RETURNING VALUE(S) IN YT ARE PUT INTO ROW NO. -C KNTM1 OF Y. - - CALL OUTPUT(TIM(KNTM1),YT) - - DO 2010 I=1,NOS -2010 Y(KNTM1,I)=YT(I) - -55 IF(ID.EQ.0) GO TO 40 - - 35 CONTINUE - - IF(NI .EQ. 0) GO TO 83 - - DO I=1,NI - R(I)=RS(KNS-1,I) - END DO - -C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT -C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED -C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. - - - CALL GETFA(FA) - - -83 IF(NDRUG .EQ. 0 .OR. N .EQ. 0) GO TO 82 - -C ADDING N .EQ. 0 TO ABOVE IF STATEMENT SHOWS CLEARLY THAT IF -C N = 0 (IN WHICH CASE ANALYTIC SOLUTIONS ARE CODED DIRECTLY INTO -C SUBROUTINE OUTPUT, WHICH MAKES THE COMPARTMENT AMOUNTS IRRELEVANT) -C SETTING VALUES FOR THE COMPARTMENTS, X, IS UNNECESSARY. - - -C IF ISKIPBOL = 1, DO NOT APPLY BOLUSES FROM DOSE KNS-1, SINCE THESE -C BOLUSES WERE PART OF THE STEADY STATE DOSE SET WHICH ALREADY HAD -C BOLUSES (EFFECTIVELY) APPLIED ABOVE WHERE "CONVERGENCE" OF THE -C STEADY STATE DOSE SET WAS OBTAINED. - - IF(ISKIPBOL .EQ. 0) THEN - DO I=1,NDRUG - X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS-1,I)*FA(I) - END DO - ENDIF - -C RESET ISKIPBOL = 0 HERE. IF IT IS NOW = 1, IT MEANS THAT -C THE ABOVE APPLICATION OF BOLUSES WAS SKIPPED SINCE THERE HAS JUST -C BEEN A STEADY STATE SET OF DOSES WHICH CONVERGED (AND WE DON'T -C WANT THE LAST BOLUS DOSE REAPPLIED). BUT, GOING FORWARD, ISKIPBOL -C SHOULD BE SET AGAIN TO 0 SO THE ABOVE APPLICATION OF BOLUSES WILL -C OCCUR WHENEVER THERE IS A NEW BOLUS TO BE APPLIED. - - ISKIPBOL = 0 - - -82 CONTINUE - -C CHECK STOPPING TIME. - - -40 IF(KNT .LE. M) GO TO 45 - -C ESTABLISH PRED(I,J), I=1,M; J=1,NOS. - - - DO J=1,NOS - DO I=1,M - PRED(I,J) = Y(I,J) - END DO - END DO - -C AS OF idm1x9.f, RESTORE THE VALUES FOR ND, SIG, AND RS, IN CASE -C THIS MODEL HAS TIME LAGS OR STEADY STATE DOSES - TO BE READY FOR THE -C NEXT CALL TO THIS ROUTINE. - - ND = NDO - DO I=1,ND - SIG(I) = SIGO(I) - DO J=1,NI - RS(I,J) = RSO(I,J) - END DO - END DO - -C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE MAKEVEC(NVAR,NOFIX,IRAN,X,VALFIX,PX) - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION IRAN(32),X(30),VALFIX(20),PX(32) - -C THIS ROUTINE, CALLED BY MAIN, INPUTS NVAR, NOFIX, IRAN, X, AND -C VALFIX, AND RETURNS PX(I) = A COMBINATION OF THE VALUES IN X AND -C VALFIX IN THE PROPER ORDER (AS DETERMINED BY IRAN). - - NNNVAR=0 - NNNFIX=0 - - DO I=1,NVAR+NOFIX - - IF(IRAN(I) .EQ. 1) THEN - NNNVAR=NNNVAR+1 - PX(I) = X(NNNVAR) - ENDIF - - IF(IRAN(I) .EQ. 0) THEN - NNNFIX=NNNFIX+1 - PX(I) = VALFIX(NNNFIX) - ENDIF - - END DO - - RETURN - END - -C IDM1X15.FOR 7/7/14 - -C IDM1X15.FOR = idmx1x15.f, EXCEPT THE TWO WRITE STATEMENTS TO FILE -C 25 ARE REMOVED, SINCE FILE 25 IS NOT ACTIVE IN THIS PROGRAM. - -C AND, IN SUBROUTINE FUNC, COMMON/ERROR/ERRFIL IS ADDED; ERRFIL IS -C DECLARED CHARACTER*20; AND FORMAT 111 AND SIG(.) ARE WRITTEN TO -C ERRFIL JUST BEFORE THE PROGRAM STOPS IF THE PATIENT DATA FILE -C HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE -C RESET ROW. - -c----------------------------------------------------------------------- - -c idm1x15.f 3/6/14 - -c idm1x15 has the following changes from idm1x14: - -c 1. In Subroutine FUNC, the dimensions related to the no. of output -c equations have been changed from 6 to NUMEQT OR MAXNUMEQ (see -c comments in that routine). - -c 2. In Subroutines FUNC and PREDLAST3, the dimensions of 6 in XSTORE, -c XPRED, and COMP have been changed to 20, as they should have been -c all along (i.e., this represents the maximum no. of compartments -c allowed). - -c----------------------------------------------------------------------- - -c idm1x14.f 10/11/12 - -c idm1x14 has one correction from idm1x13: - -c THE R(.) ARE SET = RS(.,.) BEFORE GETIX IS CALLED IN THE TIME RESET -c SECTION OF SUBROUTINE FUNC. NOT DOING THIS WOULD MEAN THAT IF THE -C INITIAL CONDITIONS FOR THE X(.) ARE FUNCTIONS OF THE COVARIATES -C (ESTABLISHED IN GETIX FROM THE R(.) VALUES), THEY WOULD BE ASSIGNED -C VALUES BASED ON COVARIATES FROM A PREVIOUS DOSAGE LINE IN THE -C PATIENT'S DATA FILE, RATHER THAN THE LINE WHICH IS THE DOSE RESET -C LINE. - -c----------------------------------------------------------------------- - -c idm1x13.f 9/27/12 - -c idm1x13 has the following bug correction to idm1x12: - -C IN SUBROUTINE FUNC, BEFORE -C THE FIRST CALL TO GETFA, THE R(.) ARE SET = RS(.,.) IN CASE ANY OF -C THE FA(.) ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM -C THE R(.) VALUES IN GETFA. IN ADDITION, PRIOR TO THE 2 SECTIONS WHERE -C THE FA(.) ARE USED, GETFA IS CALLED SO THAT THE FA(.) ARE UPDATED TO -C CURRENT VALUES, BASED ON THE MOST RECENT COVARIATE VALUES IN THE -C PATIENT'S DATA FILE. IN PREVIOUS PROGRAMS, IT WAS SIMPLY ASSUMED -C THAT THE FA(.) WERE FUNCTIONS OF THE PARAMETERS, BUT NOT THE -C COVARIATES, AND SO THIS WASN'T NECESSARY. BUT THE CODE IN -C TSTMULTI.FOR IMPLIES THAT THE FA(.) COULD BE FUNCTIONS OF THE -C COVARIATES, AND SO THIS CHANGE IS NECESSARY. - -C NOTE THAT SETTING THE R(.) TO RS(.,.) BEFORE THE FIRST CALL TO -C GETFA ALSO MEANS THE R(.) WILL BE SET BEFORE GETIX AND GETTLAG ARE -C FIRST CALLED, WHICH AGAIN IS REQUIRED IN CASE THEY ESTABLISH VALUES -C AS FUNCTIONS OF THE COVARIATES IN THE PATIENT DATA FILE. - -c----------------------------------------------------------------------- - -c idm1x12.f 7/25/12 - -c idm1x12 has the following change to idm1x11: - -c In SUBROUTINE FUNC, the code to save ND0, SIGO, RSO, is moved to -c before the IF(N .EQ. 0) GO TO 75 statement. The reason is that -c before this routine returns, ND, SIG, and RS are reset back to these -c values, even if N = 0, and so they must be established at this time. - -c----------------------------------------------------------------------- - -c idm1x11.f 5/25/12 - -c idm1x11 has the following changes from idm1x10: - -C IT HAS CODE CHANGES IN SUBROUTINE PREDLAST3 TO HANDLE THE CASE WHERE -C PRED1 + PRED3 - 2*PRED2 = 0 --> PREDNEG SHOULD NOT BE CALCULATED. -C USUALLY THIS WILL HAPPEN WHEN THE MODEL/DOSAGE REGIMEN IS SO "EASY" -C TO PREDICT THAT THE 3 PREDICTED VALUES ARE VERY CLOSE TO EACH OTHER, -C AND BY "BAD LUCK" COULD BE IN A LINEAR PROGRESSION. I.E., IF -C PRED1 + DEL = PRED2, AND PRED2 + DEL = PRED3, THEN -C PRED1 + PRED3 - 2*PRED2 = 0. - -C IN THIS CASE, OF COURSE, PREDNEG SHOULD NOT BE CALCULATED SINCE THAT -C WILL RESULT IN A DIVIDE BY 0, OR A NaN IF THE PROGRAM DOES NOT STOP. - -C WHEN THIS HAPPENS (SEE CODE IN PREDLAST3), WHETHER OR NOT CONVERGENCE -C IS ACHIEVED WILL DEPEND SOLELY ON THE TOL1 CRITERION (I.E., THE TOL2 -C CRITERION CANNOT BE USED, AND IS UNNEEDED). - -C----------------------------------------------------------------------- - -c idm1x10.f 4/14/12 - -c idm1x10 has the following changes to idm1x9.f: - -c It is to be used with npageng17.f, which allows steady state doses -c to be boluses as well as IVs. As a result, an additional parameter, -c ISKIPBOL, is used so, in Subroutine FUNC, when convergence occurs in -c a steady state dose set, the last bolus from that set will not be -c reapplied below label 83. - -c----------------------------------------------------------------------- - -c idm1x9.f 3/2/12 - -c idm1x9 has the following bug fix to idm1x8.f. In Subroutine FUNC, the -c code to save ND, SIG, and RS before altering them if there are -c time lag parameters (in the call to GETTLAG) is now executed whether -c or not there are time lag parameters. The reason is that, with steady -c state doses, the first SIG(.) time in a steady state dose set is -c reset to be 0 after the steady state dose is identified. And this -c time must be reset back to be its original negative value at the end -c of the routine so that the next time the routine is called, the -c program will again know when a steady state dose is coming. - -c----------------------------------------------------------------------- - -c idm1x8.f 1/15/12 - -c Corrects bug in Subroutine FUNC - now time resets are identified -c by just the observation time = 0 (i.e., the dose time = 0 is -c no longer required). This is because it is possible for a dose -c time (especially if there are timelags) to be after the last -c observation time in a section of the patient file (before a time -c reset), and if this happens, the program will not be able to -c identify the observation time of 0 as a time reset. - -c----------------------------------------------------------------------- - -c idm1x7.f 11/21/11 - -c idm1x7 has the following changes from idm1x6: - -c 1. It can accommodate steady state dose regimens as created by -c new subroutine NEWWORK1.FOR in npageng16.f. And it has new -c Subroutine PREDLAST3 (both of these 2 new subroutines are based on -c stand-a-lone versions of the same name) which is called by -c Subroutine FUNC to predict the final (steady state) compartment -c amounts. If these predicted values are determined to have -c converged, the rest of the steady state dose set will be skipped -c to save time. Note that predictions start after the end of the -c 5th dose set (out of 100 in each steady state regimen), and -c continue until convergence is reached, or the entire steady state -c dose set has been integrated through. - -C SO THE MAIN CHANGES TO THE CODE ARE: - -C CHECK TO SEE IF A DOSE TIME IS NEGATIVE. IF NOT, PROCEED AS USUAL. IF -C SO, PROCEED AS IF THAT TIME WAS 0, BUT AFTER THE END OF THAT DOSE AND - - -C THE NEXT 4, CALL SUBROUTINE PREDLAST3 TO PREDICT THE STEADY STATE -C COMPARTMENT AMOUNTS AFTER THE 100 DOSES (NOTE THAT THE COMPARTMENT -C AMOUNTS WILL HAVE TO BE FOUND AT THE END OF EACH OF THE STEADY STATE -C DOSES OF COURSE AS THE LOGIC OF PREDLAST3 REQUIRES). IF CONVERGENCE -C IS ACHIEVED, ASSIGN THE COMPARTMENT AMOUNTS TO BE THE PREDICTED -C AMOUNTS AND SET KNS TO BE WHAT IT IS WHEN THESE STEADY STATE DOSE -C SETS HAVE FINISHED. ALSO, SET T = END OF THE STEADY STATE DOSE SET -C SINCE THAT'S WHAT IT WOULD HAVE BEEN HAD ALL THE DOSES BEEN -C INTEGRATED THROUGH. - -c 2. All arrays related to doses (SIG,SIGO,RS,RSO, and BS) in -c Subroutine FUNC have their 500's changed to 5000's. This is because -c each set of 100 steady state doses, with each of up to 7 drugs having -c its own stopping time, could require an extra 100 x 8 dose events, -c and there could be multiple steady state sets (they can occur at the -c start of the dose regimen, or at any time reset point). - -c 3. Near the top of Subroutine FUNC, R(1)=0.0D0 is replaced by setting -c R(2*I-1) = 0.D0, for I = 1,NDRUG. This should have been done when -c the program became a multi-drug program (see comment in FUNC). - -c 4. A time reset no longer requires all initial compartment amounts -c to be reset to 0. This is because a time reset no longer has to mean -c an "infinite" amount of time has occurred with no dosing; it can also -c now mean an "infinite" amount of time has occurred with unknown -c dosing. So Subroutine GETIX will be called to establish initial -c conditions for the new time period (these initial values can of -c course be 0's as was always assumed in previous programs). This is -c the situation where a patient, who previously had doses and -c observations which were recorded while he was in a lab, goes home and -c gets unknown doses over a long time period, and then returns to the -c lab to get a new set of doses and observations, starting with -c observations which establish his initial conditions for this new -c time period. - - -c----------------------------------------------------------------------- - -c idm1x6.f 12/20/10 - -c idm1x6 has the following change to idm1x5: - -c In Subroutine FUNC, it has code that calls Subroutine ANAL3, rather -c than USERANAL if N .EQ. -1. Also, the code to reset X(I),I=1,N to 0 -c where there is a time reset now includes extra code to set -c X(I),I=1,3 to 0 if N .EQ. -1. - -c Note that ANAL3, and the routines it calls are from the Little NPAG - -c program module, IDPC9A.FOR. - -c Note that this module is linked first with bigmlt11.f, and the -c template model file is TSTMULTH.FOR (in which in Subroutine SYMBOL, -c the user is told to code N=-1 if he wants to assume the standard -c 3-compartment linear model with analytic solutions, and in this -c case also establish the 5 parameters, {KE,KA,KCP,KPC,V} of this -c model). - -c----------------------------------------------------------------------- - -c idm1x5.f 4/03/10 - -c idm1x5 has a bug correction to idm1x4. In Subroutine FUNC, in the -c IF(TIM(KNT) .EQ. 0.D0 .AND. SIG(KNS) .EQ. 0.D0) block, the time, -c T, is also reset = 0 since the integration will again start from -c time 0. When this wasn't done (in idm1x4.f), the results were -c unpredictable (depending on how the DVODE integration routines -c treated a (T,TOUT) pair which decreased rather than increased. - -c----------------------------------------------------------------------- - -c idm1x4.f 11/23/09 - -c idm1x4 fixes a bug in the idm1x3 code. Label 75 is moved to in -c front of the CALL GETTLAG(TLAG) statement (see the reason in -c that part of the code). - -c----------------------------------------------------------------------- - -c idm1x3.f 9/18/09 - -c idm1x3 has the following changes from idm1x2: - -c 1. The TLAG and FA vectors, and the initial values for the X array -c will be set by calling new routines (GETTLAG, GETFA, and GETIX, -c respectively) that are part of the model file (the new template is -c TSTMULT.FOR). This means the user can now code explicit formulas -c for these values. As a result, all reference to NTLAG, IC, IFA, and -c IVOL have been removed. - -c 2. The shift subroutine will now be from the module, shift5.f, -c rather than shift4.f. - -c 3. In Subroutine USERANAL, ISTATE is no longer written out. This -c can slow the program a lot if the numerical integrator (DVODE) is -c struggling with the integrations. Instead, the total no. of calls to -c XERRWD (the routine which writes the details of the warnings) is -c written to the screen by the main "engine" module, currently -c bigmlt4.f. - -c Note that this module, along with idm2x3.f, id3x3.f, and shift5.f -c are part of the new "engine", whose main module is bigmlt4.f. - -c----------------------------------------------------------------------- - -c idm1x2.f 8/14/09 - - -c idm1x2 has the following changes from idm1x1: - -c 1. The code for setting initial compartment amounts from initial -c compartment concentrations is changed to reflect the fact that -c now IC(2) refers to the index of the covariates, not the -c column no. of RS (see comment in code). - -c 2. The code to establish the timelag parameters has changed to -c reflect that NTLAG(I) can now be negative --> in Subroutine -c SHIFT, the associated timelag parameter will now be the -c exponent of the indicated parameter (rather than the parameter -c itself). - -c 3. The code to establish the FA parameters has changed to -c reflect that IFA(I) can now be negative --> the associated FA -c parameter will now be the exponent of the indicated parameter -c (rather than the parameter itself). - - -c idm1x2.f (along with other new modules idm2x2.f and idm3x2.f) are -c still called by bigmlt2.f, but are part of the "engine" for the -c new NPBIG15B.FOR program. - -c----------------------------------------------------------------------- - -c idm1x1.f 5/27/09 - - -c idm1x1.f has the following changes from idfix5g.f: - -c 1. It allows the extra option of setting initial compartment -c amounts from their initial concentrations - see code in Subroutine -c FUNC. - -c 2. It is part of the new Big NPAG "engine", bigmlt2.f, which allows -c patient data files to have "reset" values of 0 in the dosage and -c sampling blocks. Whenever, in Subroutine FUNC, the program sees a -c SIG(.) = 0 and a TIM(.) = 0, it knows that a large enough time has -c passed since the last dose that all compartment amounts are to be -c reset = 0. Subsequent dose and observed value times are then values -c from this point. - -c 3. The first argument to Subroutine OUTPUT is changed from 0.0 to -c 0.D0 in two places. - -c This module, along with idm2x1.f and idm3x1.f are first used in the -c bigmlt2.f program. - -c----------------------------------------------------------------------- - -c idfix5g.f 5-28-02 - - -c idfix5g has the following changes from idfix5f.f: - -c It allows multiple drug inputs (rather than just one drug input). -c The changes required for this are: - -c 1. BS has dimension change from (500,3) to (500,7) -c 2. COMMON/CNST2 is changed to include NDRUG (no. of drugs) and -c NADD (no. of additional covariates), rather than NBI and NRI. -c 3. NTLAG is now a vector instead of a scalar. In particular, -C NTLAG(I) = 0 IF DRUG I'S BOLUS COL. HAS NO TIMELAG PARAMETER; -C K IF DRUG I'S BOLUS COL. HAS A TIMELAG WHOSE VALUE IS -C GIVEN BY PARAMETER NO K. -C 4. IFA, PASSED IN COMMON/FRABS FROM SUBROUTINE SYMBOL IS NOW A VECTOR -C INSTEAD OF A SCALAR. -C IFA(I) = 0 IF DRUG I WILL HAVE FA = 1.0. -C K IF DRUG I WILL HAVE AN FA WHOSE VALUE IS TO BE GIVEN -C BY PARAMETER K. -C 5. THE BOLUS COMPARTMENT NOS., NBCOMP(I), NOW COME VIA -C COMMON/BOLUSCOMP FROM SUBROUTINE SYMBOL, AND THE DIMENSION OF -C NBCOMP HAS BEEN CHANGED TO 7 (MAXIMUM OF 1 PER DRUG) FROM 20. -C 6. ALL OF THE CODE IN SUBROUTINE FUNC RELATED TO NRI AND NBI HAS BEEN -C CHANGED TO BE IN TERMS OF NI AND NDRUG. -C 7. THE CODE RELATED TO CALLING SUBROUTINE SHIFT, INCLUDING THE -C CALLING ARGUMENTS, HAS BEEN CHANGED TO REFLECT THE ABOVE CHANGES -C IN NTLAG (I.E., IT IS NOW A VECTOR RATHER THAN A SCALAR). A NEW -C MODULE, shift3.f (WHICH REPLACES shift2.f) WILL BE LINKED WITH -C THIS MODULE. - -C----------------------------------------------------------------------- - -c idfix5f.f 4-23-02 - -c idfix5f has the following changes to idfix5e: - -c 1. To enable FA to be a parameter value (either fixed or random), -c rather than always be hardcoded = 1.0, the following changes are -c implemented ... - -c The hardcoding of FA = 1.0 and the code for NBCOMP are removed -c from main. In addition, COMMON/BCOMP is removed from the entire -c module. Instead, in SUBROUTINE FUNC, a new COMMON/FRABS/IFA provides -c the value IFA which is the parameter index of the FA value (passed -c from SUBROUTINE SYMBOL) unless it = 0, in which case FA is -c set = 1.0. Also the NBCOMP compartment nos. are now set in -c SUBROUTINE FUNC. - -c 2. COMMONS /OBSER AND /SUM2 (and the arrays in them) are deleted from - -c main. They were not needed. Also, COMMON CNST2 is deleted from main -c since NBI is no longer needed here (since NBCOMP code is removed - -c see no. 1. above). - -c----------------------------------------------------------------------- - -c idfix5e.f 1-22-00 - -c idfix5e has the following changes to idfix5d: - -c It allows the initial conditions of the amounts in the compartments -c to be paramater values, rather than fixed at 0.0. These parameter -c values may be either fixed or random. - - -c To affect this enhancement, the primary change is the code in -c subroutine FUNC which sets the initial conditions based on the -c values in IC which are provided by COMMON/INITCOND from -c SUBROUTINE SYMBOL of the Fortran model file. - -c There are many other changes to simply the code (i.e., a lot of -c code was leftover code which was unused and/or confusing), namely: - -c - Commons ADAPT1, ADAPT2, LPARAM, PRED, TRANS, and PARAM are -c deleted. Variables ISW, IP, and C are deleted. -c - COMMON/PARAMD/P is now in MAIN, FUNC, and JACOB; MAIN and -c FUNCx of idcy_53e.f and idcy_63e.f; and DIFFEQ and OUTPUT of -c the Fortran model file. -c - P is redimensioned 32. It will hold only the parameters of the -c model (although some of those parameters may be initial conditions) -c and there are 20 allowable random paramaters and 12 allowable -c fixed paramaters now. -c - All the code to reverse the paramater order (using PD) and to do -c and undo square root transformations in MAIN and FUNC is removed -c (it was unneeded, and therefore confusing). In particular, all -c references to NPT, NUMYES, NUIC, NUP, NPNL, and NBOT are removed. -c - COMMON ANALYT/IDIFF is removed. IDIFF is unneeded since IDIFF = 0 -c is equivalent to N = 0, and so IDIFF code in FUNC is replaced by -c the equivalent code for N. NEQN is replaced by N. - -c - In SUBROUTINE SUMSQ, COMMON/PARAM is removed, along with PP and P. -c Setting PP(I) = P(I), I=1,NPNL made no sense since PP wasn't used - -c and NPNL was always = 0 anyway. P is removed as an argument to -c SUMSQ (it was unneeded). -c - In FUNC, the If statment at label 83 is changed to include N .EQ. 0 -c since if N = 0, setting compartment values is unnecessary. - - -c idfix5e is part of the big npem program, npbig4.f. - -c----------------------------------------------------------------------- - - SUBROUTINE IDPC(X,SUMSQJ) - -C INPUT ARE: - -C INFORMATION FROM A SUBJECT DATA FILE WHICH HAS BEEN READ IN -C PREVIOUSLY. THIS INFO IS PASSED TO THE OTHER ROUTINES IN THIS -C MODULE BY COMMONS /OBSER/, /CNST/, /CNST2/, AND /SUM2/. - - -C X(I) = ITH COORDINATE OF THE GRID POINT OF INTEREST (INCLUDING FIXED -C PARAMETER VALUES). -C STDEV(I,J) = STD DEV FOR THE ITH OBSERVATION OF THE JTH OUTPUT EQ. -C (INPUT IN BLANK COMMON TO SUBROUTINE FUNC). - -C OUTPUT IS: - -C SUMSQJ = SUM, FOR THIS SUBJECT, OVER I=1,M x NOS (ACTUALLY THE (I,J) -C CONTRIBUTION IS IGNORED IF YO(I,J) = -99 --> MISSING VALUE), OF -C ((YO(I,J)-H(I,J))/STDEV(I,J))**2, WHERE H(I,J) = PREDICTED VALUE OF THE -C JTH OUTPUT EQ AT THE ITH OBSERVATION TIME, ASSUMING THE IGTH GRID -C POINT, X. NOTE THAT M AND NOS ARE INPUT IN COMMONS SUM2 AND CNST2, -C RESPECTIVELY. - -C----------------------------------------------------------------------- - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION X(32),P(32) - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/PARAMD/ P - - -C*****INITIALIZE PROGRAM***** - - CALL SYMBOL - -C THE ABOVE CALL OBTAINS INFO FROM COMMONS. - -C FIND THE SUM OF SQUARES OF DIFFERENCES BETWEEN THE OBSERVED -C VALUES AND THE PREDICTED VALUES (NORMALIZED BY THE ASSAY -C VARIANCE OF EACH OBSERVATION) FOR THIS POINT. - -C PUT MODEL PARAMETER VALUES INTO P. - - DO I=1,NP - P(I)=X(I) - END DO - -C SUMLM RETURNS FROM SUBROUTINE SUMSQ AS THE SUM OF SQUARES -C FOR THIS SET OF (X1,X2,X3,X4,X5) VALUES. - - CALL SUMSQ(SUMLM) - - SUMSQJ=SUMLM - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE FUNC(M,F) - -C FUNCTION TO DETERMINE THE ENTRIES IN F, GIVEN P. - - IMPLICIT REAL*8(A-H,O-Z) - COMMON/BOLUSCOMP/NBCOMP - COMMON/OBSER/ TIM,SIG,RS,YO,BS - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/INPUT/ R,B - COMMON/PARAMD/ P - COMMON/CNST2/ NPL,NOS,NDRUG,NADD - COMMON/STATE/ X - COMMON STDEV - COMMON/ERROR/ERRFIL - PARAMETER(MAXNUMEQ=7) - -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. - - DIMENSION X(20),P(32),TIM(594),SIG(5000),SIGO(5000),R(37), - 1 RS(5000,34),RSO(5000,34),YT(MAXNUMEQ),YO(594,MAXNUMEQ),F(3564), - 2 BS(5000,7),Y(594,MAXNUMEQ),B(20),NBCOMP(7),STDEV(594,MAXNUMEQ), - 3 FA(7),TLAG(7),XSTORE(100,20),XPRED(20) - - CHARACTER ERRFIL*20 - -C NOTE THAT AS OF idm1x15.f, THE DIMENSIONS OF 6 IN XSTORE AND XPRED -C HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN ALL -C ALONG (I.E., THE SAME AS FOR X). - -C NOTE THAT THE 2ND DIMENSION OF STDEV AND YO IS MAXNUMEQ, WHICH -C IS SET IN THE NEW PARAMETER STATEMENT ABOVE. -C NOTE THAT THE DIMENSIONS RELATED TO THE NO. OF OUTPUT EQS. IN -C YO, YT, STDEV, AND Y ARE CHANGED TO MAXNUMEQ (FROM 6). NUMEQT COULD -C NOT BE USED BECAUSE THESE ARRAYS WERE NOT PASSED TO THIS ROUTINE AS -C DUMMY ARGUMENTS. - - -C NOTE THAT "7" IN THE ABOVE ARRAYS INDICATE THE NO. OF DRUGS ALLOWED. - -C NOTE THAT F HAS DIMENSION 3564 = 594*6 SINCE IT HAS NOS*M ENTRIES, -C THE MAX VALUE OF NOS = 6, AND THE MAX VALUE FOR M = 99*6 = 594. - -C R(7) CHANGED TO R(20) <-- No. of 'rate inputs' -C B(3) CHANGED TO B(20) <-- No. of different bolus inputs -C CHANGED X(3) TO X(20) <-- No. of compartments -C IC(10) CHANGED TO IC(20) <-- Initial conditions in compartments; -C should have been changed to 20 previously (like X,B). -C NBCOMP(10) CHANGED TO NBCOMP(20) <-- Same remarks as for IC. -C P(10) CHANGED TO P(32) <-- No. of parameters - -C*****ODE CONSTANTS AND INITIALIZATION***** - - KNS=1 - KNT=1 - -C NOTE THAT KNT IS THE RUNNING INDEX OF THE NEXT OBSERVATION TIME, -C AND KNS IS THE RUNNING INDEX OF THE NEXT DOSAGE TIME. - - T=0.0D0 - -C INITIALIZE ISKIPBOL = 0. SEE CODE BELOW. IT IS ONLY NEEDED FOR A -C STEADY STATE DOSE SET WHICH HAS BOLUS DOSES. - - ISKIPBOL = 0 - - - DO I = 1,NDRUG - R(2*I-1) = 0.D0 - END DO - -c AS OF idm1x7.f, instead of R(1) = 0, the code has been changed to -c set R(2*I-1) = 0, for I = 1,NDRUG. I.E., All IV rates for all NDRUG -c drugs are initialized to be 0 ... in case the 1st obs. time is 0, -c which means that OUTPUT is called before the R(I) are set below. - - -C CALL SUBROUTINE GETFA IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETFA IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF FA FOR EACH -C OF THE NDRUG DRUGS. - -C AS OF idm1x13.f, BEFORE CALLING GETFA, MUST SET -C THE R(.) IN CASE ANY OF THE FA(.) ARE FUNCTIONS OF THE -C COVARIATES WHICH ARE ESTABLISHED FROM THE R(.) VALUES IN -C GETFA. - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - CALL GETFA(FA) - - -C NOTE THAT NBCOMP(I),I=1,NDRUG WAS SET IN SUBROUTINE SYMBOL AND -C PASSED TO THIS ROUTINE VIA COMMON/BOLUSCOMP. - - -C As of idm1x12.f, the code to save ND0, SIGO, RSO, is moved to before -c the IF(N .EQ. 0) GO TO 75 statement. The reason is that before this -c routine returns, ND, SIG, and RS are reset back to these values, -c even if N = 0, and so they must be established at this time. - -C AS OF idm1x9.f, SAVE ND, SIG, AND RS WHETHER OR NOT NTL = 1, SINCE -C IF THERE ARE STEADY STATE DOSE SETS, THE FIRST SIG(.) VALUE IN EACH -C SET WILL BE CHANGED TO BE 0 BELOW. - - NDO = ND - DO I=1,ND - SIGO(I) = SIG(I) - DO J=1,NI - RSO(I,J) = RS(I,J) - END DO - END DO - - - -C IF N = 0, THE OUTPUT EQUATION(S) FOR Y ARE CODED EXPLICITLY INTO -C SUBROUTINE OUTPUT, AND NO D.E. SOLUTIONS (VIA USERANAL/DIFFEQ) ARE -C TO BE USED. IN THIS CASE, SKIP THE CODE REGARDING INITIAL CONDITIONS -C OF THE COMPARTMENTS, SINCE THEY ARE IRRELEVANT (I.E., THE COMPARTMENT -C AMOUNTS DON'T NEED TO BE INITIALIZED SINCE THEY WON'T BE UPDATED BY -C INTEGRATING D.E.'S). IN FACT, COULD PROBABLY SKIP TIMELAGS TOO, -C SINCE THEY CHANGE THE TIME THAT BOLUS DOSES ARE GIVEN, AND THIS -C THEORETICALLY ONLY AFFECTS COMPARTMENT AMOUNTS (WHICH ARE NOT USED -C IF N = 0), BUT JUST SKIP INITIAL CONDITIONS FOR NOW. - - IF(N .EQ. 0) GO TO 75 - - -C CALL SUBROUTINE GETIX IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETIX IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF X (THE INITIAL -C COMPARTMENT AMOUNT) FOR EACH OF THE N COMPARTMENTS. - - CALL GETIX(N,X) - - - -C CALL SUBROUTINE GETTLAG IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETTLAG IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF THE TIMELAG -C FOR EACH OF THE NDRUG DRUGS. - - - 75 CALL GETTLAG(TLAG) - -C IF ANY TLAG(.) VALUES RETURN AS .NE. 0, THEN, CALL SUBROUTINE SHIFT -C TO ADJUST THE DOSAGE REGIMEN APPROPRIATELY. - - NTL = 0 - DO ID = 1,NDRUG - IF(TLAG(ID) .NE. 0) NTL = 1 - END DO - - IF(NTL .EQ. 1) THEN - -C STORE INCOMING VALUES IN ND, SIG, AND RS (WHICH CONTAINS BS VALUES) -C SINCE THEY WILL BE CHANGED IN THE CALL TO SUBROUTINE SHIFT, WHICH -C "SHIFTS" THE DOSAGE REGIMEN MATRIX TO ACCOUNT FOR THE TIMELAG -C PARAMETER(S), TLAG(I). AT THE END OF THIS ROUTINE, THE VALUES IN ND, -C SIG, AND RS WILL BE RESET TO THEIR INCOMING VALUES - TO BE READY FOR -C THE NEXT CALL TO THIS ROUTINE WITH POSSIBLY DIFFERENT VALUES FOR -C TLAG(I). - - - CALL SHIFT(TLAG,ND,SIG,NDRUG,NADD,RS) - - -C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NTL .EQ. 1) CONDITION. - - IF(TIM(KNT).GE.SIG(KNS)) GO TO 12 - IF(TIM(KNT).NE.0.0D0) GO TO 45 - -C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) -C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. - - CALL OUTPUT(0.D0,YT) - DO 2000 I=1,NOS -2000 Y(KNT,I)=YT(I) - KNT=KNT+1 - GO TO 45 - -12 IF(TIM(KNT).GT.SIG(KNS)) GO TO 13 - IF(TIM(KNT).NE.0.0D0) GO TO 45 - -C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TIM(KNT) -C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. - - CALL OUTPUT(0.D0,YT) - DO 2005 I=1,NOS -2005 Y(KNT,I)=YT(I) - KNT=KNT+1 - -13 IF(SIG(KNS) .GT. 0.0D0) GO TO 45 - -C CHECK TO SEE IF SIG(KNS) < 0. IF SO, IT MEANS THAT 100 STEADY STATE -C DOSES SHOULD NOW BE APPLIED WITH AN INTERDOSE INTERVAL EQUAL TO -C -SIG(KNS). - - ISTEADY = 0 - - IF(SIG(KNS) .LT. 0.D0) THEN - - - - - ISTEADY = 1 - NSET = 1 - -C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE -C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 -C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... -C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. -C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE -C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE -C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE -C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC -C OF PREDLAST3 REQUIRES). - - -C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT -C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS -C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF -C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE -C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. - -C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF -C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL -C INTEGRATED THROUGH, WHICHEVER COMES FIRST. - - DOSEINT = -SIG(KNS) - -C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START -C OF 100 DOSE SETS THAT BEGIN AT TIME 0. - - - SIG(KNS) = 0 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. - - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - IF(NDRUG .EQ. 0) GO TO 81 - -C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT -C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED -C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. - - CALL GETFA(FA) - - - IF(N .EQ. 0) GO TO 120 - - DO I=1,NDRUG - X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS,I)*FA(I) - END DO - -C NOTE THAT FA(I) IS THE FRACTION OF DRUG AVAILABLE FROM A BOLUS INPUT -C FOR DRUG I INTO ITS ABSORPTIVE COMPARTMENT. - - GO TO 81 - -120 DO I=1,NDRUG - B(I)=BS(KNS,I)*FA(I) - END DO - -81 KNS = KNS+1 - - -C*****INTEGRATION OF EQUATIONS***** - - -C DETERMINE IF, OBSER(ID=0), OR DOSE(ID=1), OR BOTH(ID=2). - -45 IF(KNS .GT. ND) GO TO 15 - - -C CODE CHANGE BELOW FOR idm1x8.f. - - IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) THEN - -C AS OF idm1x7.f, A TIME RESET NO LONGER REQUIRES ALL INITIAL -C COMPARTMENT AMOUNTS TO BE RESET TO 0. THIS IS BECAUSE A TIME RESET -C NO LONGER HAS TO MEAN THAT AN "INFINITE" AMOUNT OF TIME HAS OCCURRED -C WITH NO DOSING; IT CAN ALSO NOW MEAN THAT AN "INFINITE" AMOUNT OF -C TIME HAS OCCURRED WITH UNKNOWN DOSING (IN THIS CASE, SUBROUTINE -C GETIX WILL BE CALLED BELOW TO ESTABLISH INITIAL CONDITIONS FOR THIS -C TIME PERIOD). - -C ADVANCE KNS TO THE NEXT VALUE THAT HAS SIG(KNS) .LE. 0. I.E., ONCE -C TIMN(KNT) = 0, IT MEANS THAT WE ARE DONE WITH THE OUTPUT OBS. -C TIMES IN THE PREVIOUS SECTION --> THERE IS NO POINT IN CONTINUING -C TO INTEGRATE TILL THE END OF THE DOSES IN THE PREVIOUS SECTION -C (IF THERE ARE ANY). - - DO IKNS = KNS,ND - IF(SIG(IKNS) .LE. 0.D0) GO TO 110 - END DO - -C TO GET HERE MEANS THAT NO VALUE IN SIG(.) FROM KNS TO ND HAS A -C VALUE .LE. 0, AND THIS IS AN ERROR. IT MEANS THAT THE PATIENT DATA -C FILE HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING -C DOSE RESET ROW. TELL THE USER AND STOP. - - WRITE(*,111) ND,KNS,SIG(KNS) -111 FORMAT(//' IN SUBROUTINE FUNC, THE CURRENT SUBJECT HAS AN'/ - 1' OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE'/ - 2' RESET ROW. THE PROGRAM NOW STOPS. '// - 3' REVIEW YOUR PATIENT FILES AND CORRECT THE ERROR.'// - 4' NOTE THAT THE ',I4,' DOSE TIMES (POSSIBLY ALTERED BY TIMELAGS'/ - 5' ARE THE FOLLOWING (AND THERE IS NO TIME .LE. 0 AFTER TIME'/ - 6' NO. ',I4,' WHICH HAS CORRESPONDING TIME ',F15.4,'):') - - - DO I = 1,ND - WRITE(*,*) SIG(I) - END DO - - OPEN(47,FILE=ERRFIL) - WRITE(47,111) ND,KNS,SIG(KNS) - DO I = 1,ND - WRITE(47,*) SIG(I) - END DO - CLOSE(47) - - CALL PAUSE - STOP - - - 110 KNS = IKNS - - -C THERE ARE TWO POSSIBILITES AT THIS POINT, EITHER SIG(KNS) = 0 -C OR SIG(KNS) < 0. - -C IF SIG(KNS) = 0, THIS REPRESENTS A TIME RESET (T WILL BE SET = 0 -C BELOW) WITH A SINGLE DOSE LINE TO START. IN THIS CASE, CALL GETIX -C AGAIN (JUST AS WAS DONE NEAR THE TOP OF THIS ROUTINE) TO OBTAIN -C INITIAL COMPARTMENT AMOUNTS. NOTE THAT BY DEFAULT, IN GETIX, ALL -C COMPARTMENT AMOUNTS ARE SET = 0 (WHICH WOULD BE THE CASE IF IN THE -C LONG TIME PERIOD BETWEEN THE LAST SET OF DOSES AND THIS NEW -C BEGINNING, NO DOSES HAVE BEEN GIVEN). BUT THE USER MAY ALSO HAVE -C CODED INTO GETIX EQUATIONS THAT SET ONE OR MORE OF THE X(I) TO -C FUNCTIONS OF COVARIATE AND PARAMETER VALUES (WHICH WOULD BE THE -C SITUATION IF AN UNKNOWN DOSING REGIMEN HAS TAKEN PLACE BUT IT -C DOESN'T MATTER WHAT IT WAS BECAUSE THE PATIENT COMES TO A LAB AND -C SIMPLY HAS HIS COMPARTMENT VALUES ESTABLISHED BEFORE CONTINUING -C WITH THE OTHER VALUES IN HIS PATIENT FILE). - -C IF SIG(KNS) < 0, THIS REPRESENTS A TIME RESET WITH A STEADY STATE -C SET OF 100 DOSES ABOUT TO BEGIN. IN THIS CASE, WE ASSUME THAT THE -C PATIENT IS ABOUT TO GET 100 SETS OF DOSES SO THAT HIS COMPARTMENT -C AMOUNTS WILL ACHIEVE STEADY STATE VALUES. THESE STEADY STATE VALUES -C WILL BE ESTIMATED IN THE BLOCK OF CODE BELOW THAT STARTS WITH -C IF(ISTEADY .EQ. 1). IN THIS CASE, WE WILL STILL CALL GETIX TO -C MAKE SURE THAT ANY RESIDUAL COMPARTMENT AMOUNTS FROM A PREVIOUS -C SET OF DOSES IS ZEROED OUT (OR SET = VALUES AS DETERMINED BY -C SUBROUTINE GETIX). - -C AS OF idm1x14.f, BEFORE CALLING GETIX, MUST SET -C THE R(.) IN CASE ANY OF THE INITIAL CONDITIONS FOR THE X(.) -C ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM THE -C R(.) VALUES IN GETFA. - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - - - CALL GETIX(N,X) - -C MUST ALSO RESET T = 0 SINCE THE INTEGRATION WILL AGAIN START FROM -C TIME 0. - - T = 0.D0 - -C IF SIG(KNS) .LT. 0, THIS IS NOT ONLY A TIME RESET, IT IS THE -C BEGINNING OF A STEADY STATE DOSE SET. IN THIS CASE, APPLY 100 -C STEADY STATE DOSES WITH AN INTERDOSE INTERVAL EQUAL TO -SIG(KNS). - - ISTEADY = 0 - - IF(SIG(KNS) .LT. 0.D0) THEN - - ISTEADY = 1 - NSET = 1 - -C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE -C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 -C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... -C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. -C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE -C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE - -C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE -C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC -C OF PREDLAST3 REQUIRES). - - -C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT -C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS -C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF -C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE -C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. - -C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF -C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL -C INTEGRATED THROUGH, WHICHEVER COMES FIRST. - - DOSEINT = -SIG(KNS) - -C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START -C OF 100 DOSE SETS THAT BEGIN AT TIME 0. - - SIG(KNS) = 0 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(TIM(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) CONDITION. - - - - IF(TIM(KNT) .NE. SIG(KNS)) GO TO 20 - ID=2 - TOUT=TIM(KNT) - KNT=KNT+1 - KNS=KNS+1 - - IF(N .EQ. 0) GO TO 31 - GO TO 30 - -20 IF(TIM(KNT) .GT. SIG(KNS) .AND. SIG(KNS) .GT. 0) GO TO 25 - - -15 ID=0 - TOUT=TIM(KNT) - KNT=KNT+1 - IF(N .EQ. 0) GO TO 31 - GO TO 30 - -25 ID=1 - TOUT=SIG(KNS) - KNS=KNS+1 - IF(N .EQ. 0) GO TO 31 - -30 CONTINUE -32 IF(N .NE. -1) CALL USERANAL(X,T,TOUT) - IF(N .EQ. -1) CALL ANAL3(X,T,TOUT) - - -C IF ISTEADY = 1, THIS IS INSIDE A STEADY STATE DOSE SET. CHECK TO SEE -C IF TOUT IS A MULTIPLE OF DOSEINT. IF SO, RECORD THE COMPARTMENT -C AMOUNTS. THEN, AFTER COMPARTMENT AMOUNTS HAVE BEEN STORED FOR AT -C LEAST THE 1ST 5 MULTIPLES OF DOSEINT, STOP AND CALL SUBROUTINE -C PREDLAST3 WHICH PREDICTS THE FINAL (STEADY STATE) COMPARTMENT AMOUNTS -C AFTER THE LAST (100TH) DOSE SET. - -C IF PREDLAST3 HAS PREDICTED VALUES WHICH "CONVERGE", ASSIGN THE -C PREDICTED VALUES TO X, INCREASE KNS TO BE THE INDEX OF THE FIRST DOSE -C EVENT WHICH OCCURS AFTER THE STEADY STATE DOSE SET ENDS AND CONTINUE. - -C IF PREDLAST3 VALUES DON'T CONVERGE, CONTINUE THE PROCESS WITH -C COMPARTMENT AMOUNTS FOR MULTIPLES 2 - 6 OF DOSEINT, TEST FOR -C "CONVERGENCE", ETC. THIS PROCESS CONTINUES UNTIL "CONVERGENCE" IS -C ACHIEVED FOR A SET OF 5 COMPARTMENT AMOUNTS (OR SETS OF AMOUNTS IF -C NDRUG IS > 1), OR UNTIL ALL 100 DOSE SETS IN THE STEADY STATE REGIMEN -C HAVE FINISHED. - - IF(ISTEADY .EQ. 1) THEN - - -C THE NEXT DOSE SET END TIME IS DOSEINT*NSET. IF TOUT = DOSEINT*NSET, -C STORE THE COMPARTMENT AMOUNTS. IF NSET .GE. 5, CALL PREDLAST3 AND -C PROCEED AS INDICATED ABOVE. - - CALL THESAME(TOUT,DOSEINT*NSET,ISAME) - - IF(ISAME .EQ. 1) THEN - - NN = N - IF(N .EQ. -1) NN = 3 - - DO J = 1,NN - XSTORE(NSET,J) = X(J) - END DO - - - IF(NSET .GE. 5) THEN - - CALL PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) - - - IF(ICONV .EQ. 1) THEN - -C SINCE THE PREDICTED VALUES ARE CONSIDERED ACCURATE (I.E., -C "CONVERGENCE WAS ACHIEVED IN PREDLAST), RESET ISTEADY TO 0, -C WHICH MEANS THAT THE STEADY STATE DOSES ARE FINISHED; ASSIGN THE -C COMPARTMENT AMOUNTS TO BE THE PREDICTED VALUES; AND SET KNS TO THE -C FIRST DOSE EVENT AFTER THE END OF THE STEADY STATE DOSE SET. ALSO, -C SET T = THE ENDING TIME OF THE STEADY STATE DOSE SET = 100*DOSEINT, -C SINCE THAT IS WHAT IT WOULD HAVE BEEN HAD ALL 100 DOSE SETS BEEN -C RUN. - - ISTEADY = 0 - - DO J = 1,NN - X(J) = XPRED(J) - END DO - - T = 100.D0*DOSEINT - - -C ADVANCE KNS TO BE THE FIRST DOSE PAST THE 100 DOSE SETS IN THIS -C STEADY STATE SET. NOTE THAT THIS SET ENDS BEFORE 100*DOSEINT, SO -C FIND THE FIRST SIG(.) THAT IS .GE. 100*DOSEINT, OR THAT IS = 0 -C (WHICH SIGNIFIES A TIME RESET) OR THAT IS < 0 (WHICH SIGNIFIES -C ANOTHER STEADY STATE SET). - - DO I = KNS,ND - IF(SIG(I) .GE. 100.D0*DOSEINT .OR. SIG(I) .LE. 0.D0) THEN - KNSNEW = I - GO TO 100 - ENDIF - END DO - -C TO GET HERE MEANS THAT THERE ARE NO DOSE TIMES PAST THE END OF THIS -C STEADY STATE DOSE SET. IN THIS CASE, SET KNS TO ND+1. - - KNS = ND+1 - GO TO 200 - - 100 KNS = KNSNEW - 200 CONTINUE - - -C SET ISKIPBOL = 1 WHENEVER CONVERGENCE OCCURS IN -C THE STEADY STATE DOSES SINCE IN THIS CASE, WE DON'T WANT TO -C REAPPLY THE LAST BOLUS FROM THE STEADY STATE SET BELOW LABEL 83. - - ISKIPBOL = 1 - - ENDIF - - -C THE ABOVE ENDIF IS FOR THE IF(ICONV .EQ. 1) CONDITION. - -C IF ICONV = 0, ISTEADY IS STILL = 1, -C WHICH MEANS THAT THE ATTEMPT TO PREDICT THE FINAL (STEADY STATE) -C COMPARTMENT AMOUNTS CONTINUES. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NSET .GE. 5) CONDITION. - -C SINCE ISAME = 1, THE END OF THE SET NO. NSET HAS OCCURRED --> -C INCREASE NSET BY 1. - - - NSET = NSET + 1 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISTEADY .EQ. 1) CONDITION. - - - -31 CONTINUE - -C RECORD OBSERVATION AND SUPPLY NEW DOSE - - IF(ID .EQ. 1) GO TO 35 - KNTM1=KNT-1 - -C NOTE THAT THE TIME AT WHICH THE OUTPUT IS DESIRED IS TIM(KNTM1); THIS -C IS CLEAR SINCE THE RETURNING VALUE(S) IN YT ARE PUT INTO ROW NO. -C KNTM1 OF Y. - - CALL OUTPUT(TIM(KNTM1),YT) - - DO 2010 I=1,NOS -2010 Y(KNTM1,I)=YT(I) - -55 IF(ID.EQ.0) GO TO 40 - - 35 CONTINUE - - IF(NI .EQ. 0) GO TO 83 - - DO I=1,NI - R(I)=RS(KNS-1,I) - END DO - -C AS OF idm1x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT -C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED -C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. - - CALL GETFA(FA) - - -83 IF(NDRUG .EQ. 0 .OR. N .EQ. 0) GO TO 82 - -C ADDING N .EQ. 0 TO ABOVE IF STATEMENT SHOWS CLEARLY THAT IF -C N = 0 (IN WHICH CASE ANALYTIC SOLUTIONS ARE CODED DIRECTLY INTO -C SUBROUTINE OUTPUT, WHICH MAKES THE COMPARTMENT AMOUNTS IRRELEVANT) -C SETTING VALUES FOR THE COMPARTMENTS, X, IS UNNECESSARY. - - -C IF ISKIPBOL = 1, DO NOT APPLY BOLUSES FROM DOSE KNS-1, SINCE THESE -C BOLUSES WERE PART OF THE STEADY STATE DOSE SET WHICH ALREADY HAD -C BOLUSES (EFFECTIVELY) APPLIED ABOVE WHERE "CONVERGENCE" OF THE -C STEADY STATE DOSE SET WAS OBTAINED. - - IF(ISKIPBOL .EQ. 0) THEN - DO I=1,NDRUG - X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS-1,I)*FA(I) - END DO - ENDIF - -C RESET ISKIPBOL = 0 HERE. IF IT IS NOW = 1, IT MEANS THAT -C THE ABOVE APPLICATION OF BOLUSES WAS SKIPPED SINCE THERE HAS JUST -C BEEN A STEADY STATE SET OF DOSES WHICH CONVERGED (AND WE DON'T -C WANT THE LAST BOLUS DOSE REAPPLIED). BUT, GOING FORWARD, ISKIPBOL -C SHOULD BE SET AGAIN TO 0 SO THE ABOVE APPLICATION OF BOLUSES WILL -C OCCUR WHENEVER THERE IS A NEW BOLUS TO BE APPLIED. - - ISKIPBOL = 0 - - -82 CONTINUE - -C CHECK STOPPING TIME. - - -40 IF(KNT .LE. M) GO TO 45 - -C*****DETERMINE F(I)***** - -C NOTE THAT IF YO(I,J) = -99 --> THIS OBSERVED LEVEL IS MISSING. -C IN THIS CASE, SET THE CORRESPONDING VALUE OF F = 0. - - DO J=1,NOS - DO I=1,M - IF(YO(I,J) .EQ. -99) F((J-1)*M+I) = 0.D0 - IF(YO(I,J) .NE. -99) F((J-1)*M+I) =(Y(I,J)-YO(I,J))/STDEV(I,J) - END DO - END DO - - -C AS OF idm1x9.f, RESTORE THE VALUES FOR ND, SIG, AND RS, IN CASE -C THIS MODEL HAS TIME LAGS OR STEADY STATE DOSES - TO BE READY FOR THE -C NEXT CALL TO THIS ROUTINE. - - ND = NDO - DO I=1,ND - SIG(I) = SIGO(I) - DO J=1,NI - RS(I,J) = RSO(I,J) - END DO - END DO - -C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE SUMSQ(SSQ) - -C SUBROUTINE TO EVALUATE THE SUM OF SQUARES OF THE RESIDUAL VECTOR. - - IMPLICIT REAL*8(A-H,O-Z) - COMMON/SUM2/ M,NPNL - COMMON/CNST2/ NPL,NOS,NDRUG,NADD - DIMENSION F(3564) - -C NOTE THAT F HAS DIMENSION 3564 = 594*6 SINCE IT HAS NOS*M ENTRIES, -C THE MAX VALUE OF NOS = 6, AND THE MAX VALUE FOR M = 99*6 = 594. - - - CALL FUNC(M,F) - SSQ=0.0D0 - NUMRES=M*NOS - DO 10 I=1,NUMRES -10 SSQ=SSQ+F(I)*F(I) - RETURN - - END -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE USERANAL(X,TIN,TOUT) - -C PURPOSE: -C GIVEN X(TIN) THE PROGRAM CALCULATES X(TOUT), WHERE X IS THE -C STATE VECTOR FOR THE MODEL UNDER CONSIDERATION (AS DEFINED -C BY THE D.E'S IN SUBROUTINE DIFFEQ). THESE D.E'S ARE SOLVED -C USING THE LINPACK ROUTINE, VODE.FOR (AND ASSOCIATED ROUTINES). - -C THIS ROUTINE CALLS SUBROUTINE DVODE (VODE.FOR) ONCE FOR EACH -C POINT AT WHICH ANSWERS ARE DESIRED. NOTE THAT DVODE WILL CALL -C SUBROUTINE DIFFEQ (SUPPLIED BY THE USER -- IT GIVES THE -C DIFF. EQS. OF THE MODEL, XP(I)) AND, IF THE USER DESIRES, -C SUBROUTINE JACOB (SUPPLIED BY THE USER -- IT GIVES THE -C JACOBIAN OF PARTIAL DERIVATIVES, dXP(I)/dX(J)). SUBROUTINES -C DIFFEQ AND JACOB ARE IN THIS MODULE. - -C ARGUMENTS ON INPUT: -C X - AN ARRAY OF DIMENSION 20. IN THE STANDARD 3-COMPARTMENT -C MODEL, X(1), X(2), X(3) SHOULD -C BE SET TO THE AMOUNT OF DRUG IN THE ABSORBTION, -C CENTRAL, AND PERIPHERAL COMPARTMENTS, RESPECTIVELY, -C AT TIME T=TIN. -C TIN - CURRENT VALUE OF TIME. -C TOUT - TIME AT WHICH SOLUTION IS DESIRED. - -C VALUES FROM COMMON/TOUSER (FROM MXEM2__/MAIN) WHICH WERE INPUT -C REAL-TIME BY THE USER (SEE DETAILS BELOW). -C NDIM = NO. OF STATES IN MODEL (.LE. 3 FOR NOW). -C MF = METHOD FLAG. -C RTOL = SCALAR RELATIVE TOLERANCE PARAMETER. -C ATOL(I), I=1,NDIM = ABSOLUTE TOLERANCE PARAMETERS. - -C ARGUMENTS ON OUTPUT: -C X - THE COMPARTMENT AMOUNTS AT T=TOUT. -C TIN - SET AT TOUT - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION X(20),ATOL(20),RWORK(300),IWORK(40) - - EXTERNAL DIFFEQ,JACOB - COMMON/TOUSER/NDIM,MF,RTOL,ATOL - -C THE LOGIC OF THIS CODE IS TAKEN FROM PROGRAM DESOLV3.FOR (4/28/96). - -C FOLLOWING VALUES ARE SUPPLIED TO SUBROUTINE DVODE: - -C DIFFEQ = NAME OF SUBROUTINE COMPLETED BY USER WHICH GIVES THE D.E.'S -C OF THE MODEL. IT MUST BE DECLARED EXTERNAL. -C TIN = The initial value of the independent variable. - -C TOUT = First point where output is desired (.ne. TIN). -C ITOL = 2 SINCE ATOL IS AN ARRAY. -C RTOL = Relative tolerance parameter (scalar). -C ATOL = Absolute tolerance parameter. -C The estimated local error in X(i) will be controlled so as -C to be roughly less (in magnitude) than -C EWT(i) = RTOL*abs(X(i)) + ATOL(i) SINCE ITOL = 2. -C Thus the local error test passes if, in each component, -C either the absolute error is less than ATOL (or ATOL(i)), -C or the relative error is less than RTOL. -C Use RTOL = 0.0 for pure absolute error control, and -C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error -C control. Caution.. Actual (global) errors may exceed these -C local tolerances, so choose them conservatively. -C ITASK = 1 for normal computation of output values of X at t = TOUT. -C ISTATE = Integer flag (input and output). Set ISTATE = 1. -C IOPT = 0 to indicate no optional input used. -C RWORK = Real work array of length at least.. -C 20 + 16*NDIM for MF = 10, -C 22 + 9*NDIM + 2*NDIM**2 for MF = 21 or 22, -C 22 + 11*NDIM + (3*ML + 2*MU)*NDIM for MF = 24 or 25. -C ... I'LL USE AN ARRAY OF 300 (PLENTY FOR NDIM .LE. 8). -C LRW = Declared length of RWORK (in user's DIMENSION statement). -C IWORK = Integer work array of length at least.. -C 30 for MF = 10, -C 30 + NDIM for MF = 21, 22, 24, or 25. -C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower -C and upper half-bandwidths ML,MU. -C ... I'LL USE AN ARRAY OF 40 (PLENTY FOR NDIM .LE. 8). -C LIW = Declared length of IWORK (in user's DIMENSION). -C JACOB = Name of subroutine COMPLETED BY USER for Jacobian matrix -C (MF = 21 or 24). If used, this name must be declared -C external. If not used, pass a dummy name. -C MF = Method flag. Standard values are.. -C 10 for nonstiff (Adams) method, no Jacobian used. -C 21 for stiff (BDF) method, user-supplied full Jacobian. -C 22 for stiff method, internally generated full Jacobian. - -C 24 for stiff method, user-supplied banded Jacobian. -C 25 for stiff method, internally generated banded Jacobian. -C RPAR,IPAR = user-defined real and integer SCALARS OR arrays passed to -C DIFFEQ AND JACOB. - -C Note that the main program must declare arrays X, RWORK, IWORK, -C and possibly ATOL, RPAR, and IPAR. - - -C THE FOLLOWING VALUES RETURN FROM CALLS TO SUBROUTINE DVODE. - -C X = Array of computed values of X vector (AT TIME TOUT). -C T = Corresponding value of independent variable (normally TOUT). -C ISTATE = 2 if DVODE was successful, negative otherwise. -C -1 means excess work done on this call. (Perhaps wrong MF.) -C -2 means excess accuracy requested. (Tolerances too small.) -C -3 means illegal input detected. (See printed message.) -C -4 means repeated error test failures. (Check all input.) -C -5 means repeated convergence failures. (Perhaps bad -C Jacobian supplied or wrong choice of MF or tolerances.) -C -6 means error weight became zero during problem. (Solution -C component i vanished, and ATOL or ATOL(i) = 0.) - - ITOL=2 - ITASK=1 - ISTATE=1 - IOPT=0 - LRW=300 - LIW=40 - - CALL DVODE(DIFFEQ,NDIM,X,TIN,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, - 1 IOPT,RWORK,LRW,IWORK,LIW,JACOB,MF,RPAR,IPAR) - -c IF (ISTATE .LT. 0) THEN -c WRITE(*,16) ISTATE -c 16 FORMAT(///' On return from DVODE, ISTATE =',I3) -c ENDIF - - - TIN=TOUT - - - - RETURN - END -C - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE JACOB(NDIM, T, X, ML, MU, PD, NRPD, RPAR, IPAR) - - IMPLICIT REAL*8(A-H,O-Z) - COMMON/PARAMD/ P - COMMON/INPUT/ R,B - DIMENSION X(NDIM), PD(NRPD,NDIM), P(32),R(37),B(20) - -C THIS ROUTINE IS CALLED BY LINPACK ROUTINE DVODE (WHICH IS CALLED -C BY ROUTINE USERANAL). THE USER CODES THE JACOBIAN MATRIX CALCULATIONS -C OF THE MODEL (I.E., THE PARTIAL DERIVATIVES OF XP(I) W.R.T. X(I), -C WHERE XP(I) WERE CODED INTO ROUTINE DIFFEQ). - - -C SINCE THIS ROUTINE CAN'T BE MADE BY THE 'BOXES' PROGRAM AT THIS TIME, -C IT WILL NOT BE USED. IT IS JUST A DUMMY ROUTINE, NEEDED BECAUSE -C DVODE EXPECTS TO 'SEE' IT. - -C INPUT ARE: - -C NDIM = NO. OF STATES (DIMENSION OF PROBLEM). - -C T = CURRENT TIME. -C X(I) = VALUE OF STATE I AT T, I=1,NDIM. -C [ML,MU] = HALF BANDWIDTH PARAMETERS ... UNNEEDED IF MF = 21 OR 22 -C --> FULL JACOBIAN IS PROVIDED BY USER BELOW (SEE -C DESOLV3.FOR CODE FOR DETAILS). -C NOTE THAT SINCE MF = 21 OR 22 IN THIS CASE, NRPD = NDIM. -C R AND B VIA COMMON/INPUT. - - -C OUTPUT ARE: - - -C PD(I,J) = PARTIAL DERIVATIVE OF XP(I) W.R.T. X(J), WHERE XP(I) -C ARE CALCULATED IN ROUTINE DIFFEQ ABOVE. - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION XSTORE(100,20),XPRED(20),COMP(5,20) - -C NOTE THAT AS OF idm1x15.f, THE DIMENSIONS OF 6 IN XSTORE, XPRED, -C AND COMP HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN -C ALL ALONG (SEE SUBROUTINE FUNC). - - -C THIS SUBROUTINE IS CALLED BY SUBROUTINE FUNC WITH NSET SETS OF NN -C COMPARTMENT VALUES IN XSTORE. USE THE LAST 5 SETS OF VALUES TO -C PREDICT THE FINAL (STEADY STATE) COMPARTMENT AMOUNTS AFTER THE LAST -C (100TH) DOSE SET. - -C IF THESE VALUES "CONVERGE", SET ICONV = 1, AND WRITE THE PREDICTED -C VALUES INTO XPRED. IF THEY DON'T CONVERGE, SET ICONV = 0. - -C TOL1 AND TOL2 ARE, FOR NOW, HARDCODED TO BE .0005. - - TOL1 = .0005D0 - TOL2 = .0005D0 - - -C THE LAST 5 SETS OF VALUES ARE IN XSTORE(NSET-4:NSET,.). PUT THESE -C VALUES INTO COMP(.,.). - - II = 0 - - DO I = NSET-4,NSET - II = II+1 - DO J = 1,NN - COMP(II,J) = XSTORE(I,J) - END DO - END DO - - -C FOR EACH COMPARTMENT AMOUNT, SEE IF THE FINAL STEADY STATE COMP. -C AMOUNT CAN BE PREDICTED ACCURATELY. - - DO IN = 1,NN - - A1 = COMP(1,IN) - A2 = COMP(2,IN) - A3 = COMP(3,IN) - DEL1 = A2 - A1 - DEL2 = A3 - A2 - -C TEST FOR DEL1 = 0. IF SO, SEE ISAMETOT BELOW. - - CALL THESAME(DEL1,0.D0,ISAME1) - - IF(ISAME1 .EQ. 0) THEN - - F = DEL2/DEL1 - -C THE UNDERLYING ASSUMPTION IS THAT THE RATIO F = DEL2/DEL1 -C IS CONTANT BETWEEN CONSECUTIVE OUTPUT DIFFERENCES. IF SO, THEN -C THE STEADY STATE VALUE WILL BE A1 + DEL1/(1 - F) (SEE SS.EXP -C IN \ALAN3\STEADYSTATE). CALCULATE THIS VALUE AND CALL IT PRED1. - -C BUT, IF DEL2 = DEL1, THEN F = 1. IN THIS CASE, CAN'T DO THE FOLLOWING -C CALCULATION FOR PRED1, AND WE WOULDN'T WANT TO DO IT SINCE -C DEL2 = DEL1 --> A2 - A1 = A3 - A2 --> A1, A2, AND A3 ARE IN AN -C ARITHMETIC PROGRESSION --> THERE OBVIOUSLY CAN BE NO CONVERGENCE -C SINCE, AFTER 100 DOSES, THE VALUE WOULD JUST A1 + 99*DEL1 ... -C UNLESS DEL1 = 0, IN WHICH CASE THE VALUE WOULD CONVERGE TO A1. -C IN THIS CASE SET ISAMEF1 = 1, AND SKIP CALC. OF PRED1. AND THEN -C SEE THE LOGIC RELATED TO ISAMEF1 BELOW. - - - - CALL THESAME(F,1.0,ISAMEF1) - IF(ISAMEF1 .EQ. 0) PRED1 = A1 + DEL1/(1.D0 - F) - - ENDIF - - -C SIMILARLY, CALCULATE PRED2 (BASED ON (A2,A3,A4)) AND PRED3 (BASED -C ON (A3,A4,A5). - - A1 = COMP(2,IN) - - A2 = COMP(3,IN) - A3 = COMP(4,IN) - DEL1 = A2 - A1 - DEL2 = A3 - A2 - -C TEST FOR DEL1 = 0. IF SO, SEE ISAMETOT BELOW. - - CALL THESAME(DEL1,0.D0,ISAME2) - - IF(ISAME2 .EQ. 0) THEN - F = DEL2/DEL1 - - - CALL THESAME(F,1.0,ISAMEF2) - IF(ISAMEF2 .EQ. 0) PRED2 = A1 + DEL1/(1.D0 - F) - - ENDIF - - A1 = COMP(3,IN) - A2 = COMP(4,IN) - A3 = COMP(5,IN) - DEL1 = A2 - A1 - DEL2 = A3 - A2 - -C TEST FOR DEL1 = 0. IF SO, SEE ISAMETOT BELOW. - - CALL THESAME(DEL1,0.D0,ISAME3) - - IF(ISAME3 .EQ. 0) THEN - F = DEL2/DEL1 - - - CALL THESAME(F,1.0,ISAMEF3) - IF(ISAMEF3 .EQ. 0) PRED3 = A1 + DEL1/(1.D0 - F) - ENDIF - - -C ASSUMING A NEGATIVE EXPONENTIAL PATTERN FIT (SEE SS.EXP IN -C \ALAN3\STEADYSTATE OR HOME NOTES, PG.2 ON 9/11/11 FOR DETAILS) ON -C (PRED1,PRED2,PRED3), CALCULATE PREDNEG. - -C BUT ONLY DO THIS CALCULATION, AND THE SUBSEQUENT -C CONVERGENCE DETERMINATION IF ISAME1 = ISAME2 = ISAME3 = 0, AND -C ISAMEF1 = ISAMEF2 = ISAMEF3 = 0. OTHERWISE, AT LEAST ONE OF THE -C PREDICTED VALUES ABOVE WAS NOT CALCULATED. - - ISAMETOT = ISAME1 + ISAME2 + ISAME3 - ISAMEFTOT = ISAMEF1 + ISAMEF2 + ISAMEF3 - - - IF(ISAMETOT .EQ. 0 .AND. ISAMEFTOT .EQ. 0) THEN - -C EDITED CODE BELOW FOR idm1x11.f. - -C IF PRED1 + PRED3 - 2*PRED2 = 0, PREDNEG (SEE BELOW) CANNOT BE -C CALCULATED. IN THIS CASE, PRED2 - PRED1 = PRED3 - PRED2 --> -C THE SEQUENCE (PRED1, PRED2, PRED3) IS LINEAR, WHICH CANNOT BE -C MODELED WITH AN EXPONENTIAL FIT (SEE COMMENTS ABOVE). SO, IF THIS -C HAPPENS, CONVERGENCE WILL BE SATISFIED IF THESE 3 VALUES ARE -C VIRTUALLY THE SAME - I.E., ONLY THE REQUIREMENT INVOLVING TOL1 -C WILL BE NEEDED FOR CONVERGENCE (RECALL THE ONLY REASON FOR THE -C EXTRA NEGATIVE EXPONENTIAL FIT, AND THE CALCULATION OF PREDNEG IS FOR -C THOSE CASES WHERE PRED1, PRED2, AND PRED3 ARE NOT ALL VIRTUALLY THE -C SAME VALUE). - - DEN = PRED1+PRED3-2.D0*PRED2 - CALL THESAME(DEN,0.D0,ISAMEDEN) - - IF(ISAMEDEN .EQ. 0) PREDNEG = (PRED1*PRED3 - PRED2*PRED2)/DEN - -C NOW CHECK FOR CONVERGENCE, WHICH HAS BEEN OBTAINED IF -C |PRED3/PRED2 - 1| < TOL1 AND |PREDNEG/PRED3 - 1| < TOL2. - - ICONV = 1 - IF(DABS(PRED3/PRED2 - 1.D0) .GE. TOL1) ICONV = 0 - IF(ISAMEDEN .EQ. 0 .AND. DABS(PREDNEG/PRED3 - 1.D0) .GE. TOL2) - 1 ICONV = 0 - -C IF ICONV = 1 FOR THIS COMPARTMENT, IN, STORE THE PREDICTED AMOUNT, -C AND CONTINUE TO THE NEXT COMPARTMENT. NOTE BELOW THAT -C NON-CONVERGENCE IN ANY COMPARTMENT ENDS THE PROCESS SINCE TO -C CONVERGE, ALL COMPARTMENT PREDICTIONS MUST CONVERGE. - - IF(ICONV .EQ. 1 .AND. ISAMEDEN .EQ. 1) XPRED(IN) = PRED3 - IF(ICONV .EQ. 1 .AND. ISAMEDEN .EQ. 0) XPRED(IN) = PREDNEG - -C EDITED CODE ABOVE FOR idm1x11.f. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISAMETOT .EQ. 0 .AND. ISAMEFTOT .EQ.0) -C CONDITION. - - -C IF ISAMETOT .GT. 0, THERE ARE TWO POSSIBILITIES (AND NOTE THAT IT -C DOSEN'T MATTER WHAT ISAMEFTOT IS IN THIS CASE): - -C ISAMETOT = 3, IN WHICH CASE COMP(1:4,IN) ARE ALL THE SAME. -C ISAMETOT = 1 OR 2, IN WHICH CASE SOME OF THE COMP(1:4,IN) VALUES -C ARE THE SAME, AND SOME ARE NOT. - -C IN THE FORMER CASE, VERIFY THAT COMP(5,IN) IS THE SAME VALUE AS -C THE COMP(1:4,IN). IF SO, SET THE PREDICTED VALUE = THIS VALUE -C (I.E., THE PREDICTED VALUE FOR A CONSTANT FUNCTION IS THE -C CONSTANT VALUE), AND SET ICONV = 1. OTHERWISE, SET ICONV = 0 -C SINCE THERE IS NO WAY TO FIT 4 VALUES WHICH ARE THE SAME AND ONE -C WHICH IS NOT USING A NEGATIVE EXPONENTIAL FUNCTION. - -C IN THE LATTER CASE, SINCE SOME OF THE COMP(1:4,IN) VALUES ARE THE -C SAME, AND SOME ARE NOT, SET ICONV = 0 FOR THE SAME REASON AS -C STATED IN THE PREVIOUS PARAGRAPH. - - - IF(ISAMETOT .EQ. 3) THEN - - CALL THESAME(COMP(5,IN),COMP(1,IN),ISAME) - - IF(ISAME .EQ. 1) THEN - ICONV = 1 - XPRED(IN) = COMP(1,IN) - ENDIF - - IF(ISAME .EQ. 0) ICONV = 0 - - ENDIF - - IF(ISAMETOT .EQ. 1 .OR. ISAMETOT .EQ. 2) ICONV = 0 - - -C IF ICONV = 0, CONVERGENCE WAS NOT ACHIEVED. - - IF(ICONV .EQ. 0) RETURN - - - END DO - -C THE ABOVE END DO IS FOR THE DO IN = 1,NN LOOP. - -C TO GET TO THIS POINT, ALL COMPARTMENT AMOUNTS HAVE CONVERGED, AND -C THEIR PREDICTED AMOUNTS HAVE BEEN STORED INTO XPRED(IN),IN=1,NN. - - - RETURN - END - -c IDM3X151.FOR 7/7/14 - -C IDM3X151 HAS THE FOLLOWING CHANGE FROM IDM3X15.F - -C 1. ALL DIMENSIONS OF 71281 ARE CHANGED TO 72000. THIS IS TO ENSURE -C COMPATIBILITY WITH THE BESTDOS119.FOR PROGRAM. - -C 2. THE TWO WRITE STATEMENTS TO FILE 25 ARE REMOVED, SINCE FILE 25 IS -C NOT ACTIVE IN THIS PROGRAM. - -C 3. IN SUBROUTINE FUNC3, COMMON/ERROR/ERRFIL IS ADDED; ERRFIL IS -C DECLARED CHARACTER*20; AND FORMAT 111 AND SIG(.) ARE WRITTEN TO -C ERRFIL JUST BEFORE THE PROGRAM STOPS IF THE PATIENT DATA FILE -C HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE -C RESET ROW. - -C----------------------------------------------------------------------- - -c idm3x15.f 3/6/14 - -c idm3x15 has the following changes from idm3x14: - -c 1. In Subroutine FUNC3, the dimensions related to the no. of output -c equations have been changed from 6 to NUMEQT OR MAXNUMEQ (see -c comments in that routine). - -c 2. In Subroutine FUNC3, the dimensions of 6 in XSTORE and XPRED have -c been changed to 20, as they should have been all along (i.e., this -c represents the maximum no. of compartments allowed). - -c. 3. YPRED has been renamed to be YYPRED (to be consistent with -c the calling argument in the calling module, npageng25.f). Also, -c this will avoid confusion with the YPRED used in the module -c idm2x14.f. - -c 4. The argument list to IDCALCYY has the additional argument, -c NUMEQT, so that YYPRED can now be variably dimensioned. For the -c same reason, NUMEQT has been added to the argument list of -c Subroutines EVAL3 and FUNC3. - -c----------------------------------------------------------------------- - -c idm3x14.f 10/11/12 - -c idm3x14 has one correction from idm3x13: - -c THE R(.) ARE SET = RS(.,.) BEFORE GETIX IS CALLED IN THE TIME RESET -c SECTION OF SUBROUTINE FUNC3. NOT DOING THIS WOULD MEAN THAT IF THE -C INITIAL CONDITIONS FOR THE X(.) ARE FUNCTIONS OF THE COVARIATES -C (ESTABLISHED IN GETIX FROM THE R(.) VALUES), THEY WOULD BE ASSIGNED -C VALUES BASED ON COVARIATES FROM A PREVIOUS DOSAGE LINE IN THE -C PATIENT'S DATA FILE, RATHER THAN THE LINE WHICH IS THE DOSE RESET -C LINE. - -c----------------------------------------------------------------------- - -c idm3x13.f 9/27/12 - -c idm3x13 has the following bug correction to idm3x12: - -C IN SUBROUTINE FUNC3, BEFORE -C THE FIRST CALL TO GETFA, THE R(.) ARE SET = RS(.,.) IN CASE ANY OF -C THE FA(.) ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM -C THE R(.) VALUES IN GETFA. IN ADDITION, PRIOR TO THE 2 SECTIONS WHERE -C THE FA(.) ARE USED, GETFA IS CALLED SO THAT THE FA(.) ARE UPDATED TO -C CURRENT VALUES, BASED ON THE MOST RECENT COVARIATE VALUES IN THE -C PATIENT'S DATA FILE. IN PREVIOUS PROGRAMS, IT WAS SIMPLY ASSUMED -C THAT THE FA(.) WERE FUNCTIONS OF THE PARAMETERS, BUT NOT THE - -C COVARIATES, AND SO THIS WASN'T NECESSARY. BUT THE CODE IN -C TSTMULTI.FOR IMPLIES THAT THE FA(.) COULD BE FUNCTIONS OF THE -C COVARIATES, AND SO THIS CHANGE IS NECESSARY. - -C NOTE THAT SETTING THE R(.) TO RS(.,.) BEFORE THE FIRST CALL TO -C GETFA ALSO MEANS THE R(.) WILL BE SET BEFORE GETIX AND GETTLAG ARE -C FIRST CALLED, WHICH AGAIN IS REQUIRED IN CASE THEY ESTABLISH VALUES -C AS FUNCTIONS OF THE COVARIATES IN THE PATIENT DATA FILE. - -c----------------------------------------------------------------------- - -c idm3x12.f 7/25/12 - -c idm3x12 has the following change to idm1x11: - -c In SUBROUTINE FUNC3, the code to save ND0, SIGO, RSO, is moved to -c before the IF(N .EQ. 0) GO TO 75 statement. The reason is that -c before this routine returns, ND, SIG, and RS are reset back to these -c values, even if N = 0, and so they must be established at this time. - -c----------------------------------------------------------------------- - -c idm3x11.f 4/14/12 - -c idm3x11 has the following changes to idm2x10.f: - -c It is to be used with npageng17.f, which allows steady state doses -c to be boluses as well as IVs. As a result, an additional parameter, -c ISKIPBOL, is used so, in Subroutine FUNC, when convergence occurs in -c a steady state dose set, the last bolus from that set will not be -c reapplied below label 83. - -c----------------------------------------------------------------------- - -c idm3x10.f 4/10/12 - -c idm3x10 has one small 'bug' fix to idm3x9: - -c In Subroutine FUNC3, at label 40, and just below it in the do loop, -c NUMT+1 is replaced by NUMT. Also, all comment references to NUMT+1 -c are replaced by NUMT. The reason is that the no. of times at which -c predicted values are required is NUMT, not NUMT+1. This can, in -c rare situations, mean that TPRED(NUMT+1) = 0 can cause the program -c to stop with an error message (see code around format 111). - -c----------------------------------------------------------------------- - -c idm3x9.f 3/2/12 - -c idm3x9 has the following bug fix to idm3x8.f. In Subroutine FUNC3, -c the code to save ND, SIG, and RS before altering them if there are -c time lag parameters (in the call to GETTLAG) is now executed whether -c or not there are time lag parameters. The reason is that, with steady -c state doses, the first SIG(.) time in a steady state dose set is -c reset to be 0 after the steady state dose is identified. And this -c time must be reset back to be its original negative value at the end -c of the routine so that the next time the routine is called, the -c program will again know when a steady state dose is coming. - -c----------------------------------------------------------------------- - -c idm3x8.f 1/15/12 - -c Corrects bug in Subroutine FUNC3 - now time resets are identified -c by just the observation time = 0 (i.e., the dose time = 0 is -c no longer required). This is because it is possible for a dose -c time (especially if there are timelags) to be after the last -c observation time in a section of the patient file (before a time -c reset), and if this happens, the program will not be able to -c identify the observation time of 0 as a time reset. - -c----------------------------------------------------------------------- - -c idm3x7.f 11/11/11 - -c idm3x7 has the same changes to idm3x6 that idm1x7 has from idm1x6 -c (see all the comments in idm1x7.f for explanations). In particular: - -c 1. It can accommodate steady state dose regimens. - -c 2. All arrays related to doses (SIG,SIGO,RS,RSO, and BS) in -c Subroutine FUNC have their 500's changed to 5000's. - -c 3. Near the top of Subroutine FUNC, R(1)=0.0D0 is replaced by setting -c R(2*I-1) = 0.D0, for I = 1,NDRUG. This should have been done when -c the program became a multi-drug program (see comment in FUNC). - -c 4. A time reset no longer requires all initial compartment amounts -c to be reset to 0. This is because a time reset no longer has to mean -c an "infinite" amount of time has occurred with no dosing; it can also -c now mean an "infinite" amount of time has occurred with unknown -c dosing. So Subroutine GETIX will be called to establish initial -c conditions for the new time period (these initial values can of -c course be 0's as was always assumed in previous programs). This is -c the situation where a patient, who previously had doses and -c observations which were recorded while he was in a lab, goes home and -c gets unknown doses over a long time period, and then returns to the -c lab to get a new set of doses and observations, starting with -c observations which establish his initial conditions for this new -c time period. - -c----------------------------------------------------------------------- - -c idm3x6.f 12/20/10 - -c idm3x6 has the following change to idm3x5: - -c In Subroutine FUNC3, it has code that calls Subroutine ANAL3, rather -c than USERANAL if N .EQ. -1. Also, the code to reset X(I),I=1,N to 0 -c where there is a time reset now includes extra code to set -c X(I),I=1,3 to 0 if N .EQ. -1. - -c Note that ANAL3, and the routines it calls are from the Little NPAG -c program module, IDPC9A.FOR. - -c Note that this module is linked first with bigmlt11.f, and the -c template model file is TSTMULTH.FOR (in which in Subroutine SYMBOL, -c the user is told to code N=-1 if he wants to assume the standard -c 3-compartment linear model with analytic solutions, and in this -c case also establish the 5 parameters, {KE,KA,KCP,KPC,V} of this -c model). - -c----------------------------------------------------------------------- - -c idm3x5.f 4/03/10 - -c idm3x5 has a bug correction to idm3x4. In Subroutine FUNC3, in the -c IF(TPRED(KNT) .EQ. 0.D0 .AND. SIG(KNS) .EQ. 0.D0) block, the time, -c T, is also reset = 0 since the integration will again start from -c time 0. When this wasn't done (in idm3x4.f), the results were -c unpredictable (depending on how the DVODE integration routines -c treated a (T,TOUT) pair which decreased rather than increased. - -c----------------------------------------------------------------------- - -c idm3x4.f 11/23/09 - -c idm3x4 fixes a bug in the idm3x3 code. Label 75 is moved to in -c front of the CALL GETTLAG(TLAG) statement (see the reason in -c that part of the code). - -c----------------------------------------------------------------------- - -c idm3x3.f 9/18/09 - -c idm3x3 has the following changes from idm3x2: - -c 1. The TLAG and FA vectors, and the initial values for the X array -c will be set by calling new routines (GETTLAG, GETFA, and GETIX, -c respectively) that are part of the model file (the new template is -c TSTMULT.FOR). This means the user can now code explicit formulas -c for these values. As a result, all reference to NTLAG, IC, IFA, and -c IVOL have been removed. - -c 2. The shift subroutine will now be from the module, shift5.f, -c rather than shift4.f. - -c Note that this module, along with idm1x3.f, id2x3.f, and shift5.f -c are part of the new "engine", whose main module is bigmlt4.f. - -c----------------------------------------------------------------------- - -c idm3x2.f 8/14/09 - -c idm3x2 has the following changes from idm3x1: - -c 1. The code for setting initial compartment amounts from initial -c compartment concentrations is changed to reflect the fact that -c now IC(2) refers to the index of the covariates, not the -c column no. of RS (see comment in code). - -c 2. The code to establish the timelag parameters has changed to -c reflect that NTLAG(I) can now be negative --> in Subroutine -c SHIFT, the associated timelag parameter will now be the -c exponent of the indicated parameter (rather than the parameter -c itself). - -c 3. The code to establish the FA parameters has changed to -c reflect that IFA(I) can now be negative --> the associated FA -c parameter will now be the exponent of the indicated parameter -c (rather than the parameter itself). - - -c idm3x2.f (along with other new modules idm1x2.f and idm2x2.f) are -c still called by bigmlt2.f, but are part of the "engine" for the -c new NPBIG15B.FOR program. - -c----------------------------------------------------------------------- - - -c idm3x1.f 5/27/09 - -c idm3x1.f has the following changes from idcy_63f.f: - -c 1. It allows the extra option of setting initial compartment -c amounts from their initial concentrations - see code in Subroutine -c FUNC3. - -c 2. It is part of the new Big NPAG "engine", bigmlt2.f, which allows -c patient data files to have "reset" values of 0 in the dosage and -c sampling blocks. Whenever, in Subroutine FUNC2, the program sees a -c SIG(.) = 0 and a TIM(.) = 0, it knows that a large enough time has -c passed since the last dose that all compartment amounts are to be -c reset = 0. Subsequent dose and observed value times are then values -c from this point. - -c 3. The first argument to Subroutine OUTPUT is changed from 0.0 to -c 0.D0 in two places. - - -c This module, along with idm1x1.f and idm2x1.f are first used in the -c bigmlt2.f program. - -c----------------------------------------------------------------------- - - - -c idcy_63g.f 5-28-02 - -c idcy_63g has the following changes from idcy_63f: - -c It allows multiple drug inputs (rather than just one drug input). -c The changes required for this are: - -c 1. BS has dimension change from (500,3) to (500,7) -c 2. COMMON/CNST2 is changed to include NDRUG (no. of drugs) and -c NADD (no. of additional covariates), rather than NBI and NRI. -c 3. NTLAG is now a vector instead of a scalar. In particular, -C NTLAG(I) = 0 IF DRUG I'S BOLUS COL. HAS NO TIMELAG PARAMETER; -C K IF DRUG I'S BOLUS COL. HAS A TIMELAG WHOSE VALUE IS -C GIVEN BY PARAMETER NO K. -C 4. IFA, PASSED IN COMMON/FRABS FROM SUBROUTINE SYMBOL IS NOW A VECTOR -C INSTEAD OF A SCALAR. -C IFA(I) = 0 IF DRUG I WILL HAVE FA = 1.0. -C K IF DRUG I WILL HAVE AN FA WHOSE VALUE IS TO BE GIVEN -C BY PARAMETER K. -C 5. THE BOLUS COMPARTMENT NOS., NBCOMP(I), NOW COME VIA -C COMMON/BOLUSCOMP FROM SUBROUTINE SYMBOL, AND THE DIMENSION OF -C NBCOMP HAS BEEN CHANGED TO 7 (MAXIMUM OF 1 PER DRUG) FROM 20. -C 6. ALL OF THE CODE IN SUBROUTINE FUNC3 RELATED TO NRI AND NBI HAS -C BEEN CHANGED TO BE IN TERMS OF NI AND NDRUG. -C 7. THE CODE RELATED TO CALLING SUBROUTINE SHIFT, INCLUDING THE -C CALLING ARGUMENTS, HAS BEEN CHANGED TO REFLECT THE ABOVE CHANGES -C IN NTLAG (I.E., IT IS NOW A VECTOR RATHER THAN A SCALAR). A NEW -C MODULE, shift3.f (WHICH REPLACES shift2.f) WILL BE LINKED WITH -C THIS MODULE. - -C----------------------------------------------------------------------- - -c idcy_63f.f 4-23-02 - - -c idcy_63f has the following changes to idcy_63e: - -c 1. To enable FA to be a parameter value (either fixed or random), -c rather than always be hardcoded = 1.0, the following changes are -c implemented ... - -c The hardcoding of FA = 1.0 and the code for NBCOMP are removed -c from main. In addition, COMMON/BCOMP is removed from the entire -c module. Instead, in SUBROUTINE FUNC3, a new COMMON/FRABS/IFA provides -c the value IFA which is the parameter index of the FA value (passed -c from SUBROUTINE SYMBOL) unless it = 0, in which case FA is -c set = 1.0. Also the NBCOMP compartment nos. are now set in -c SUBROUTINE FUNC3. - -c 2. COMMONS /OBSER AND /SUM2 (and the arrays in them) are deleted from -c main. They were not needed. Also, COMMON CNST2 is deleted from main -c since NBI is no longer needed here (since NBCOMP code is removed - -c see no. 1. above). - -c----------------------------------------------------------------------- - -c idcy_63e.f 1-22-00 - -c idcy_63e has the following changes to idcy_63d: - -c It allows the initial conditions of the amounts in the compartments -c to be paramater values, rather than fixed at 0.0. These parameter -c values may be either fixed or random. - -c To affect this enhancement, the primary change is the code in -c subroutine FUNC3 which sets the initial conditions based on the -c values in IC which are provided by COMMON/INITCOND from -c SUBROUTINE SYMBOL of the Fortran model file. - -c There are many other changes to simply the code (i.e., a lot of -c code was leftover code which was unused and/or confusing), namely: - -c - Commons ADAPT1, ADAPT2, LPARAM, PRED, TRANS, and PARAM are -c deleted. Variables ISW, IP, and C are deleted. -c - COMMON/PARAMD/P is now in MAIN, FUNC, and JACOB of idfix5e.f; -c MAIN and FUNCx of idcy_53e.f and idcy_63e.f; and DIFFEQ and OUTPUT -c of the Fortran model file. -c - P is redimensioned 32. It will hold only the parameters of the -c model (although some of those parameters may be initial conditions) -c and there are 20 allowable random paramaters and 12 allowable -c fixed paramaters now. -c - All the code to reverse the paramater order (using PD) and to do -c and undo square root transformations in MAIN and FUNC3 is removed -c (it was unneeded, and therefore confusing). In particular, all -c references to NPT, NUMYES, NUIC, NUP, NPNL, and NBOT are removed. -c - COMMON ANALYT/IDIFF is removed. IDIFF is unneeded since IDIFF = 0 -c is equivalent to N = 0, and so IDIFF code in FUNC3 is replaced by -c the equivalent code for N. NEQN is replaced by N. -c - In SUBROUTINE EVAL3, COMMON/PARAM is removed, along with PP and P. -c Setting PP(I) = P(I), I=1,NPNL made no sense since PP wasn't used -c and NPNL was always = 0 anyway. -c - In FUNC3, the If statment at label 83 is changed to include -c N .EQ. 0 since if N = 0, setting compartment values is unnecessary. - -c idcy_63e is part of the big npem program, npbig4.f. - - - SUBROUTINE IDCALCYY(NPP,NDIM,ESTML,TPRED,NUMT,YYPRED,NUMEQT) - -C INPUT ARE: - -C NPP = NO. OF PARAMETERS (RANDOM AND FIXED) IN THE PARAMATER -C VECTOR, ESTML. -C NDIM = NO. OF STATES FOR THE O.D.E. -C ESTML = VECTOR OF PARAMETER ESTIMATES. -C TPRED = VECTOR OF TIMES AT WHICH PREDICTED CONCENTRATIONS WILL -C BE FOUND. -C NUMT = OF TIMES IN TPRED. - - -C INFORMATION FROM A SUBJECT DATA FILE WHOSE INFO IS PASSED TO THE -C ROUTINES IN THIS MODULE VIA COMMONS /OBSER/, /CNST/, /CNST2/, AND -C /SUM2/. - - -C OUTPUT IS: - - -C YYPRED(I,J), I=1,NUMT; J=1,NOS = THE PREDICTED VALUE AT TIME -C TPRED(I) OF THE JTH OUTPUT EQUATION, GIVEN THE INPUT VECTOR -C ESTML. M AND NOS ARE INPUT TO THIS MODULE VIA COMMONS SUM2 AND -C CNST2, RESPECTIVELY. - -c----------------------------------------------------------------------- - -c See other comments at the top of idcy_63d.f code. - -C----------------------------------------------------------------------- - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION ESTML(32),YYPRED(72000,NUMEQT),TPRED(72000),P(32) - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/PARAMD/ P - -C*****INITIALIZE PROGRAM***** - - CALL SYMBOL - -C THE ABOVE CALL OBTAINS INFO FROM COMMONS. - -C NOTE THAT THIS PROGRAM NOW GETS N = NDIM AND NPP = NVAR+NOFIX -C AS CALLING ARGUMENTS. - - N = NDIM - NP = NPP - -C CALCULATE THE OUTPUT CONCENTRATION VECTOR, Y, FOR THE PARAMETER -C VECTOR, ESTML. - -C PUT MODEL PARAMETER VALUES INTO P. - - DO I=1,NP - P(I) = ESTML(I) - END DO - - -C CALL SUBROUTINE EVAL3 TO GET Y, EVALUATED -C AT ESTML(I) AS DEFINED ABOVE. - - CALL EVAL3(NUMT,YYPRED,TPRED,NUMEQT) - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE FUNC3(NUMT,YYPRED,TPRED,NUMEQT) - - -C THIS SUBROUTINE, CALLED BY EVAL3, FINDS YYPRED(I) = OUTPUT CONC. AT -C THE NUMT TIMES IN TPRED, GIVEN PARAMETER VALUES IN P. -C NOTE THAT YYPRED IS FOUND AT THE NUMT TIMES IN TPRED BELOW. - - IMPLICIT REAL*8(A-H,O-Z) - COMMON/BOLUSCOMP/NBCOMP - COMMON/OBSER/ TIM,SIG,RS,YO,BS - COMMON/CNST/ N,ND,NI,NUP,NUIC,NP - COMMON/INPUT/ R,B - COMMON/PARAMD/ P - COMMON/CNST2/ NPL,NOS,NDRUG,NADD - COMMON/STATE/ X - COMMON/ERROR/ERRFIL - PARAMETER(MAXNUMEQ=7) - -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. - - - DIMENSION X(20),P(32),TIM(594),SIG(5000),SIGO(5000),R(37), - 1 RS(5000,34),RSO(5000,34),YT(MAXNUMEQ),YO(594,MAXNUMEQ), - 2 YYPRED(72000,NUMEQT),BS(5000,7),Y(72000,MAXNUMEQ),B(20), - 3 NBCOMP(7),TPRED(72000),TLAG(7),FA(7),XSTORE(100,20),XPRED(20) - - CHARACTER ERRFIL*20 - -C NOTE THAT AS OF idm3x15.f, THE DIMENSIONS OF 6 IN XSTORE AND XPRED -C HAVE BEEN CHANGED TO 20, WHICH IS WHAT THEY SHOULD HAVE BEEN ALL -C ALONG (I.E., THE SAME AS FOR X). - -C NOTE THAT THE DIMENSIONS RELATED TO THE NO. OF OUTPUT EQS. IN -C YO, YT AND Y ARE CHANGED TO MAXNUMEQ (FROM 6). NUMEQT COULD NOT -C BE USED BECAUSE THESE ARRAYS WERE NOT PASSED TO THIS ROUTINE AS -C DUMMY ARGUMENTS. - - -C THE 2ND DIMENSION OF YYPRED IS CHANGED TO NUMEQT, SINCE IT IS PASSED -C IN THE ARGUMENT LIST, AND CAN THEREFORE BE VARIABLY DIMENSIONED. - - -C NOTE THAT "7" IN THE ABOVE ARRAYS INDICATE THE NO. OF DRUGS ALLOWED. - -C*****ODE CONSTANTS AND INITIALIZATION***** - - KNS=1 - KNT=1 - -C NOTE THAT KNT IS THE RUNNING INDEX OF THE NEXT OBSERVATION TIME, -C AND KNS IS THE RUNNING INDEX OF THE NEXT DOSAGE TIME. - - T=0.0D0 - -C INITIALIZE ISKIPBOL = 0. SEE CODE BELOW. IT IS ONLY NEEDED FOR A -C STEADY STATE DOSE SET WHICH HAS BOLUS DOSES. - - ISKIPBOL = 0 - - - DO I = 1,NDRUG - R(2*I-1) = 0.D0 - END DO - -c AS OF idm3x7.f, instead of R(1) = 0, the code has been changed to -c set R(2*I-1) = 0, for I = 1,NDRUG. I.E., All IV rates for all NDRUG -c drugs are initialized to be 0 ... in case the 1st obs. time is 0, -c which means that OUTPUT is called before the R(I) are set below. - -C CALL SUBROUTINE GETFA IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETFA IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF FA FOR EACH -C OF THE NDRUG DRUGS. - -C AS OF idm3x13.f, BEFORE CALLING GETFA, MUST SET -C THE R(.) IN CASE ANY OF THE FA(.) ARE FUNCTIONS OF THE -C COVARIATES WHICH ARE ESTABLISHED FROM THE R(.) VALUES IN -C GETFA. - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - - CALL GETFA(FA) - - -C NOTE THAT NBCOMP(I),I=1,NDRUG WAS SET IN SUBROUTINE SYMBOL AND -C PASSED TO THIS ROUTINE VIA COMMON/BOLUSCOMP. - - -C As of idm3x12.f, the code to save ND0, SIGO, RSO, is moved to before -c the IF(N .EQ. 0) GO TO 75 statement. The reason is that before this -c routine returns, ND, SIG, and RS are reset back to these values, -c even if N = 0, and so they must be established at this time. - -C AS OF idm3x9.f, SAVE ND, SIG, AND RS WHETHER OR NOT NTL = 1, SINCE -C IF THERE ARE STEADY STATE DOSE SETS, THE FIRST SIG(.) VALUE IN EACH -C SET WILL BE CHANGED TO BE 0 BELOW. - - NDO = ND - DO I=1,ND - SIGO(I) = SIG(I) - DO J=1,NI - RSO(I,J) = RS(I,J) - END DO - END DO - - - -C IF N = 0, THE OUTPUT EQUATION(S) FOR Y ARE CODED EXPLICITLY INTO -C SUBROUTINE OUTPUT, AND NO D.E. SOLUTIONS (VIA USERANAL/DIFFEQ) ARE -C TO BE USED. IN THIS CASE, SKIP THE CODE REGARDING INITIAL CONDITIONS -C OF THE COMPARTMENTS, SINCE THEY ARE IRRELEVANT (I.E., THE COMPARTMENT -C AMOUNTS DON'T NEED TO BE INITIALIZED SINCE THEY WON'T BE UPDATED BY -C INTEGRATING D.E.'S). IN FACT, COULD PROBABLY SKIP TIMELAGS TOO, -C SINCE THEY CHANGE THE TIME THAT BOLUS DOSES ARE GIVEN, AND THIS -C THEORETICALLY ONLY AFFECTS COMPARTMENT AMOUNTS (WHICH ARE NOT USED -C IF N = 0), BUT JUST SKIP INITIAL CONDITIONS FOR NOW. - - IF(N .EQ. 0) GO TO 75 - - -C CALL SUBROUTINE GETIX IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETIX IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF X (THE INITIAL -C COMPARTMENT AMOUNT) FOR EACH OF THE N COMPARTMENTS. - - CALL GETIX(N,X) - - - -C CALL SUBROUTINE GETTLAG IN npemdriv.f (THE FIRST TEMPLATE FILE TO -C INCLUDE GETTLAG IS TSTMULTG.FOR) TO OBTAIN THE VALUE OF THE TIMELAG -C FOR EACH OF THE NDRUG DRUGS. - - 75 CALL GETTLAG(TLAG) - -C IF ANY TLAG(.) VALUES RETURN AS .NE. 0, THEN, CALL SUBROUTINE SHIFT -C TO ADJUST THE DOSAGE REGIMEN APPROPRIATELY. - - NTL = 0 - DO ID = 1,NDRUG - IF(TLAG(ID) .NE. 0) NTL = 1 - END DO - - IF(NTL .EQ. 1) THEN - -C STORE INCOMING VALUES IN ND, SIG, AND RS (WHICH CONTAINS BS VALUES) -C SINCE THEY WILL BE CHANGED IN THE CALL TO SUBROUTINE SHIFT, WHICH -C "SHIFTS" THE DOSAGE REGIMEN MATRIX TO ACCOUNT FOR THE TIMELAG -C PARAMETER(S), TLAG(I). AT THE END OF THIS ROUTINE, THE VALUES IN ND, -C SIG, AND RS WILL BE RESET TO THEIR INCOMING VALUES - TO BE READY FOR -C THE NEXT CALL TO THIS ROUTINE WITH POSSIBLY DIFFERENT VALUES FOR -C TLAG(I). - - - CALL SHIFT(TLAG,ND,SIG,NDRUG,NADD,RS) - - -C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NTL .EQ. 1) CONDITION. - - - - - IF(TPRED(KNT).GE.SIG(KNS)) GO TO 12 - IF(TPRED(KNT).NE.0.0D0) GO TO 45 - -C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TPRED(KNT) -C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. - - CALL OUTPUT(0.D0,YT) - DO 2000 I=1,NOS -2000 Y(KNT,I)=YT(I) - KNT=KNT+1 - GO TO 45 - -12 IF(TPRED(KNT) .GT. SIG(KNS)) GO TO 13 - IF(TPRED(KNT) .NE. 0.0D0) GO TO 45 - -C THE ONLY WAY THE FOLLOWING CALL TO OUTPUT CAN OCCUR IS IF TPRED(KNT) -C = 0 --> OBTAIN YT = OUTPUT VALUE(S) AT TIME 0.0. - - CALL OUTPUT(0.D0,YT) - DO 2005 I=1,NOS -2005 Y(KNT,I)=YT(I) - KNT=KNT+1 - -13 IF(SIG(KNS) .GT. 0.0D0) GO TO 45 - -C CHECK TO SEE IF SIG(KNS) < 0. IF SO, IT MEANS THAT 100 STEADY STATE -C DOSES SHOULD NOW BE APPLIED WITH AN INTERDOSE INTERVAL EQUAL TO -C -SIG(KNS). - - ISTEADY = 0 - - IF(SIG(KNS) .LT. 0.D0) THEN - - ISTEADY = 1 - NSET = 1 - -C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE -C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 -C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... -C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. -C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE -C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE -C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE -C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC -C OF PREDLAST3 REQUIRES). - -C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT -C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS -C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF -C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE -C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. - -C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF -C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL -C INTEGRATED THROUGH, WHICHEVER COMES FIRST. - - DOSEINT = -SIG(KNS) - - - -C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START -C OF 100 DOSE SETS THAT BEGIN AT TIME 0. - - - SIG(KNS) = 0 - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. - - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - IF(NDRUG .EQ. 0) GO TO 81 - -C AS OF idm3x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT -C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED -C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. - - CALL GETFA(FA) - - - IF(N .EQ. 0) GO TO 120 - DO I=1,NDRUG - X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS,I)*FA(I) - END DO - -C NOTE THAT FA(I) IS THE FRACTION OF DRUG AVAILABLE FROM A BOLUS INPUT -C FOR DRUG I INTO ITS ABSORPTIVE COMPARTMENT. - - GO TO 81 - -120 DO I=1,NDRUG - B(I)=BS(KNS,I)*FA(I) - END DO - -81 KNS=KNS+1 - -C*****INTEGRATION OF EQUATIONS***** - - -C DETERMINE IF, OBSER(ID=0), OR DOSE(ID=1), OR BOTH(ID=2). - -45 IF(KNS.GT.ND) GO TO 15 - - - -C CODE CHANGE BELOW FOR idm3x8.f. - - IF(TPRED(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) THEN - - - -C AS OF idm3x7.f, A TIME RESET NO LONGER REQUIRES ALL INITIAL -C COMPARTMENT AMOUNTS TO BE RESET TO 0. THIS IS BECAUSE A TIME RESET -C NO LONGER HAS TO MEAN THAT AN "INFINITE" AMOUNT OF TIME HAS OCCURRED -C WITH NO DOSING; IT CAN ALSO NOW MEAN THAT AN "INFINITE" AMOUNT OF -C TIME HAS OCCURRED WITH UNKNOWN DOSING (IN THIS CASE, SUBROUTINE -C GETIX WILL BE CALLED BELOW TO ESTABLISH INITIAL CONDITIONS FOR THIS -C TIME PERIOD). - -C ADVANCE KNS TO THE NEXT VALUE THAT HAS SIG(KNS) .LE. 0. I.E., ONCE -C TIMN(KNT) = 0, IT MEANS THAT WE ARE DONE WITH THE OUTPUT OBS. -C TIMES IN THE PREVIOUS SECTION --> THERE IS NO POINT IN CONTINUING -C TO INTEGRATE TILL THE END OF THE DOSES IN THE PREVIOUS SECTION -C (IF THERE ARE ANY). - - DO IKNS = KNS,ND - IF(SIG(IKNS) .LE. 0.D0) GO TO 110 - END DO - -C TO GET HERE MEANS THAT NO VALUE IN SIG(.) FROM KNS TO ND HAS A -C VALUE .LE. 0, AND THIS IS AN ERROR. IT MEANS THAT THE PATIENT DATA -C FILE HAS AN OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING -C DOSE RESET ROW. TELL THE USER AND STOP. - - WRITE(*,111) ND,KNS,SIG(KNS) -111 FORMAT(//' IN SUBROUTINE FUNC3, THE CURRENT SUBJECT HAS AN'/ - 1' OBSERVATION TIME RESET ROW WITHOUT AN ACCOMPANYING DOSE'/ - 2' RESET ROW. THE PROGRAM NOW STOPS. '// - 3' REVIEW YOUR PATIENT FILES AND CORRECT THE ERROR.'// - 4' NOTE THAT THE ',I4,' DOSE TIMES (POSSIBLY ALTERED BY TIMELAGS'/ - 5' ARE THE FOLLOWING (AND THERE IS NO TIME .LE. 0 AFTER TIME'/ - 6' NO. ',I4,' WHICH HAS CORRESPONDING TIME ',F15.4,'):') - - - DO I = 1,ND - WRITE(*,*) SIG(I) - END DO - - OPEN(47,FILE=ERRFIL) - WRITE(47,111) ND,KNS,SIG(KNS) - DO I = 1,ND - WRITE(47,*) SIG(I) - END DO - CLOSE(47) - - - CALL PAUSE - STOP - - - 110 KNS = IKNS - - - -C THERE ARE TWO POSSIBILITES AT THIS POINT, EITHER SIG(KNS) = 0 -C OR SIG(KNS) < 0. - -C IF SIG(KNS) = 0, THIS REPRESENTS A TIME RESET (T WILL BE SET = 0 -C BELOW) WITH A SINGLE DOSE LINE TO START. IN THIS CASE, CALL GETIX -C AGAIN (JUST AS WAS DONE NEAR THE TOP OF THIS ROUTINE) TO OBTAIN -C INITIAL COMPARTMENT AMOUNTS. NOTE THAT BY DEFAULT, IN GETIX, ALL -C COMPARTMENT AMOUNTS ARE SET = 0 (WHICH WOULD BE THE CASE IF IN THE -C LONG TIME PERIOD BETWEEN THE LAST SET OF DOSES AND THIS NEW -C BEGINNING, NO DOSES HAVE BEEN GIVEN). BUT THE USER MAY ALSO HAVE -C CODED INTO GETIX EQUATIONS THAT SET ONE OR MORE OF THE X(I) TO -C FUNCTIONS OF COVARIATE AND PARAMETER VALUES (WHICH WOULD BE THE -C SITUATION IF AN UNKNOWN DOSING REGIMEN HAS TAKEN PLACE BUT IT -C DOESN'T MATTER WHAT IT WAS BECAUSE THE PATIENT COMES TO A LAB AND -C SIMPLY HAS HIS COMPARTMENT VALUES ESTABLISHED BEFORE CONTINUING -C WITH THE OTHER VALUES IN HIS PATIENT FILE). - -C IF SIG(KNS) < 0, THIS REPRESENTS A TIME RESET WITH A STEADY STATE -C SET OF 100 DOSES ABOUT TO BEGIN. IN THIS CASE, WE ASSUME THAT THE -C PATIENT IS ABOUT TO GET 100 SETS OF DOSES SO THAT HIS COMPARTMENT -C AMOUNTS WILL ACHIEVE STEADY STATE VALUES. THESE STEADY STATE VALUES -C WILL BE ESTIMATED IN THE BLOCK OF CODE BELOW THAT STARTS WITH -C IF(ISTEADY .EQ. 1). IN THIS CASE, WE WILL STILL CALL GETIX TO -C MAKE SURE THAT ANY RESIDUAL COMPARTMENT AMOUNTS FROM A PREVIOUS -C SET OF DOSES IS ZEROED OUT (OR SET = VALUES AS DETERMINED BY -C SUBROUTINE GETIX). - -C AS OF idm3x14.f, BEFORE CALLING GETIX, MUST SET -C THE R(.) IN CASE ANY OF THE INITIAL CONDITIONS FOR THE X(.) -C ARE FUNCTIONS OF THE COVARIATES WHICH ARE ESTABLISHED FROM THE -C R(.) VALUES IN GETFA. - - DO I=1,NI - R(I)=RS(KNS,I) - END DO - - - CALL GETIX(N,X) - - - -C MUST ALSO RESET T = 0 SINCE THE INTEGRATION WILL AGAIN START FROM -C TIME 0. - - T = 0.D0 - - -C IF SIG(KNS) .LT. 0, THIS IS NOT ONLY A TIME RESET, IT IS THE -C BEGINNING OF A STEADY STATE DOSE SET. IN THIS CASE, APPLY 100 -C STEADY STATE DOSES WITH AN INTERDOSE INTERVAL EQUAL TO -SIG(KNS). - - ISTEADY = 0 - - IF(SIG(KNS) .LT. 0.D0) THEN - - ISTEADY = 1 - NSET = 1 - -C NOTE THAT ISTEADY = 1 TELLS THE PROGRAM BELOW TO PROCEED AS IF THE -C DOSE TIME IS 0, AND START INTEGRATING THROUGH THE SET OF 100 -C DOSE SETS, ALL OF WHICH OCCUR BEFORE THE NEXT OBSERVATION TIME ... -C BUT PAUSE AFTER THE END OF THE 5TH DOSE SET (NSET IS THE RUNNING NO. -C OF THE CURRENT DOSE SETS THAT HAVE BEEN RUN) AND CALL SUBROUTINE -C PREDLAST3 TO PREDICT THE STEADY STATE COMPARTMENT AMOUNTS AFTER THE -C 100 DOSE SETS (NOTE THAT THE COMPARTMENT AMOUNTS WILL HAVE TO BE -C STORED AT THE END OF EACH OF THE STEADY STATE DOSE SETS AS THE LOGIC -C OF PREDLAST3 REQUIRES). - -C IF "CONVERGENCE" IS ACHIEVED AT THAT POINT, ASSIGN THE COMPARTMENT -C AMOUNTS TO BE THE PREDICTED AMOUNTS, AND ASSIGN KNS TO BE WHAT IT IS -C WHEN THESE STEADY STATE DOSE SETS HAVE FINISHED. NOTE THAT THE END OF -C THE 100TH DOSE SET WILL BE AT TIME 100*(-SIG(KNS)), SO KNS WILL BE -C THE INDEX OF THE FIRST DOSE EVENT WHICH OCCURS AFTER THIS TIME. - -C IF "CONVERGENCE" IS NOT ACHIEVED, CONTINUE APPLYING THE LOGIC OF -C PREDLAST3 UNTIL IT IS ACHIEVED, OR UNTIL THE 100 DOSE SETS ARE ALL -C INTEGRATED THROUGH, WHICHEVER COMES FIRST. - - DOSEINT = -SIG(KNS) - -C RESET SIG(KNS) TO BE 0 SINCE THIS DOSE EVENT REPRESENTS THE START -C OF 100 DOSE SETS THAT BEGIN AT TIME 0. - - - - SIG(KNS) = 0 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SIG(KNS) .LT. 0.D0) CONDITION. - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(TPRED(KNT) .EQ. 0.D0 .AND. KNT .GT. 1) CONDITION. - - - IF(TPRED(KNT) .NE. SIG(KNS)) GO TO 20 - ID=2 - TOUT=TPRED(KNT) - - KNT=KNT+1 - KNS=KNS+1 - - IF(N .EQ. 0) GO TO 31 - GO TO 30 - -20 IF(TPRED(KNT) .GT. SIG(KNS) .AND. SIG(KNS) .GT. 0) GO TO 25 - -15 ID=0 - TOUT=TPRED(KNT) - - KNT=KNT+1 - - IF(N .EQ. 0) GO TO 31 - GO TO 30 - -25 ID=1 - TOUT=SIG(KNS) - - KNS=KNS+1 - IF(N .EQ. 0) GO TO 31 - - -30 CONTINUE - - -32 IF(N .NE. -1) CALL USERANAL(X,T,TOUT) - IF(N .EQ. -1) CALL ANAL3(X,T,TOUT) - - - -C IF ISTEADY = 1, THIS IS INSIDE A STEADY STATE DOSE SET. CHECK TO SEE -C IF TOUT IS A MULTIPLE OF DOSEINT. IF SO, RECORD THE COMPARTMENT -C AMOUNTS. THEN, AFTER COMPARTMENT AMOUNTS HAVE BEEN STORED FOR AT -C LEAST THE 1ST 5 MULTIPLES OF DOSEINT, STOP AND CALL SUBROUTINE -C PREDLAST3 WHICH PREDICTS THE FINAL (STEADY STATE) COMPARTMENT AMOUNTS -C AFTER THE LAST (100TH) DOSE SET. - -C IF PREDLAST3 HAS PREDICTED VALUES WHICH "CONVERGE", ASSIGN THE -C PREDICTED VALUES TO X, INCREASE KNS TO BE THE INDEX OF THE FIRST DOSE -C EVENT WHICH OCCURS AFTER THE STEADY STATE DOSE SET ENDS AND CONTINUE. - -C IF PREDLAST3 VALUES DON'T CONVERGE, CONTINUE THE PROCESS WITH -C COMPARTMENT AMOUNTS FOR MULTIPLES 2 - 6 OF DOSEINT, TEST FOR -C "CONVERGENCE", ETC. THIS PROCESS CONTINUES UNTIL "CONVERGENCE" IS -C ACHIEVED FOR A SET OF 5 COMPARTMENT AMOUNTS (OR SETS OF AMOUNTS IF -C NDRUG IS > 1), OR UNTIL ALL 100 DOSE SETS IN THE STEADY STATE REGIMEN -C HAVE FINISHED. - - IF(ISTEADY .EQ. 1) THEN - - -C THE NEXT DOSE SET END TIME IS DOSEINT*NSET. IF TOUT = DOSEINT*NSET, -C STORE THE COMPARTMENT AMOUNTS. IF NSET .GE. 5, CALL PREDLAST3 AND -C PROCEED AS INDICATED ABOVE. - - CALL THESAME(TOUT,DOSEINT*NSET,ISAME) - - IF(ISAME .EQ. 1) THEN - - NN = N - IF(N .EQ. -1) NN = 3 - - DO J = 1,NN - XSTORE(NSET,J) = X(J) - END DO - - IF(NSET .GE. 5) THEN - - CALL PREDLAST3(NN,NSET,XSTORE,XPRED,ICONV) - -C - - IF(ICONV .EQ. 1) THEN - -C SINCE THE PREDICTED VALUES ARE CONSIDERED ACCURATE (I.E., -C "CONVERGENCE WAS ACHIEVED IN PREDLAST), RESET ISTEADY TO 0, -C WHICH MEANS THAT THE STEADY STATE DOSES ARE FINISHED; ASSIGN THE -C COMPARTMENT AMOUNTS TO BE THE PREDICTED VALUES; AND SET KNS TO THE -C FIRST DOSE EVENT AFTER THE END OF THE STEADY STATE DOSE SET. ALSO, -C SET T = THE ENDING TIME OF THE STEADY STATE DOSE SET = 100*DOSEINT, -C SINCE THAT IS WHAT IT WOULD HAVE BEEN HAD ALL 100 DOSE SETS BEEN -C RUN. - - - ISTEADY = 0 - - DO J = 1,NN - X(J) = XPRED(J) - END DO - - - T = 100.D0*DOSEINT - -C ADVANCE KNS TO BE THE FIRST DOSE PAST THE 100 DOSE SETS IN THIS -C STEADY STATE SET. NOTE THAT THIS SET ENDS BEFORE 100*DOSEINT, SO -C FIND THE FIRST SIG(.) THAT IS .GE. 100*DOSEINT, OR THAT IS = 0 -C (WHICH SIGNIFIES A TIME RESET) OR THAT IS < 0 (WHICH SIGNIFIES -C ANOTHER STEADY STATE SET). - - DO I = KNS,ND - IF(SIG(I) .GE. 100.D0*DOSEINT .OR. SIG(I) .LE. 0.D0) THEN - KNSNEW = I - GO TO 100 - ENDIF - END DO - - -C TO GET HERE MEANS THAT THERE ARE NO DOSE TIMES PAST THE END OF THIS -C STEADY STATE DOSE SET. IN THIS CASE, SET KNS TO ND+1 - - KNS = ND+1 - GO TO 200 - - 100 KNS = KNSNEW - 200 CONTINUE - - - -C SET ISKIPBOL = 1 WHENEVER CONVERGENCE OCCURS IN -C THE STEADY STATE DOSES SINCE IN THIS CASE, WE DON'T WANT TO -C REAPPLY THE LAST BOLUS FROM THE STEADY STATE SET BELOW LABEL 83. - - ISKIPBOL = 1 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICONV .EQ. 1) CONDITION. - -C IF ICONV = 0, ISTEADY IS STILL = 1, -C WHICH MEANS THAT THE ATTEMPT TO PREDICT THE FINAL (STEADY STATE) -C COMPARTMENT AMOUNTS CONTINUES. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NSET .GE. 5) CONDITION. - -C SINCE ISAME = 1, THE END OF THE SET NO. NSET HAS OCCURRED --> -C INCREASE NSET BY 1. - - NSET = NSET + 1 - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISAME .EQ. 1) CONDITION. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ISTEADY .EQ. 1) CONDITION. - - - -31 CONTINUE - - -C RECORD OBSERVATION AND SUPPLY NEW DOSE - - IF(ID.EQ.1) GO TO 35 - KNTM1=KNT-1 - -C NOTE THAT THE TIME AT WHICH THE OUTPUT IS DESIRED IS TPRED(KNTM1); -C THIS IS CLEAR SINCE THE RETURNING VALUE(S) IN YT ARE PUT INTO ROW NO. -C KNTM1 OF Y. - - CALL OUTPUT(TPRED(KNTM1),YT) - - DO 2010 I=1,NOS -2010 Y(KNTM1,I)=YT(I) - - - -55 IF(ID.EQ.0) GO TO 40 - - 35 CONTINUE - - IF(NI .EQ. 0) GO TO 83 - - DO I=1,NI - R(I)=RS(KNS-1,I) - END DO - -C AS OF idm3x13.f: MUST CALL GETFA BEFORE EVERY TIME THAT -C FA(.) ARE USED IN CASE THE EQUATION(S) FOR THE FA(.) ARE BASED -C ON THE COVARIATES, WHICH CAN CHANGE DOSE TO DOSE. - - CALL GETFA(FA) - - -83 IF(NDRUG .EQ. 0 .OR. N .EQ. 0) GO TO 82 - -C ADDING N .EQ. 0 TO ABOVE IF STATEMENT SHOWS CLEARLY THAT IF -C N = 0 (IN WHICH CASE ANALYTIC SOLUTIONS ARE CODED DIRECTLY INTO -C SUBROUTINE OUTPUT, WHICH MAKES THE COMPARTMENT AMOUNTS IRRELEVANT) -C SETTING VALUES FOR THE COMPARTMENTS, X, IS UNNECESSARY. - - -C IF ISKIPBOL = 1, DO NOT APPLY BOLUSES FROM DOSE KNS-1, SINCE THESE -C BOLUSES WERE PART OF THE STEADY STATE DOSE SET WHICH ALREADY HAD -C BOLUSES (EFFECTIVELY) APPLIED ABOVE WHERE "CONVERGENCE" OF THE -C STEADY STATE DOSE SET WAS OBTAINED. - - IF(ISKIPBOL .EQ. 0) THEN - DO I=1,NDRUG - X(NBCOMP(I))=X(NBCOMP(I))+BS(KNS-1,I)*FA(I) - END DO - ENDIF - - - -C RESET ISKIPBOL = 0 HERE. IF IT IS NOW = 1, IT MEANS THAT -C THE ABOVE APPLICATION OF BOLUSES WAS SKIPPED SINCE THERE HAS JUST -C BEEN A STEADY STATE SET OF DOSES WHICH CONVERGED (AND WE DON'T -C WANT THE LAST BOLUS DOSE REAPPLIED). BUT, GOING FORWARD, ISKIPBOL -C SHOULD BE SET AGAIN TO 0 SO THE ABOVE APPLICATION OF BOLUSES WILL -C OCCUR WHENEVER THERE IS A NEW BOLUS TO BE APPLIED. - - ISKIPBOL = 0 - - -82 CONTINUE - -C CHECK STOPPING TIME. - -40 IF(KNT .LE. NUMT) GO TO 45 - -C*****DETERMINE YYPRED(I)***** - - DO J=1,NOS - DO I=1,NUMT - YYPRED(I,J)=Y(I,J) - END DO - END DO - - -C AS OF idm3x9.f, RESTORE THE VALUES FOR ND, SIG, AND RS, IN CASE -C THIS MODEL HAS TIME LAGS OR STEADY STATE DOSES - TO BE READY FOR THE -C NEXT CALL TO THIS ROUTINE. - - - ND = NDO - DO I=1,ND - SIG(I) = SIGO(I) - DO J=1,NI - RS(I,J) = RSO(I,J) - END DO - END DO - -C ESTABLISH THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE EVAL3(NUMT,YYPRED,TPRED,NUMEQT) - -C THIS SUBROUTINE, CALLED BY IDCALCYY/MAIN, FINDS THE OUTPUT CONC. -C ARRAY, YYPRED, EVALUATED AT PARAMETER VALUES IN VECTOR P, PASSED -C DIRECTLY TO SUBROUTINE FUNC3 VIA COMMON/PARAMD ... AT THE NUMT -C TIMES IN TPRED. - - IMPLICIT REAL*8(A-H,O-Z) - COMMON /SUM2/ M,NPNL - COMMON/CNST2/ NPL,NOS,NDRUG,NADD - DIMENSION YYPRED(72000,NUMEQT),TPRED(72000) - - CALL FUNC3(NUMT,YYPRED,TPRED,NUMEQT) - - RETURN - END - - -C NPAGFULLA.FOR 6/30/14 - -C NPAGFULLA HAS THE FOLLOWING CHANGES TO NPAGFULL: - -C 1. JUST AFTER THE REWIND(27) STATEMENT, SUBROUTINE NEWWORK1 IS -C CALLED TO READ THE PATIENT DATA FROM FILE 27, AND CONVERT IT TO -C PATIENT DATA ON FILE 37, WITH EACH STEADY STATE DOSE INDICATOR -C RESULTING IN AN EXTRA 100 DOSE SETS (WITH THE NEGATIVE DOSE TIME -C LEFT IN - SEE COMMENTS BELOW). NOTE THAT THIS SUBROUTINE NEWWORK1 -C IS THE SAME AS IN THE CURRENT NPAG "ENGINE" MODULE, npageng25.f, -C EXCEPT IT READS FILE 27 AND WRITES TO FILE 37, RATHER THAN READING -C FROM FILE 23 AND WRITING TO FILE 27; ARRAY TIMOBREL IS NOT -C ESTABLISHED IN NEWWORK1, AND NOT PASSED AS AN ARGUMENT (IT IS NOT -C NEEDED IN THIS PROGRAM); MAXSUB IS ALSO NOT PASSED AS AN -C ARGUMENT (IT IS NOT NEEDED); NSUB IS NOT PASSED AS AN ARGUMENT (IT -C IS NOT NEEDED); AND COMMON/DOSEOBS AND THE ARRAYS IN IT ARE DELETED -C (THEY ARE NOT NEEDED). - -C NOTE THAT THIS NEWWORK1 ROUTINE IS INCLUDED IN THIS MODULE, AS IS -C SUBROUTINE ORDERDELTA. - -C 2. SUBROUTINE FILREAD IS CHANGED TO READ FILE 37, RATHER THAN -C FILE 27. NOTE THAT FILE 37 IS CLOSED JUST BEFORE THE RETURN STATEMENT -C IN THE MAIN OF THIS MODULE. - -C 3. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN -C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx -C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING -C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT -C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT -C USING COMMON/ERR/ERRFIL. - -C 4. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, -C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET -C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED -C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT -C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS -C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL -C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 -C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO -C MAXNUMEQ. - -C 5. COMMON/OBSER IN MAIN IS REMOVED. IT WASN'T NEEDED. SIMILARLY -C ALL THE ARRAYS IN THIS COMMON ARE NO LONGER DIMENSIONED. - - - -C----------------------------------------------------------------------- - -C NPAGFULL.FOR 3/26/13 - -C NPAGFULL IS BASED ON THE npageng22.f PROGRAM. IT RUNS AN NPAG -C ANALYSIS IN ORDER TO OBTAIN THE FULL POSTERIOR DENSITY OF A SUBJECT -C GIVEN AN APRIORI DENSITY. ALL OTHER CODE IN npageng22.f IS -C REMOVED (E.G., ALL EXTRA CALCULATIONS, ALL WRITING TO FILES, ETC.). - -C NOTE THAT ALL INFO NEEDED BY THIS ROUTINE IS INCLUDED IN THE -C CALLING ARGUMENTS; IN PARTICULAR, npag102.inp IS NOT READ. - -C THIS COMPARES TO NPAGBAY, WHICH CALCULATED THE 0-CYCLE BAYESIAN -C POSTERIOR OF THE SUBJECT. - -C NOTE ALSO THAT ALL DIMENSIONS OF 500 RELATED TO DOSE EVENTS HAVE BEEN -C CHANGE TO 5000. - -C----------------------------------------------------------------------- - -c npageng22.f 11/8/12 - -c npageng22 has the following change from npageng21: - -c 1. It comments out the PAUSE statement following Format 164 in -c Subroutine emint. Reason: the program will not complete properly if -c it is run under Pmetrics (which cannot supply a keyboard response -c during a run). - -c 2. Formats 1657 and 7124 are changed to show that the output file -c is made by npageng22 rather than npageng21. - -c----------------------------------------------------------------------- - -c See npageng22.f code for all the comments from npageng21.f back -c to m2_5calf.f. - - -C----------------------------------------------------------------------- - -C*********************************************************************** - - SUBROUTINE NPAGFULL(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK, - 1 CORDEN,NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM0, - 2 NGRID,NACTVE,PYJGX,DENSTOR,CORDLAST,MAXCYC) - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - DIMENSION WORK(MAXGRD),WORKK(MAXGRD),PYJGX(MAXSUB,MAXGRD), - 1 DENSTOR(MAXGRD,4),CORDEN(MAXGRD,MAXDIM+1), - 2 CORDLAST(MAXGRD,MAXDIM+1), YO(594,MAXNUMEQ),SIG(594,MAXNUMEQ), - 3 AB(30,2),X(30),VALFIX(20),IRAN(32),PX(32),ATOL(20), - 4 C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ),C3(MAXNUMEQ),ATOLL(20) - -C NOTE THAT ALL DIMENSIONS = 150 HAVE BEEN CHANGED TO 594, SINCE THIS -C NO. REPRESENTS THE TOTAL NO. OF OBSERVATIONS (AND THE MAX. NO IS -C MAXNUMEQ OUTPUT EQUATIONS x 99 OBSERVATIONS/EQ). THIS COULD BE CHANGED -C TO NUMEQT*MAXOBS, BUT IT WOULD BE MORE TROUBLE THAN IT'S WORTH TO -C MAKE THESE DIMENSIONS VARIABLE. - - CHARACTER ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - COMMON SIG - COMMON/TOUSER/NDIMM,MFF,RTOLL,ATOLL - COMMON/NXER/NXE -C NXE FROM ABOVE COMMON IS NO. OF TIMES XERRWD IS CALLED. - -C THE BLANK COMMON ABOVE IS SUPPLIED TO SUBROUTINE IDPC. -C COMMON/TOUSER IS SUPPLIED TO SUBROUTINE USERANAL IN idfixed.f. -C COMMON/OBSER/ IS SUPPLIED FROM SUBROUTINE FILREAD. -C NO! AS OF NPAGFULLA.FOR, COMMON/OBSER IS REMOVED FROM MAIN. IT IS -C UNNEEDED. SIMILARLY, TIMOB, DOSTIM, RS, Y00, AND BS ARE NO LONGER -C DIMENSIONED IN MAIN. - - - -C*********************************************************************** - -C----------------------------------------------------------------------- - - 2 FORMAT(A20) - 222 FORMAT(A3) - 2222 FORMAT(A5) - -C----------------------------------------------------------------------- - - NSUB = 1 - - NDIMM = NDIM - MFF = MF - RTOLL = RTOL - DO I = 1,NDIM - ATOLL(I) = ATOL(I) - END DO - -C THE ABOVE VALUES HAD TO BE ESTABLISHED SINCE THE SAME VARIABLES -C CANNOT BE IN COMMON STATEMENTS IF THEY ARE DUMMY CALLING ARGUMENTS. - - - - -C NOTE THAT THIS SUBROUTINE WAS CALLED BY BESTDOSxxx.FOR/MAIN, WHICH -C HAS ALREADY WRITTEN TO SCRATCH FILE 27 THE DATA FROM THE SINGLE -C SUBJECT WHOSE POSTERIOR DENSTIY IS TO BE CALCULATED, BASED ON THE -C PRIOR DENSITY INPUT PASSED TO THIS ROUTINE IN CORDEN. - - -c As of npageng14.f, tol is hardcoded to be 1.D-4. Previously, it -c was allowed to be any positive number .GE. 1.D-4. - - tol = 1.D-4 - - -C ESTABLISH ASSAY VALUES FROM ierrmod AND gamlam0. - - - gamma = 1.d0 - flat = 1.d0 - if(ierrmod .eq. 2) gamma = gamlam0 - if(ierrmod .eq. 3) gamma = gamlam0 - if(ierrmod .eq. 4) flat = gamlam0 - - igamma = 0 - gamdel=0.1 - if(ierrmod.eq.1) gamdel=0.d0 - - -C CHANGE NGRID TO BE MAXGRD, IF IT IS > MAXGRD. - -C???DEBUG 3/23. NGRID IS NOT A DIMENSION --> IT IS NEEDED TO BE -C WHATEVER IT IS FROM THE NPAGDENFILE INPUT INTO THE BESTDOS MAIN -C MODULE. SO DON'T LIMIT IT TO BE .LE. MAXGRD. - -C if(ngrid .gt. MAXGRD) then - -C write(6,*) - -C write(6,*) 'requested NGRID = ',NGRID -C write(6,*) 'maximum allowable is MAXGRD = ',MAXGRD -C write(6,*) 'resetting NGRID = ',MAXGRD -C write(6,*) 'to fit in available storage' -C write(6,*) - -C ngrid = MAXGRD - -C endif - - - -C CALCULATE VOLSPA, THE 'VOLUME' OF THE INTEGRATION SPACE (NEEDED IN -C CALLS TO NOTINT). - - VOLSPA=1.D0 - DO 170 I=1,NVAR - 170 VOLSPA = VOLSPA*(AB(I,2)-AB(I,1)) - - -C NOTE IN THIS PROGRAM, THE USER WILL ALWAYS INPUT A PRIOR DENSITY -C WITH VALUES IN CORDEN, SO THE ICYCLE = 0 CODE HAS BEEN REMOVED. - - -C AS OF npageng19.f, PRESET NACTLAST TO BE NACTVE. THIS WAY, IN THE -C UNLIKELY EVENT THAT THE FIRST CYCLE OF A RUN HAS A HESSIAN ERROR -C (WHICH MEANS THAT WHEN CONTROL COMES BACK TO MAIN FROM SUBROUTINE -C emint, IT IS TRANSFERRED TO LABEL 900 AND THEREFORE SKIPS THE -C cbegin statistics SECTION WHERE NACTLAST = NACTVE IS SET), THERE -C WON'T BE A PROBLEM WHEN NACTVE IS SET = NACTLAST JUST BELOW LABEL -C 900. IN PREVIOUS PROGRAMS, IN THE ABOVE SITUATION, BELOW LABEL 900, -C NACTVE = NACTLAST WOULD RESULT IN NACTVE BEING SET = 0 SINCE -C NACTLAST WAS UNITIALIZED. - - - NACTLAST = NACTVE - - - prefobj=-1.d30 - prebig=-1.d30 - - -C SET ICYCLE = 0. THE PROGRAM WILL RUN UP TO MAXCYC CYCLES. - - ICYCLE = 0 - -C CORDEN HOLDS, IN ITS FIRST NACTVE ROWS, THE STARTING JOINT DENSITY -C AND COORDINATE VALUES. FOR K=1,NACTVE, CORDEN(K,J) = JTH COORDINATE -C OF THE KTH ACTIVE POINT, J=1,NVAR; AND CORDEN(K,NVAR+1) IS THE -C ASSOCIATED DENSITY FOR THE KTH ACTIVE POINT. - -C IF ICYCLE .GT. 0, CORDEN WAS READ IN. -C IF ICYCLE = 0, NACTVE=NGRID, AND CORDEN WAS FILLED AT LABEL 30 ABOVE. -C IN THIS CASE, THE DENSITY IS UNIFORM, SO ALL -C CORDEN(K,NVAR+1) VALUES = 1/VOLSPA, K=1,NACTVE. - - -C IPRED=11 + ICYCLE -C JCOL=0 - ITEST=0 - -C IPRED IS THE CYCLE NO. WHERE THE NEXT 2-CYCLE PREDICTION -C ALGORITHM STARTS (IT IS NO LONGER USED). JCOL = COLUMN NO. OF DENSTOR -C IN WHICH IS STORED THE DENSITY OF ONE OF THE 2-CYCLES USED IN THE -C PREDICTION (IT IS NO LONGER USED). IT IS SET = 0 ABOVE, SINCE NO -C STORAGE IS REQUIRED UNTIL CYCLE NO. 11 - - -C (SEE BELOW). ITEST=0 --> THE NEXT CYCLE IS NOT (INITIALIZED) TO BE -C A TEST CYCLE (SEE CODE BELOW WHEN ITEST=1,2, OR 3). - -C NEW FOR m2_13cal.f: NSTORE SET = 0. NSTORE IS THE NO. OF GRID -C POINTS, WHOSE P(YJ|X) VALUES HAVE BEEN STORED IN PYJGX IN LOOP 800. -C THIS NO. CAN BE CHANGED BY THE 'CONDENSING' CODE BELOW, SINCE -C INACTIVE POINTS ARE THROWN OUT. - - NSTORE=0 -cadapt initialize grid resoution to 20% - resolve=0.20 - - - 1001 ICYCLE=ICYCLE+1 - - -cgam3 -10001 continue - -c above is new entry point for gammaplus/minus eps tries - itest = 0 - - -cadapt reset number of stored points to that before expansion -c nstore=nstoresv - - -C 1239 FORMAT(///' CYCLE NO.',I5,/) - -C ICYCLE IS THE NUMBER OF THE NEXT CYCLE TO BE RUN. -C -C THIS IS WHERE EACH NEW CYCLE STARTS (FOR EACH CYCLE, THE DENSITY OF -C X IS UPDATED FROM THE PREVIOUS DENSITY ESTIMATE, USING THE -C OBSERVED SUBJECT DATA FROM THE INPUT DATA FILES WHICH ARE PASSED TO -C SUBROUTINE IDPC BELOW. -C - - -C START THE SUBJECT LOOP. - - - -C REWIND SCRATCH FILE 27 WHICH HAS ALL THE SUBJECT DATA FILES -C CONCATENATED ON IT, IN ORDER. ACTUALLY THERE IS ONLY NSUB = 1 -C SUBJECT IN THIS RUN. - - - - REWIND(27) - -C PUT THE SUBJECT'S DATA ONTO FILE 37 BY CALLING SUBROUTINE NEWWORK1 -C (SIMILAR ROUTINE TO THE ONE IN npageng25.f, EXCEPT IT READS FILE 27 -C AND WRITES TO FILE 37, RATHER THAN READING FROM FILE 23 AND WRITING -C TO FILE 27). NOTE THAT IT HAS NO ARGUMENTS; NONE ARE NEEDED IN THIS -C PROGRAM. - -C NOTE THAT IF THE SUBJECT FILE HAS NO STEADY STATE DOSE INDICATORS, IT -C WILL NOT BE CHANGED; IF IT DOES, IT WILL BE ALTERED TO INCLUDE AN -C EXTRA 100 DOSES SETS FOR EACH STEADY STATE DOSE INDICATOR. NOTE THAT -C SUBROUTINE NEWWORK1 WILL LEAVE IN THE NEGATIVE DOSE TIME (WHICH IS -C THE STEADY STATE DOSE INDICATOR) BECAUSE THE ID ROUTINES NEED TO SEE -C THIS INDICATOR TO KNOW THAT A STEADY STATE DOSE SET IS COMING. - - OPEN(37) - - - CALL NEWWORK1 - REWIND(37) - - - -C NOBTOT WILL BE THE RUNNING TOTAL OF ALL NON-MISSING OBSERVED VALUES -C OVER ALL THE NSUB SUBJECTS. THIS IS NEEDED TO CALCULATE BIC BELOW. - - NOBTOT = 0 - - - DO 1000 JSUB=1,NSUB - - - -C CALL SUBROUTINE FILREAD TO READ, FOR THIS SUBJECT, FROM SCRATCH FILE -C 37, THE NO. OF OBSERVATION TIMES (NOBSER) AS WELL AS THE -C OBSERVED VALUES THEMSELVES: YO(I,J) = THE 'NOISY' OBSERVED VALUES -C FOR THIS SUBJECT; I=1,NOBSER, J=1,NUMEQT. THESE OBSERVED VALUES ARE -C USED ONLY TO CALCULATE THE ASSAY STANDARD DEVIATIONS (USING THE -C VECTORS, C0,C1,C2,C3, WHICH ARE ALSO READ IN). THE REST OF THE INFO -C IN THE SUBJECT DATA FILE IS PASSED IN COMMONS TO THE IDPC MODULE -C SUBROUTINES. - - CALL FILREAD(NOBSER,YO,C0,C1,C2,C3) - -C FIND THE ASSAY STANDARD DEVIATIONS FOR THIS SUBJECT. FOR EACH -C OF THE NOBSER*NUMEQT OBSERVED VALUES (EXCEPT THAT YO(I,J) = -99 --> -C OUTPUT EQ. J HAS NO OBSERVED LEVEL FOR OBSERVATION TIME I), -C Y, SIG = C0 + C1*Y + C2*Y**2 + C3*Y**3. -C NOTE THAT, THEORETICALLY, SIG SHOULD BE A CUBIC FNT. OF -C THE 'TRUE' OBSERVED VALUES, NOT THE 'NOISY' OBSERVED VALUES (BUT THE -C 'TRUE' VALUES ARE UNKNOWN). - -C ALSO, CALCULATE SIGFAC, THE PRODUCT OF THE NON-MISSING STD. DEV.'S -C (A NON-MISSING S.D. IS ONE FOR WHICH THE CORRESPONDING YO(I,J) IS -C .NE. -99, THE MISSING VALUE CODE). -C INITIALIZE SIGFAC=1, AND THEN UPDATE IT FOR EACH NON-MISSING -C OBSERVATION. - -C MISVAL WILL BE THE RUNNING TOTAL OF MISSING VALUES AMONG ALL THE -C NUMEQT x NOBSER POTENTIAL OBSERVED LEVELS. - - MISVAL = 0 - - SIGFAC=1.D0 - - DO 140 I=1,NOBSER - DO 140 J=1,NUMEQT - - Y = YO(I,J) - -C IF Y = -99, IT MEANS THAT OUTPUT EQ. J HAD NO VALUE AT OBSERVATION -C TIME I. IN THIS CASE, IGNORE THIS Y AND INCREASE MISVAL BY 1. - - - IF(Y .EQ. -99) THEN - MISVAL = MISVAL+1 - GO TO 140 - ENDIF - -C NOTE: FOR EACH SUBJECT, MUST ENSURE THAT ALL THE STD DEV'S ARE NON- -C ZERO. OTHERWISE, THE PROGRAM WILL BLOW UP! THIS IS BECAUSE -C P(YJ|X) INVOLVES SQUARED DIFFERNCES BETWEEN OBSERVED Y'S AND -C EXPECTED Y'S (FOR EACH X GRID POINT)...EACH DIFFERENCE -C NORMALIZED (I.E., DIVIDED) BY THE VARIANCE OF THE RESPECTED -C OBSERSATION. - -C SEE M2_17CAL.F CODE FOR COMMENTS ON HOW A STD. DEV. COULD = 0. - -C ALSO TEST TO MAKE SURE NO STD. DEV. < 0, SINCE SIGFAC BEING NEGATIVE -C WOULD RESULT IN A NEGATIVE PROBABILITY (SEE PYJGX CALCULATION BELOW). - - SIG(I,J) = C0(J)+C1(J)*Y+C2(J)*Y*Y+C3(J)*Y**3 -cgam4 - if(ierrmod.eq.2) sig(i,j) = sig(i,j)*gamma - if(ierrmod.eq.3) sig(i,j)=dsqrt(sig(i,j)**2 + gamma**2) - if(ierrmod.eq.4) sig(i,j) = gamma*flat - - IF(SIG(I,J) .EQ. 0) THEN - - - - WRITE(*,2345) JSUB -2345 FORMAT(//' A S.D. IS 0 FOR JSUB = ',I5,'. RERUN THE '/ - 1' PROGRAM WITH C0 NOT = 0 FOR THIS SUBJECT, OR WITH THIS'/ - 2' SUBJECT ELIMINATED.'// - 3' THIS IS IN SUBROUTINE NPAGFULL.'/) - CLOSE(37) - - OPEN(47,FILE=ERRFIL) - WRITE(47,2345) JSUB - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - IF(SIG(I,J) .LT. 0) THEN - - - - WRITE(*,2346) JSUB -2346 FORMAT(//' A S.D. < 0 FOR JSUB = ',I5,'. RERUN THE '/ - 1' PROGRAM WITH A BETTER CHOICE FOR THE ASSAY ERROR POLYNOMIAL'/ - 2' COEFFICIENTS.'// - 3' THIS IS IN SUBROUTINE NPAGFULL.'/) - CLOSE(37) - - OPEN(47,FILE=ERRFIL) - WRITE(47,2346) JSUB - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - SIGFAC=SIGFAC*SIG(I,J) - - 140 CONTINUE - -C NOTE THAT SIGFAC WAS CALCULATED IN LOOP 140 ABOVE, AND THAT OFAC IS -C NOW THE RESULT OF (NOBSER*NUMEQT - MISVAL) VALUES. - - OFAC=2.506628274631**(NOBSER*NUMEQT - MISVAL) - NOBTOT = NOBTOT + NOBSER*NUMEQT - MISVAL - - -C NOTE THAT 2.5066... = SQRT(2*PI). - -C FOR EACH SUBJECT, AND EACH GRID POINT, CALL IDPC, A SUBROUTINIZED -C VERSION OF THE ADAPT PROGRAM ID3 TO CALCULATE THE SUM OF SQUARES OF -C DIFFERENCES BETWEEN THE OBSERVED VALUES AND PREDICTED (BY THE MODEL) -C VALUES (NORMALIZED BY THE ASSAY VARIANCE OF EACH OBSERVATION) ... - - 8888 FORMAT(' ',' CYCLE ',I5,', SUBJECT ',I5,' ... % COMPLETED = ', - 1F8.2) - XNEXT = 1.D0 - -C SEVERAL CHANGES FOR m2_13cal.f ARE IN LOOP 800. - - DO 800 IG=1,NACTVE - - -C PRINT TO THE SCREEN THE UPDATE ON WHAT % OF GRID POINTS HAVE BEEN -C CALCULATED IF NACTVE > NSTORE (I.E., IF NACTVE .LE. NSTORE --> -C ALL P(YJ|X)'s ARE ALREADY STORED INTO PYJGX AND SO THIS 8OO LOOP -C WILL GO VERY FAST. - - IF(NACTVE .GT. NSTORE) THEN - -C PRINT GRID PT. AND % COMPLETED TO SCREEN. - XPER=IG*100.D0/NACTVE - - IF(XPER .GE. XNEXT) THEN - - IF(ICYCLE.eq.1) THEN - WRITE(*,8888) ICYCLE,JSUB,XPER - IF(NXE .GT. 0) WRITE(*,1254) NXE - 1254 FORMAT(' TOTAL NO. OF NUM. INTEG. WARNINGS IS ',I20) - ENDIF - - XNEXT=XNEXT+1.D0 - - ENDIF - - ENDIF - - IF(IG .LE. NSTORE) GO TO 700 - - -C ESTABLISH THE IGTH GRID POINT. IT IS STORED IN ROW IG OF -C CORDEN. - - DO J=1,NVAR - X(J)=CORDEN(IG,J) - END DO - -C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO -C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL -C MAKEVEC TO DO THIS. - - - CALL MAKEVEC(NVAR,NOFIX,IRAN,X,VALFIX,PX) - - CALL IDPC(PX,W) - -C W RETURNS AS THE SUM OF: -C ((YO(I,J)-H(I,J))/SIG(I,J))**2, WHERE H(I,J) = PREDICTED VALUE OF THE -C JTH OUTPUT EQ AT THE ITH OBSERVATION TIME, ASSUMING THE IGTH GRID -C POINT, X, ... OVER THE NOBSER x NUMEQT QUANTITIES ABOVE WHICH DON'T -C HAVE YO(I,J) = -99 (WHICH MEANS THAT OUTPUT EQ. J HAS NO OBSERVED -C LEVEL FOR TIME I). - -C CALCULATE P(YJ|X) FOR X-GRID POINT NO. IG. - -C THIS NEXT TEST IS FOR THE PC. AS AN EXAMPLE, THE COMPAC COMPUTER -C CANNOT HANDLE ARGUMENTS TO DEXP WHICH ARE SMALLER THAN -11354. SINCE -C THE ARGUMENT TO DEXP BELOW IS -.5*W, SET PYJGX = 0 IF W IS .GT. -C 22708. - -C SEE CODE AFTER CALCULATION OF P(YJ) TO SEE WHAT HAPPENS IF ALL THE -C P(YJ|X) ARE SET = 0. - -C NOTE THAT WORKK WILL ALWAYS BE SET = P(YJ|X=IG GRID PT), WHICH IS -C NEEDED IN THE CALCULATION OF DXI (NOTE DXI NOT USED AS OF -C bignpaglap1.f) SINCE PYJGX WILL NOT BE COMPLETE IF NACTVE > MAXGRD. - - IF(IG .LE. MAXGRD) PYJGX(JSUB,IG)=0.D0 - WORKK(IG) = 0.D0 - - IF(W .LE. 22708.D0) THEN - IF(IG .LE. MAXGRD) PYJGX(JSUB,IG) = DEXP(-.5D0*W)/SIGFAC/OFAC - WORKK(IG) = DEXP(-.5D0*W)/SIGFAC/OFAC - ENDIF - -C CALCULATE P(X,YJ) FOR X-GRID POINT NO. IG. PUT IT INTO WORK(IG). - - IF(IG .GT. MAXGRD) THEN - WORK(IG) = WORKK(IG)*CORDEN(IG,NVAR+1) - GO TO 800 - ENDIF - - 700 WORK(IG)=PYJGX(JSUB,IG)*CORDEN(IG,NVAR+1) - - WORKK(IG) = PYJGX(JSUB,IG) - - 800 CONTINUE - - -C CALCULATE P(YJ), A SCALAR WHICH IS THE INTEGRAL OF P(X,YJ) OVER - -C X-SPACE. - -C CALL NOTINT, AN INTEGRATION ROUTINE. THE -C FOLLOWING IS SUPPLIED TO THIS ROUTINE: -C VOLSPA = VOLUMNE OF THE INTEGRATION SPACE. -C NGRID = NO. OF ORIGINAL GRID POINTS. -C NACTVE = NO. OF ACTIVE GRID POINTS. -C WORK(I), I=1,NACTVE = VALUE OF THE FUNCTION TO BE INTEGRATED, AT -C THE ITH GRID POINT. -C MAXGRD = THE DIMENSION OF WORK. - - CALL NOTINT(VOLSPA,NGRID,NACTVE,WORK,MAXGRD,PYJ) - - -C IF PYJ RETURNS AS 0, IT IS BECAUSE P(X,YJ)=WORK IS 0 IN ALL ITS -C NACTVE ENTRIES. THIS OCCURS WHEN EACH OF NACTVE VALUES OF W (WHICH -C RETURNS FROM THE CALLS TO IDPC) IS LARGER THAN 1416 (SINCE P(YJ|X) -C INVOLVES e RAISED TO THE POWER -.5*W, AND e RAISED TO A POWER -C SMALLER THAN -708 IS SET TO 0 BY, FOR EXAMPLE, THE COMPAC COMPUTER). -C - -C IN CASE THIS HAPPENS, PRINT A MESSAGE TO THE USER AND STOP. -C - IF (PYJ .EQ. 0.D0) THEN - - - - WRITE(*,26) - 26 FORMAT(//' FOR THIS SUBJECT, THE PROB. OF THE OBSERVED'/ - 1' CONCENTRATIONS (FOR THE INDICATED DOSAGE REGIMEN), GIVEN EACH '/ - 2' AND EVERY GRID POINT IN THE ESTABLISHED GRID, IS 0. THE '/ - 3' PROGRAM STOPS. THE USER SHOULD CONSIDER INCREASING THE'/ - 4' NO. OF GRID POINTS ALLOWED (HARDCODED INTO MAIN), AND/OR '/ - 5' NARROWING THE GRID BOUNDARIES OF THE VARIABLES, AND/OR '/ - 6' INCREASING THE SIZES OF (C0,C1,C2,C3), THE ASSAY NOISE '/ - 7' COEFFICIENTS. ALL OF THESE CHANGES WILL HAVE THE EFFECT OF'/ - 8' MAKING SOME OF THE ABOVE CONDITIONAL PROBABILITES LARGER.'// - 9' THIS IS IN SUBROUTINE NPAGFUL.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,26) - CLOSE(47) - - - - CALL PAUSE - STOP - - - - ENDIF - - 1000 CONTINUE - - -c begin optimization -cgam5 -cgam5 - from here (immediately after 1000 CONTINUE to -cgam5 - immediately before c end optimization was lifted -cgam5 - from gamadapt1.f, replacing old material beteen these limits - igamma = igamma + 1 - if(ierrmod.eq.1) igamma=1 -csdsc - added April 2, 2000 -c con first iteration, call hte interior point method - - if(mod(igamma,3).eq.1) then - - gammab = gamma - gammap = gamma * (1.d0+gamdel) - gammam = gamma / (1.d0+gamdel) - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,1, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - - nactve = keep - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. - -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - - - fobjbase = fobj - - - nactve0 = nactve -c new on Jan 2, 2002 - save otpimal solution in denstor(1,4) -c so that stat program can work on best of base, up, and down -c solutions - do i=1,nactve - denstor(i,4)=corden(i,nvar+1) - enddo - nstore = 0 - fobjbest = fobjbase - - if(ierrmod.eq.1) go to 14001 - gamma = gammap - go to 10001 - - endif -cgamma above endif is for mod(igamma,3).eq.1 case - - if(mod(igamma,3).eq.2) then - - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - fobjplus = fobj - -c new Jan 2, 2002 - save solution if fobjplus is better than fobjbase - if(fobjplus.gt.fobjbest) then - fobjbest = fobjplus - do i=1,nactve - - denstor(i,4) = corden(i,nvar+1) - enddo - endif - gamma = gammam - - go to 10001 - - endif - - if(mod(igamma,3).eq.0) then - - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. - -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - - fobjminu = fobj - - if(fobjminu.gt.fobjbest) then - fobjbest = fobjminu - do i=1,nactve - denstor(i,4) = corden(i,nvar+1) - enddo - endif - - endif - -cgamma - above statement changed from "nstore = nactve" to force -c reevaluation of all points. - -c now temporairily reset to gamma - gamma = gammab - fobj = fobjbase - if(fobjplus.gt.fobjbase) then - gamma = gammap - - fobj = fobjplus - gamdel = 4.*gamdel - endif - - if(fobjminu.gt.fobjbase) then - gamma = gammam - fobj = fobjminu - gamdel = 4.*gamdel - endif - gamdel = gamdel*0.5 - if(gamdel.lt.0.01) gamdel=0.01 -14001 continue -cgam5 above label is entry point for ierrmod = 1 (no gamma) case - -c corden(*,nvar+1) sums to 1 when it comes out of emint -c Now reset forden(i,nvar+1) to best of three solutions -c and normalize to funny BIGNPEM factor - fact=ngrid/volspa - do i=1,nactve - corden(i,nvar+1)=fact*denstor(i,4) - enddo - - -cend optimization - - -cbegin statistics - - -c now we compute all hte statistical stuff using this distribution -c and the full nactve (before condensation) points. -c Later, in the condensation performed just before the grid refienment -c and subsequent expansion, we will condense by just using the -c 'keep' flags in DENSTOR(i,1) that emint left there. The density will -c not be updated to refelct this cahnge (there is no need) -c until the next call to emint - - -c As of npageng18.f, save CORDEN to CORDLAST AND NACTVE TO NACTLAST. -c The reason is that if, somewhere during the next cycle's calculations -c (during one of the calls to Subroutine emint), a Hessian Matrix is -c singular, then IHESS will be set = -1, and the program will stop. -c And in this case, the program must be able to write out all of the -c information from this cycle (the last completed cycle). And that -c means that the CORDEN from this cycle (which will be stored into -c CORDLAST), and NACTVE (store into NACTLAST) should be used in the -c call to Subroutine SUBRES in loop 7000. Otherwise, the CORDEN and -c NACTVE used in that call would have already partly updated in the -c next cycle before the Hessian error occurred. - - DO I = 1,NACTVE - DO J = 1,NVAR+1 - CORDLAST(I,J) = CORDEN(I,J) - END DO - END DO - - NACTLAST = NACTVE - - - IF(MAXCYC .EQ. 0) GO TO 900 - -C Starting with bigmlt1.f, this is a jump point. - - -cend statistics -cbegin control -c we are now done wtih statistics - this is the best place to -c check for whether we can exit - if so , last printed statistic -c will agree with current density corden, and corden is still -c correct (e.g. after condensation-expansion, it is no longer -c correct until we call emint again) -cint.9 control section to check for exit criteria, resolution -c refinement, and end of major cycles - -cint9.a first, we exit if we have reached maxcyc on cycle counter - -C SET IMAXCYC = 0; IF IT CHANGES TO 1, IT MEANS THAT MAXCYC CYCLES -C HAVE BEEN RUN, AND THE PROGRAM WILL STOP. - - IMAXCYC = 0 - - if(icycle .ge. maxcyc) then - - - -C SET IMAXCYC = 1 --> MAXCYC WAS REACHED. - - IMAXCYC = 1 - -C COMMENT OUT THE GO TO 900 STATEMENT BELOW SINCE EVEN IF ICYCLE -C = MAXCYC, THE PROGRAM STILL NEEDS TO TEST TO SEE IF CONVERGENCE -C WAS ACHIEVED IN THE FINAL CYCLE. -C go to 900 - - endif - -c The above endif is for the if(icycle .ge. maxcyc) condition. - - -cint9.b second, we check improvement from last cycle - - ximprove=fobj-prefobj - prefobj = fobj - -cint9.c if ximprove is too low, refine the resolve criterion - - if(dabs(ximprove) .le. tol .and. resolve .gt. 0.0001) then - resolve=resolve*0.5 - endif - -cint9.d check to see if resolve bottoms out - if so, start a new -c major cycle by resetting it to its highest allowable value, or -c exit if the improvment from the last major cycle is too small ... - -C AND EXIT IF IMAXCYC = 1 (SEE ABOVE; THIS MEANS THAT THE MAX. NO. -C OF CYCLES HAS ALREADY BEEN RUN AND THE ONLY REASON THIS PART OF THE -C CODE IS BEING RUN IS TO SEE IF CONVERGENCE WAS ACHIEVED IN THE FINAL -C CYCLE. - - if(resolve.le.0.0001) then - - -c saveres = resolve - resolve=0.2 - checkbig = fobj - prebig - prebig =fobj - -C NOTE THAT THE -C CONVERGENCE CRITERION IS THAT DABS(CHECKBIG) .LE. .01. - - -C WRITE(*,1023) ICYCLE -C1023 FORMAT(/' FOR CYCLE NO, ',I6,' THE CONVERGENCE CRITERION AND ME -C 1DIANS ARE: ') - -C WRITE(*,1024) DABS(checkbig) - -C1024 FORMAT(1X,G14.4,' <-- CONVERGENCE OCCURS WHEN THIS NO. < .01') - - - if(dabs(checkbig) .le. 0.01) then - -C CONVERGENCE HAS BEEN ACHIEVED. - - go to 900 - - endif - - endif - -c above endif is for the if(resolve .le. .0001) condition. - - -C IF IMAXCYC = 1, THE MAX. NO. OF CYCLES HAVE ALREADY BEEN RUN --> -C GO TO 900. THE ONLY REASON THIS PART OF THE CODE WAS BEING RUN IS TO -C SEE IF CONVERGENCE WAS ACHIEVED IN THIS FINAL CYCLE, AND THAT WAS -C JUST TESTED ABOVE. - - IF(IMAXCYC .EQ. 1) GO TO 900 - - -cend control -cbegin expansion - - nactveold=nactve - - do ipoint=1,nactveold -c first, divide current probability into 2*nvar+1 pieces - pcur=corden(ipoint,nvar+1)/(2*nvar+1) -c update original point - corden(ipoint,nvar+1)=pcur - do ivar=1,nvar - del=(ab(ivar,2)-ab(ivar,1))*resolve -c create first new trial point at -eps in coordinate ivar - do i=1,nvar - corden(nactve+1,i)=corden(ipoint,i) - enddo - corden(nactve+1,ivar)=corden(nactve+1,ivar)-del - corden(nactve+1,nvar+1)=pcur - ntry=nactve+1 -c icheck that new point is at least minimally distant from old points - - call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) -c only keep trial lower point if it lies above lower bound and satisfies -c minimal distance requirement - if(corden(nactve+1,ivar).ge.ab(ivar,1)) then - if(iclose.eq.0) nactve=nactve+1 - endif -c now create second trail point at +eps in coordinate ivar - do i=1,nvar - corden(nactve+1,i)=corden(ipoint,i) - enddo - corden(nactve+1,ivar)=corden(nactve+1,ivar)+del - corden(nactve+1,nvar+1)=pcur -c only keep upper point if it lies below upper bound and -c satisfies distance requirement - ntry=nactve+1 - call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) - if(corden(nactve+1,ivar).le.ab(ivar,2)) then - if(iclose.eq.0) nactve=nactve+1 - endif - enddo -c above enddo for loop over ivar=1,nvar - - enddo -c above enddo for loop over ipoint=1,nactveold - - -cend expansion -c go to begin new cycle - - prefobj=fobj - - - - GO TO 1001 - - 900 continue - -C AS OF npageng18.f, CONTROL CAN BE TRANSFERRED TO LABEL 900 DIRECTLY -C AFTER RETURNING FROM A CALL TO SUBROUTINE emint. THIS HAPPENS WHEN -C IHESS = -1, WHICH MEANS THAT THE HESSIAN MATRIX IN THE INTERIOR -C POINT EM ALGORITHM WAS SINGULAR. RATHER THAN SIMPLY STOPPING AS IT -C DID PREVIOUSLY, NOW THE PROGRAM WILL CREATE THE OUTPUT FILES BEFORE -C STOPPING ... BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C FIRST, WRITE THE REASON FOR STOPPING AS ICONVERGE = 3 BELOW. THEN -C RESET CORDEN BACK TO CORDLAST (SEE ABOVE), WHICH WAS THE CORDEN -C AT THE END OF THE PREVIOUS CYCLE. -C FOR NPAGFULL, OF COURSE, NO WRITING OCCURS TO OUTPUT FILES. - - -C WRITE WHY THE PROGRAM STOPPED. - - IF(IHESS .EQ. -1) THEN - - NACTVE = NACTLAST - - DO I = 1,NACTVE - DO J = 1,NVAR+1 - CORDEN(I,J) = CORDLAST(I,J) - END DO - END DO - - GO TO 910 - - ENDIF - - -C Starting with bigmlt1.f, this is an entry point to continue -c calculations - - - 910 CONTINUE - -cbegin endgame -c we can only arrive here from the control section, which menas -c that we ahve completed optimizaiton but not done the subsequent -c expansion. This means that the density is correct, and we can safely -c just write it out and exit. - - WRITE(*,1294) ICYCLE,MAXCYC - 1294 FORMAT(/' NPAG RAN ',I6,' OUT OF A MAXIMUM POSSIBLE ',I6/ - 1' CYCLES TO OBTAIN THE POSTERIOR DENSITY.') - -C FOR NPAGFULL, THE DENSITY IS CORRECT AT THIS POINT. SO RETURN TO -C THE BESTDOSxxx PROGRAM. - -C AS OF NPAGFULLA.FOR, CLOSE FILE 37. - - CLOSE(37) - - - - RETURN - END - - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE FILREAD(NOBSER,YO,C0,C1,C2,C3) - -C FILRED IS CALLED BY MAIN TO READ THE PORTION OF -C SCRATCH FILE 37 WHICH APPLIES TO THE SUBJECT UNDER CONSIDERATION. THE -C 'POINTER' FOR FILE 37 IS IN THE PROPER POSITION TO BEGIN READING THE -C INFO FOR THE DESIRED SUBJECT. - - PARAMETER(MAXNUMEQ=7) - - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION TIM(594),SIG(5000),RS(5000,34),YO(594,MAXNUMEQ), - 1 BS(5000,7),C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ), - 2 C3(MAXNUMEQ),YOO(594,MAXNUMEQ) - -C AS OF npageng13.f, THE FORMAT FOR THE WORKING COPY FILES IS: - - -C COL 1 = TIME -C COL 2 = IV FOR DRUG 1; COL 3 = PO FOR DRUG 1; -C COL 4 = IV FOR DRUG 2; COL 5 = PO FOR DRUG 2; -C ... EACH SUCCEEDING DRUG HAS AN IV FOLLOWED BY A PO COLUMN. -C NEXT NADD COLUMNS = ONE FOR EACH ADDITIONAL COVARIATE (ADDITIONAL -C REFERS TO ANY EXTRA COVARIATES BEYOUND THE 4 PERMANENT ONES IN -C COMMON DESCR (SEE BELOW). - - CHARACTER SEX*1,READLINE*300,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - - - - COMMON /OBSER/ TIM,SIG,RS,YOO,BS - COMMON /CNST/ N,ND,NI,NUP,NUIC,NP - COMMON /CNST2/ NPL,NUMEQT,NDRUG,NADD - COMMON /SUM2/ M,NPNL - COMMON/DESCR/AGE,HEIGHT,ISEX,IETHFLG - - -C INPUT IS: SCRATCH FILE 37, WHICH IS POSITIONED AT THE BEGINNING OF -C THE INFO FOR THE SUBJECT DESIRED. - -C OUTPUT ARE: - -C NOBSER = THE NO. OF OBSERVATIONS FOR THIS SUBJECT. -C YO(I,J),I=1,M; J=1,NUMEQT = NO. OF OUTPUT EQS; I=1,M, WHERE M = NO. -C OF OBSERVATION TIMES. -C [C0(J),C1(J),C2(J),C3(J)] = ASSAY NOISE COEFFICIENTS FOR OUTPUT EQ. -C J; J=1,NUMEQT. -C THE 4 DESCRIPTOR VALUES FOR THIS SUBJECT (AGE, SEX, HEIGHT, -C ETHNICITY FLAG) VIA COMMON/DESCR TO SUBROUTINES DIFFEQ/OUTPUT. -C VARIABLES/ARRAYS IN ABOVE COMMON STATEMENTS. - - -C AGE, SEX, HEIGHT, AND ETHNICITY FLAG ARE ON LINES 8-11. - - DO I=1,7 - READ(37,*) - END DO - - - READ(37,*) AGE - READ(37,2) SEX - 2 FORMAT(A1) - ISEX=1 - IF(SEX .EQ. 'F') ISEX=2 - READ(37,*) HEIGHT - READ(37,*) IETHFLG - -C READ THE NO. OF DRUGS FROM THE LINE WITH 'NO. OF DRUGS' AS ENTRIES -C 12:23. THEN READ NO. OF ADDITIONAL COVARIATES, AND THE NO. OF DOSE -C EVENTS, ETC. - - 1 FORMAT(A300) - 10 READ(37,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 - BACKSPACE(37) - - 3 FORMAT(T2,I5) - READ(37,3) NDRUG - - - IF(NDRUG .GT. 7) THEN - WRITE(*,124) - 124 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 7'/ - 1' DRUGS. THE PROGRAM IS NOW STOPPING. '/) - STOP - ENDIF - - READ(37,3) NADD - -C NOTE THAT THE NO. OF "RATES" INCLUDES 2 FOR EACH DRUG (THE IV AND -C THE PO COLUMNS) + NADD (1 COLUMN FOR EACH ADDITIONAL COVARIATE). - - NI = 2*NDRUG + NADD - - IF(NI .GT. 34) THEN - WRITE(*,123) - 123 FORMAT(/' YOUR PATIENT DATA FILES HAVE TOO MANY COLUMNS IN '/ - 1' THE DOSAGE REGIMEN BLOCK. THE NO. OF ADDITIONAL COVARIATES '/ - - 2' PLUS TWICE THE NO. OF DRUGS CANNOT EXCEED 34. THE PROGRAM IS'/ - 3' NOW STOPPING. '/) - STOP - ENDIF - - READ(37,3) ND - - IF(ND .GT. 5000) THEN - WRITE(*,125) - 125 FORMAT(' YOUR PATIENT DATA FILES CANNOT HAVE MORE THAN 5000'/ - 1' DOSE EVENTS. THE PROGRAM IS NOW STOPPING. '/) - STOP - - ENDIF - - READ(37,*) - READ(37,*) - - IF(ND.EQ.0) GO TO 40 - - DO I = 1,ND - READ(37,*) SIG(I),(RS(I,J),J=1,NI) - - END DO - -C ASSIGN THE VALUES IN EACH DRUG'S PO COLUMN TO THE CORRESPONDING -C COLUMN IN ARRAY BS. - - DO I=1,ND - DO J=1,NDRUG - BS(I,J)=RS(I,2*J) - END DO - END DO - -C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' -C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC. - - 40 READ(37,1) READLINE - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 - BACKSPACE(37) - - READ(37,3) NUMEQT - READ(37,3) M - - MAXOBDIM = 150 - IF(M .GT. MAXOBDIM) THEN - - WRITE(*,126) MAXOBDIM - 126 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ - 1' MANY OBSERVED VALUE TIMES. THIS NO. CANNOT EXCEED ',I5,'.'/ - 2' THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,126) MAXOBDIM - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - IF(NUMEQT .GT. MAXNUMEQ) THEN - - WRITE(*,127) MAXNUMEQ - 127 FORMAT(/' AT LEAST ONE OF YOUR PATIENT DATA FILES HAS TOO'/ - 1' MANY OUTPUT EQUATION COLUMNS. THIS NO. CANNOT EXCEED ',I2,'.'/ - 2' THE PROGRAM IS NOW STOPPING. '/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,127) MAXNUMEQ - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - DO I=1,M - READ(37,*) TIM(I),(YO(I,J),J=1,NUMEQT) - END DO - -C PUT YO VALUES INTO YOO BECAUSE A DUMMY ARGUMENT CANNOT BE IN A -C COMMON STATEMENT. - - DO I=1,M - DO J=1,NUMEQT - YOO(I,J) = YO(I,J) - END DO - END DO - - NOBSER=M - -C AT THIS POINT, MUST SKIP THE COVARIATE INFO IN THE FILE, AND PROCEED -C TO READ THE ASSAY NOISE COEFFICIENTS BELOW THAT. - -C READ THE NUMEQT SETS OF ASSAY COEFFICIENTS JUST BELOW THE LINE -C WHICH HAS "ASSAY COEFFICIENTS FOLLOW" IN ENTRIES 1:25. - - 50 READ(37,1) READLINE - IF(READLINE(1:25) .NE. 'ASSAY COEFFICIENTS FOLLOW') GO TO 50 - - DO IEQ = 1,NUMEQT - READ(37,*) C0(IEQ),C1(IEQ),C2(IEQ),C3(IEQ) - END DO - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE CALGRD. 3/19. - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE INFAUR - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE GOFAUR - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE NOTINT(VOLSPA,NGRID,NACTVE,FUNC,MAXGRD,ESTINT) - IMPLICIT REAL*8(A-H,O-Z) - - DIMENSION FUNC(MAXGRD) -C -C THIS SUBROUTINE, CALLED BY MAIN, IS A MULTI-DIMENSIONAL INTEGRATOR. - -C -C INPUT ARE: - -C -C VOLSPA = 'VOLUME' OF THE INTEGRATION SPACE. -C NGRID = NO. OF GRID POINTS OVER WHICH THE INTEGRATION IS DONE. -C NACTVE = NO. OF CURRENTLY ACTIVE GRID POINTS. -C FUNC(I), I=1,NACTVE = VALUE OF THE FUNCTION TO BE INTEGRATED AT - -C THE ITH GRID POINT. -C MAXGRD = DIMENSION OF FUNC -- SEE EXPLATION IN MAIN. -C - -C OUTPUT IS: -C -C ESTINT = THE ESTIMATE OF THE NVAR-DIM INTEGRAL OF THE FUNCTION WHOSE -C VALUES ARE GIVEN IN FUNC. -C - SUM=0.D0 - DO 100 IG=1,NACTVE - 100 SUM=SUM+FUNC(IG) - ESTINT=VOLSPA*SUM/NGRID - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE STAZ -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE EQUIV - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE MAKEVEC (IT'S IN ANOTHER MODULE). -C - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE SUBRES - - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - -C VODTOT.FOR 5-2-96 - -C VODTOT.FOR CONTAINS MODULES VODE.FOR AND VODEXT.FOR. - -C---------------------------------------------------------------------- - -*DECK DVODE - SUBROUTINE DVODE (F, NEQ, Y, T, TOUT, ITOL, RTOL, ATOL, ITASK, - 1 ISTATE, IOPT, RWORK, LRW, IWORK, LIW, JAC, MF, - 2 RPAR, IPAR) - EXTERNAL F, JAC - DOUBLE PRECISION Y, T, TOUT, RTOL, ATOL, RWORK, RPAR - INTEGER NEQ, ITOL, ITASK, ISTATE, IOPT, LRW, IWORK, LIW, - 1 MF, IPAR - DIMENSION Y(*), ATOL(*), RWORK(LRW), IWORK(LIW) - -c----------------------------------------------------------------------- - -c - SPECIAL CHANGE FOR bigmlt10.f - -c When Andreas' Intel compiler compiles the program, it objects to -c RPAR and IPAR being dimensioned (as (*)) in Subroutine DVODE (and -c routines called by DVODE) when they are not dimensioned in -c Subroutine USERANAL (in idm1x5.f). The comments in DVODE state that -c if these values are not being used, they do not need to be -c dimensioned in routines that call DVODE. Nevertheless, to remove the -c Intel objection, RPAR(*) and IPAR(*) are removed from the 5 routines - -c in this module which declare them arrays. - -c Similarly, RTOL supposedly does not need to be dimensioned in - -c USERANAL since it is a scalar, but the Intel compiler objects to -c having it dimensioned (*) in DVODE, etc. when it is a scalar in -c USERANAL. So, all RTOL(*) occurrences are removed in this module, -c and all references to RTOL(1), RTOL(I), etc. are changed to RTOL. - -C----------------------------------------------------------------------- -C DVODE.. Variable-coefficient Ordinary Differential Equation solver, -C with fixed-leading coefficient implementation. -C This version is in double precision. -C -C DVODE solves the initial value problem for stiff or nonstiff -C systems of first order ODEs, -C dy/dt = f(t,y) , or, in component form, -C dy(i)/dt = f(i) = f(i,t,y(1),y(2),...,y(NEQ)) (i = 1,...,NEQ). -C DVODE is a package based on the EPISODE and EPISODEB packages, and -C on the ODEPACK user interface standard, with minor modifications. -C----------------------------------------------------------------------- -C Revision History (YYMMDD) -C 890615 Date Written -C 890922 Added interrupt/restart ability, minor changes throughout. -C 910228 Minor revisions in line format, prologue, etc. -C 920227 Modifications by D. Pang: -C (1) Applied subgennam to get generic intrinsic names. -C (2) Changed intrinsic names to generic in comments. -C (3) Added *DECK lines before each routine. -C 920721 Names of routines and labeled Common blocks changed, so as -C to be unique in combined single/double precision code (ACH). - -C 920722 Minor revisions to prologue (ACH). -C 920831 Conversion to double precision done (ACH). -C----------------------------------------------------------------------- -C References.. -C -C 1. P. N. Brown, G. D. Byrne, and A. C. Hindmarsh, "VODE: A Variable -C Coefficient ODE Solver," SIAM J. Sci. Stat. Comput., 10 (1989), -C pp. 1038-1051. Also, LLNL Report UCRL-98412, June 1988. -C 2. G. D. Byrne and A. C. Hindmarsh, "A Polyalgorithm for the -C Numerical Solution of Ordinary Differential Equations," -C ACM Trans. Math. Software, 1 (1975), pp. 71-96. -C 3. A. C. Hindmarsh and G. D. Byrne, "EPISODE: An Effective Package -C for the Integration of Systems of Ordinary Differential -C Equations," LLNL Report UCID-30112, Rev. 1, April 1977. -C 4. G. D. Byrne and A. C. Hindmarsh, "EPISODEB: An Experimental -C Package for the Integration of Systems of Ordinary Differential -C Equations with Banded Jacobians," LLNL Report UCID-30132, April -C 1976. - -C 5. A. C. Hindmarsh, "ODEPACK, a Systematized Collection of ODE -C Solvers," in Scientific Computing, R. S. Stepleman et al., eds., -C North-Holland, Amsterdam, 1983, pp. 55-64. -C 6. K. R. Jackson and R. Sacks-Davis, "An Alternative Implementation - -C of Variable Step-Size Multistep Formulas for Stiff ODEs," ACM -C Trans. Math. Software, 6 (1980), pp. 295-318. -C----------------------------------------------------------------------- - -C Authors.. -C -C Peter N. Brown and Alan C. Hindmarsh -C Computing and Mathematics Research Division, L-316 -C Lawrence Livermore National Laboratory -C Livermore, CA 94550 -C and -C George D. Byrne -C Exxon Research and Engineering Co. -C Clinton Township -C Route 22 East -C Annandale, NJ 08801 -C----------------------------------------------------------------------- -C Summary of usage. -C -C Communication between the user and the DVODE package, for normal -C situations, is summarized here. This summary describes only a subset -C of the full set of options available. See the full description for -C details, including optional communication, nonstandard options, -C and instructions for special situations. See also the example -C problem (with program and output) following this summary. -C -C A. First provide a subroutine of the form.. -C -C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) -C DOUBLE PRECISION T, Y, YDOT, RPAR -C DIMENSION Y(NEQ), YDOT(NEQ) -C -C which supplies the vector function f by loading YDOT(i) with f(i). -C -C B. Next determine (or guess) whether or not the problem is stiff. -C Stiffness occurs when the Jacobian matrix df/dy has an eigenvalue -C whose real part is negative and large in magnitude, compared to the -C reciprocal of the t span of interest. If the problem is nonstiff, -C use a method flag MF = 10. If it is stiff, there are four standard -C choices for MF (21, 22, 24, 25), and DVODE requires the Jacobian -C matrix in some form. In these cases (MF .gt. 0), DVODE will use a -C saved copy of the Jacobian matrix. If this is undesirable because of -C storage limitations, set MF to the corresponding negative value -C (-21, -22, -24, -25). (See full description of MF below.) -C The Jacobian matrix is regarded either as full (MF = 21 or 22), -C or banded (MF = 24 or 25). In the banded case, DVODE requires two -C half-bandwidth parameters ML and MU. These are, respectively, the -C widths of the lower and upper parts of the band, excluding the main -C diagonal. Thus the band consists of the locations (i,j) with -C i-ML .le. j .le. i+MU, and the full bandwidth is ML+MU+1. -C -C C. If the problem is stiff, you are encouraged to supply the Jacobian -C directly (MF = 21 or 24), but if this is not feasible, DVODE will -C compute it internally by difference quotients (MF = 22 or 25). -C If you are supplying the Jacobian, provide a subroutine of the form.. -C -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, RPAR, IPAR) -C DOUBLE PRECISION T, Y, PD, RPAR -C DIMENSION Y(NEQ), PD(NROWPD,NEQ) -C -C which supplies df/dy by loading PD as follows.. -C For a full Jacobian (MF = 21), load PD(i,j) with df(i)/dy(j), -C the partial derivative of f(i) with respect to y(j). (Ignore the -C ML and MU arguments in this case.) -C For a banded Jacobian (MF = 24), load PD(i-j+MU+1,j) with -C df(i)/dy(j), i.e. load the diagonal lines of df/dy into the rows of -C PD from the top down. -C In either case, only nonzero elements need be loaded. -C -C D. Write a main program which calls subroutine DVODE once for -C each point at which answers are desired. This should also provide -C for possible use of logical unit 6 for output of error messages -C by DVODE. On the first call to DVODE, supply arguments as follows.. - -C F = Name of subroutine for right-hand side vector f. -C This name must be declared external in calling program. -C NEQ = Number of first order ODE-s. -C Y = Array of initial values, of length NEQ. -C T = The initial value of the independent variable. - -C TOUT = First point where output is desired (.ne. T). -C ITOL = 1 or 2 according as ATOL (below) is a scalar or array. -C RTOL = Relative tolerance parameter (scalar). - -C ATOL = Absolute tolerance parameter (scalar or array). -C The estimated local error in Y(i) will be controlled so as -C to be roughly less (in magnitude) than -C EWT(i) = RTOL*abs(Y(i)) + ATOL if ITOL = 1, or -C EWT(i) = RTOL*abs(Y(i)) + ATOL(i) if ITOL = 2. -C Thus the local error test passes if, in each component, -C either the absolute error is less than ATOL (or ATOL(i)), -C or the relative error is less than RTOL. -C Use RTOL = 0.0 for pure absolute error control, and -C use ATOL = 0.0 (or ATOL(i) = 0.0) for pure relative error -C control. Caution.. Actual (global) errors may exceed these -C local tolerances, so choose them conservatively. -C ITASK = 1 for normal computation of output values of Y at t = TOUT. -C ISTATE = Integer flag (input and output). Set ISTATE = 1. -C IOPT = 0 to indicate no optional input used. -C RWORK = Real work array of length at least.. -C 20 + 16*NEQ for MF = 10, -C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, -C 22 + 11*NEQ + (3*ML + 2*MU)*NEQ for MF = 24 or 25. -C LRW = Declared length of RWORK (in user's DIMENSION statement). -C IWORK = Integer work array of length at least.. -C 30 for MF = 10, -C 30 + NEQ for MF = 21, 22, 24, or 25. -C If MF = 24 or 25, input in IWORK(1),IWORK(2) the lower -C and upper half-bandwidths ML,MU. -C LIW = Declared length of IWORK (in user's DIMENSION). -C JAC = Name of subroutine for Jacobian matrix (MF = 21 or 24). -C If used, this name must be declared external in calling -C program. If not used, pass a dummy name. - -C MF = Method flag. Standard values are.. -C 10 for nonstiff (Adams) method, no Jacobian used. -C 21 for stiff (BDF) method, user-supplied full Jacobian. - -C 22 for stiff method, internally generated full Jacobian. -C 24 for stiff method, user-supplied banded Jacobian. -C 25 for stiff method, internally generated banded Jacobian. -C RPAR,IPAR = user-defined real and integer arrays passed to F and JAC. -C Note that the main program must declare arrays Y, RWORK, IWORK, -C and possibly ATOL, RPAR, and IPAR. -C -C E. The output from the first call (or any call) is.. -C Y = Array of computed values of y(t) vector. -C T = Corresponding value of independent variable (normally TOUT). -C ISTATE = 2 if DVODE was successful, negative otherwise. -C -1 means excess work done on this call. (Perhaps wrong MF.) -C -2 means excess accuracy requested. (Tolerances too small.) -C -3 means illegal input detected. (See printed message.) -C -4 means repeated error test failures. (Check all input.) -C -5 means repeated convergence failures. (Perhaps bad -C Jacobian supplied or wrong choice of MF or tolerances.) -C -6 means error weight became zero during problem. (Solution -C component i vanished, and ATOL or ATOL(i) = 0.) -C -C F. To continue the integration after a successful return, simply -C reset TOUT and call DVODE again. No other parameters need be reset. - -C -C----------------------------------------------------------------------- -C EXAMPLE PROBLEM -C -C The following is a simple example problem, with the coding -C needed for its solution by DVODE. The problem is from chemical -C kinetics, and consists of the following three rate equations.. -C dy1/dt = -.04*y1 + 1.e4*y2*y3 -C dy2/dt = .04*y1 - 1.e4*y2*y3 - 3.e7*y2**2 -C dy3/dt = 3.e7*y2**2 - -C on the interval from t = 0.0 to t = 4.e10, with initial conditions -C y1 = 1.0, y2 = y3 = 0. The problem is stiff. - -C - -C The following coding solves this problem with DVODE, using MF = 21 -C and printing results at t = .4, 4., ..., 4.e10. It uses -C ITOL = 2 and ATOL much smaller for y2 than y1 or y3 because -C y2 has much smaller values. -C At the end of the run, statistical quantities of interest are -C printed. (See optional output in the full description below.) -C To generate Fortran source code, replace C in column 1 with a blank -C in the coding below. -C -C EXTERNAL FEX, JEX -C DOUBLE PRECISION ATOL, RPAR, RTOL, RWORK, T, TOUT, Y -C DIMENSION Y(3), ATOL(3), RWORK(67), IWORK(33) -C NEQ = 3 -C Y(1) = 1.0D0 -C Y(2) = 0.0D0 -C Y(3) = 0.0D0 -C T = 0.0D0 -C TOUT = 0.4D0 -C ITOL = 2 - -C RTOL = 1.D-4 -C ATOL(1) = 1.D-8 - -C ATOL(2) = 1.D-14 -C ATOL(3) = 1.D-6 - -C ITASK = 1 -C ISTATE = 1 - -C IOPT = 0 -C LRW = 67 -C LIW = 33 -C MF = 21 -C DO 40 IOUT = 1,12 -C CALL DVODE(FEX,NEQ,Y,T,TOUT,ITOL,RTOL,ATOL,ITASK,ISTATE, -C 1 IOPT,RWORK,LRW,IWORK,LIW,JEX,MF,RPAR,IPAR) - -C WRITE(6,20)T,Y(1),Y(2),Y(3) -C 20 FORMAT(' At t =',D12.4,' y =',3D14.6) -C IF (ISTATE .LT. 0) GO TO 80 -C 40 TOUT = TOUT*10. -C WRITE(6,60) IWORK(11),IWORK(12),IWORK(13),IWORK(19), -C 1 IWORK(20),IWORK(21),IWORK(22) -C 60 FORMAT(/' No. steps =',I4,' No. f-s =',I4, -C 1 ' No. J-s =',I4,' No. LU-s =',I4/ -C 2 ' No. nonlinear iterations =',I4/ -C 3 ' No. nonlinear convergence failures =',I4/ - -C 4 ' No. error test failures =',I4/) -C STOP -C 80 WRITE(6,90)ISTATE -C 90 FORMAT(///' Error halt.. ISTATE =',I3) -C STOP -C END -C -C SUBROUTINE FEX (NEQ, T, Y, YDOT, RPAR, IPAR) -C DOUBLE PRECISION RPAR, T, Y, YDOT -C DIMENSION Y(NEQ), YDOT(NEQ) -C YDOT(1) = -.04D0*Y(1) + 1.D4*Y(2)*Y(3) -C YDOT(3) = 3.D7*Y(2)*Y(2) -C YDOT(2) = -YDOT(1) - YDOT(3) -C RETURN -C END -C -C SUBROUTINE JEX (NEQ, T, Y, ML, MU, PD, NRPD, RPAR, IPAR) -C DOUBLE PRECISION PD, RPAR, T, Y -C DIMENSION Y(NEQ), PD(NRPD,NEQ) -C PD(1,1) = -.04D0 - -C PD(1,2) = 1.D4*Y(3) -C PD(1,3) = 1.D4*Y(2) -C PD(2,1) = .04D0 -C PD(2,3) = -PD(1,3) -C PD(3,2) = 6.D7*Y(2) -C PD(2,2) = -PD(1,2) - PD(3,2) -C RETURN -C END -C -C The following output was obtained from the above program on a -C Cray-1 computer with the CFT compiler. -C -C At t = 4.0000e-01 y = 9.851680e-01 3.386314e-05 1.479817e-02 -C At t = 4.0000e+00 y = 9.055255e-01 2.240539e-05 9.445214e-02 -C At t = 4.0000e+01 y = 7.158108e-01 9.184883e-06 2.841800e-01 -C At t = 4.0000e+02 y = 4.505032e-01 3.222940e-06 5.494936e-01 -C At t = 4.0000e+03 y = 1.832053e-01 8.942690e-07 8.167938e-01 -C At t = 4.0000e+04 y = 3.898560e-02 1.621875e-07 9.610142e-01 -C At t = 4.0000e+05 y = 4.935882e-03 1.984013e-08 9.950641e-01 -C At t = 4.0000e+06 y = 5.166183e-04 2.067528e-09 9.994834e-01 -C At t = 4.0000e+07 y = 5.201214e-05 2.080593e-10 9.999480e-01 -C At t = 4.0000e+08 y = 5.213149e-06 2.085271e-11 9.999948e-01 -C At t = 4.0000e+09 y = 5.183495e-07 2.073399e-12 9.999995e-01 -C At t = 4.0000e+10 y = 5.450996e-08 2.180399e-13 9.999999e-01 -C -C No. steps = 595 No. f-s = 832 No. J-s = 13 No. LU-s = 112 -C No. nonlinear iterations = 831 -C No. nonlinear convergence failures = 0 -C No. error test failures = 22 -C----------------------------------------------------------------------- -C Full description of user interface to DVODE. -C -C The user interface to DVODE consists of the following parts. -C -C i. The call sequence to subroutine DVODE, which is a driver -C routine for the solver. This includes descriptions of both -C the call sequence arguments and of user-supplied routines. -C Following these descriptions is -C * a description of optional input available through the -C call sequence, -C * a description of optional output (in the work arrays), and -C * instructions for interrupting and restarting a solution. -C -C ii. Descriptions of other routines in the DVODE package that may be -C (optionally) called by the user. These provide the ability to -C alter error message handling, save and restore the internal -C COMMON, and obtain specified derivatives of the solution y(t). -C -C iii. Descriptions of COMMON blocks to be declared in overlay -C or similar environments. -C -C iv. Description of two routines in the DVODE package, either of -C which the user may replace with his own version, if desired. -C these relate to the measurement of errors. -C -C----------------------------------------------------------------------- -C Part i. Call Sequence. -C -C The call sequence parameters used for input only are -C F, NEQ, TOUT, ITOL, RTOL, ATOL, ITASK, IOPT, LRW, LIW, JAC, MF, -C and those used for both input and output are -C Y, T, ISTATE. -C The work arrays RWORK and IWORK are also used for conditional and -C optional input and optional output. (The term output here refers -C to the return from subroutine DVODE to the user's calling program.) -C -C The legality of input parameters will be thoroughly checked on the -C initial call for the problem, but not checked thereafter unless a -C change in input parameters is flagged by ISTATE = 3 in the input. - -C -C The descriptions of the call arguments are as follows. -C -C F = The name of the user-supplied subroutine defining the -C ODE system. The system must be put in the first-order -C form dy/dt = f(t,y), where f is a vector-valued function -C of the scalar t and the vector y. Subroutine F is to -C compute the function f. It is to have the form -C SUBROUTINE F (NEQ, T, Y, YDOT, RPAR, IPAR) -C DOUBLE PRECISION T, Y, YDOT, RPAR - -C DIMENSION Y(NEQ), YDOT(NEQ) -C where NEQ, T, and Y are input, and the array YDOT = f(t,y) -C is output. Y and YDOT are arrays of length NEQ. -C (In the DIMENSION statement above, NEQ can be replaced by -C * to make Y and YDOT assumed size arrays.) -C Subroutine F should not alter Y(1),...,Y(NEQ). -C F must be declared EXTERNAL in the calling program. - -C -C Subroutine F may access user-defined real and integer -C work arrays RPAR and IPAR, which are to be dimensioned - -C in the main program. -C -C If quantities computed in the F routine are needed -C externally to DVODE, an extra call to F should be made - -C for this purpose, for consistent and accurate results. -C If only the derivative dy/dt is needed, use DVINDY instead. -C -C NEQ = The size of the ODE system (number of first order -C ordinary differential equations). Used only for input. -C NEQ may not be increased during the problem, but -C can be decreased (with ISTATE = 3 in the input). - -C -C Y = A real array for the vector of dependent variables, of - -C length NEQ or more. Used for both input and output on the -C first call (ISTATE = 1), and only for output on other calls. -C On the first call, Y must contain the vector of initial -C values. In the output, Y contains the computed solution -C evaluated at T. If desired, the Y array may be used - -C for other purposes between calls to the solver. -C -C This array is passed as the Y argument in all calls to -C F and JAC. -C -C T = The independent variable. In the input, T is used only on -C the first call, as the initial point of the integration. - -C In the output, after each call, T is the value at which a -C computed solution Y is evaluated (usually the same as TOUT). -C On an error return, T is the farthest point reached. - -C -C TOUT = The next value of t at which a computed solution is desired. -C Used only for input. -C -C When starting the problem (ISTATE = 1), TOUT may be equal -C to T for one call, then should .ne. T for the next call. -C For the initial T, an input value of TOUT .ne. T is used -C in order to determine the direction of the integration -C (i.e. the algebraic sign of the step sizes) and the rough -C scale of the problem. Integration in either direction -C (forward or backward in t) is permitted. -C -C If ITASK = 2 or 5 (one-step modes), TOUT is ignored after -C the first call (i.e. the first call with TOUT .ne. T). -C Otherwise, TOUT is required on every call. -C -C If ITASK = 1, 3, or 4, the values of TOUT need not be - -C monotone, but a value of TOUT which backs up is limited -C to the current internal t interval, whose endpoints are -C TCUR - HU and TCUR. (See optional output, below, for -C TCUR and HU.) -C -C ITOL = An indicator for the type of error control. See -C description below under ATOL. Used only for input. -C -C RTOL = A relative error tolerance parameter, either a scalar or -C an array of length NEQ. See description below under ATOL. -C Input only. -C -C ATOL = An absolute error tolerance parameter, either a scalar or -C an array of length NEQ. Input only. -C -C The input parameters ITOL, RTOL, and ATOL determine -C the error control performed by the solver. The solver will -C control the vector e = (e(i)) of estimated local errors -C in Y, according to an inequality of the form - -C rms-norm of ( e(i)/EWT(i) ) .le. 1, -C where EWT(i) = RTOL(i)*abs(Y(i)) + ATOL(i), -C and the rms-norm (root-mean-square norm) here is -C rms-norm(v) = sqrt(sum v(i)**2 / NEQ). Here EWT = (EWT(i)) -C is a vector of weights which must always be positive, and -C the values of RTOL and ATOL should all be non-negative. -C The following table gives the types (scalar/array) of -C RTOL and ATOL, and the corresponding form of EWT(i). -C -C ITOL RTOL ATOL EWT(i) -C 1 scalar scalar RTOL*ABS(Y(i)) + ATOL -C 2 scalar array RTOL*ABS(Y(i)) + ATOL(i) -C 3 array scalar RTOL(i)*ABS(Y(i)) + ATOL -C 4 array array RTOL(i)*ABS(Y(i)) + ATOL(i) -C -C When either of these parameters is a scalar, it need not -C be dimensioned in the user's calling program. -C -C If none of the above choices (with ITOL, RTOL, and ATOL -C fixed throughout the problem) is suitable, more general -C error controls can be obtained by substituting -C user-supplied routines for the setting of EWT and/or for -C the norm calculation. See Part iv below. -C -C If global errors are to be estimated by making a repeated -C run on the same problem with smaller tolerances, then all -C components of RTOL and ATOL (i.e. of EWT) should be scaled -C down uniformly. -C -C ITASK = An index specifying the task to be performed. -C Input only. ITASK has the following values and meanings. -C 1 means normal computation of output values of y(t) at -C t = TOUT (by overshooting and interpolating). -C 2 means take one step only and return. - -C 3 means stop at the first internal mesh point at or - -C beyond t = TOUT and return. -C 4 means normal computation of output values of y(t) at -C t = TOUT but without overshooting t = TCRIT. -C TCRIT must be input as RWORK(1). TCRIT may be equal to -C or beyond TOUT, but not behind it in the direction of -C integration. This option is useful if the problem -C has a singularity at or beyond t = TCRIT. -C 5 means take one step, without passing TCRIT, and return. -C TCRIT must be input as RWORK(1). -C -C Note.. If ITASK = 4 or 5 and the solver reaches TCRIT -C (within roundoff), it will return T = TCRIT (exactly) to -C indicate this (unless ITASK = 4 and TOUT comes before TCRIT, -C in which case answers at T = TOUT are returned first). -C -C ISTATE = an index used for input and output to specify the -C the state of the calculation. -C -C In the input, the values of ISTATE are as follows. -C 1 means this is the first call for the problem -C (initializations will be done). See note below. -C 2 means this is not the first call, and the calculation -C is to continue normally, with no change in any input -C parameters except possibly TOUT and ITASK. -C (If ITOL, RTOL, and/or ATOL are changed between calls -C with ISTATE = 2, the new values will be used but not - -C tested for legality.) -C 3 means this is not the first call, and the -C calculation is to continue normally, but with -C a change in input parameters other than -C TOUT and ITASK. Changes are allowed in -C NEQ, ITOL, RTOL, ATOL, IOPT, LRW, LIW, MF, ML, MU, - -C and any of the optional input except H0. -C (See IWORK description for ML and MU.) - -C Note.. A preliminary call with TOUT = T is not counted -C as a first call here, as no initialization or checking of -C input is done. (Such a call is sometimes useful to include -C the initial conditions in the output.) -C Thus the first call for which TOUT .ne. T requires -C ISTATE = 1 in the input. -C -C In the output, ISTATE has the following values and meanings. -C 1 means nothing was done, as TOUT was equal to T with -C ISTATE = 1 in the input. -C 2 means the integration was performed successfully. -C -1 means an excessive amount of work (more than MXSTEP -C steps) was done on this call, before completing the -C requested task, but the integration was otherwise -C successful as far as T. (MXSTEP is an optional input -C and is normally 500.) To continue, the user may -C simply reset ISTATE to a value .gt. 1 and call again. -C (The excess work step counter will be reset to 0.) -C In addition, the user may increase MXSTEP to avoid -C this error return. (See optional input below.) -C -2 means too much accuracy was requested for the precision -C of the machine being used. This was detected before -C completing the requested task, but the integration -C was successful as far as T. To continue, the tolerance -C parameters must be reset, and ISTATE must be set -C to 3. The optional output TOLSF may be used for this -C purpose. (Note.. If this condition is detected before -C taking any steps, then an illegal input return -C (ISTATE = -3) occurs instead.) -C -3 means illegal input was detected, before taking any -C integration steps. See written message for details. -C Note.. If the solver detects an infinite loop of calls -C to the solver with illegal input, it will cause -C the run to stop. -C -4 means there were repeated error test failures on -C one attempted step, before completing the requested -C task, but the integration was successful as far as T. -C The problem may have a singularity, or the input -C may be inappropriate. -C -5 means there were repeated convergence test failures on -C one attempted step, before completing the requested -C task, but the integration was successful as far as T. -C This may be caused by an inaccurate Jacobian matrix, -C if one is being used. -C -6 means EWT(i) became zero for some i during the -C integration. Pure relative error control (ATOL(i)=0.0) -C was requested on a variable which has now vanished. -C The integration was successful as far as T. -C -C Note.. Since the normal output value of ISTATE is 2, -C it does not need to be reset for normal continuation. - -C Also, since a negative input value of ISTATE will be -C regarded as illegal, a negative output value requires the -C user to change it, and possibly other input, before -C calling the solver again. -C -C IOPT = An integer flag to specify whether or not any optional -C input is being used on this call. Input only. -C The optional input is listed separately below. -C IOPT = 0 means no optional input is being used. -C Default values will be used in all cases. -C IOPT = 1 means optional input is being used. -C -C RWORK = A real working array (double precision). -C The length of RWORK must be at least -C 20 + NYH*(MAXORD + 1) + 3*NEQ + LWM where -C NYH = the initial value of NEQ, -C MAXORD = 12 (if METH = 1) or 5 (if METH = 2) (unless a -C smaller value is given as an optional input), -C LWM = length of work space for matrix-related data.. -C LWM = 0 if MITER = 0, -C LWM = 2*NEQ**2 + 2 if MITER = 1 or 2, and MF.gt.0, -C LWM = NEQ**2 + 2 if MITER = 1 or 2, and MF.lt.0, -C LWM = NEQ + 2 if MITER = 3, -C LWM = (3*ML+2*MU+2)*NEQ + 2 if MITER = 4 or 5, and MF.gt.0, -C LWM = (2*ML+MU+1)*NEQ + 2 if MITER = 4 or 5, and MF.lt.0. -C (See the MF description for METH and MITER.) -C Thus if MAXORD has its default value and NEQ is constant, -C this length is.. - -C 20 + 16*NEQ for MF = 10, -C 22 + 16*NEQ + 2*NEQ**2 for MF = 11 or 12, -C 22 + 16*NEQ + NEQ**2 for MF = -11 or -12, -C 22 + 17*NEQ for MF = 13, -C 22 + 18*NEQ + (3*ML+2*MU)*NEQ for MF = 14 or 15, -C 22 + 17*NEQ + (2*ML+MU)*NEQ for MF = -14 or -15, -C 20 + 9*NEQ for MF = 20, -C 22 + 9*NEQ + 2*NEQ**2 for MF = 21 or 22, -C 22 + 9*NEQ + NEQ**2 for MF = -21 or -22, -C 22 + 10*NEQ for MF = 23, -C 22 + 11*NEQ + (3*ML+2*MU)*NEQ for MF = 24 or 25. -C 22 + 10*NEQ + (2*ML+MU)*NEQ for MF = -24 or -25. -C The first 20 words of RWORK are reserved for conditional -C and optional input and optional output. -C -C The following word in RWORK is a conditional input.. -C RWORK(1) = TCRIT = critical value of t which the solver -C is not to overshoot. Required if ITASK is -C 4 or 5, and ignored otherwise. (See ITASK.) -C -C LRW = The length of the array RWORK, as declared by the user. - -C (This will be checked by the solver.) -C -C IWORK = An integer work array. The length of IWORK must be at least -C 30 if MITER = 0 or 3 (MF = 10, 13, 20, 23), or -C 30 + NEQ otherwise (abs(MF) = 11,12,14,15,21,22,24,25). -C The first 30 words of IWORK are reserved for conditional and -C optional input and optional output. -C -C The following 2 words in IWORK are conditional input.. -C IWORK(1) = ML These are the lower and upper -C IWORK(2) = MU half-bandwidths, respectively, of the -C banded Jacobian, excluding the main diagonal. -C The band is defined by the matrix locations -C (i,j) with i-ML .le. j .le. i+MU. ML and MU -C must satisfy 0 .le. ML,MU .le. NEQ-1. -C These are required if MITER is 4 or 5, and -C ignored otherwise. ML and MU may in fact be -C the band parameters for a matrix to which -C df/dy is only approximately equal. -C -C LIW = the length of the array IWORK, as declared by the user. -C (This will be checked by the solver.) -C -C Note.. The work arrays must not be altered between calls to DVODE -C for the same problem, except possibly for the conditional and -C optional input, and except for the last 3*NEQ words of RWORK. -C The latter space is used for internal scratch space, and so is -C available for use by the user outside DVODE between calls, if -C desired (but not for use by F or JAC). -C -C JAC = The name of the user-supplied routine (MITER = 1 or 4) to -C compute the Jacobian matrix, df/dy, as a function of -C the scalar t and the vector y. It is to have the form -C SUBROUTINE JAC (NEQ, T, Y, ML, MU, PD, NROWPD, -C RPAR, IPAR) -C DOUBLE PRECISION T, Y, PD, RPAR -C DIMENSION Y(NEQ), PD(NROWPD, NEQ) -C where NEQ, T, Y, ML, MU, and NROWPD are input and the array -C PD is to be loaded with partial derivatives (elements of the - -C Jacobian matrix) in the output. PD must be given a first -C dimension of NROWPD. T and Y have the same meaning as in -C Subroutine F. (In the DIMENSION statement above, NEQ can -C be replaced by * to make Y and PD assumed size arrays.) -C In the full matrix case (MITER = 1), ML and MU are -C ignored, and the Jacobian is to be loaded into PD in -C columnwise manner, with df(i)/dy(j) loaded into PD(i,j). -C In the band matrix case (MITER = 4), the elements -C within the band are to be loaded into PD in columnwise -C manner, with diagonal lines of df/dy loaded into the rows -C of PD. Thus df(i)/dy(j) is to be loaded into PD(i-j+MU+1,j). -C ML and MU are the half-bandwidth parameters. (See IWORK). -C The locations in PD in the two triangular areas which -C correspond to nonexistent matrix elements can be ignored -C or loaded arbitrarily, as they are overwritten by DVODE. -C JAC need not provide df/dy exactly. A crude -C approximation (possibly with a smaller bandwidth) will do. -C In either case, PD is preset to zero by the solver, -C so that only the nonzero elements need be loaded by JAC. -C Each call to JAC is preceded by a call to F with the same -C arguments NEQ, T, and Y. Thus to gain some efficiency, -C intermediate quantities shared by both calculations may be -C saved in a user COMMON block by F and not recomputed by JAC, -C if desired. Also, JAC may alter the Y array, if desired. -C JAC must be declared external in the calling program. -C Subroutine JAC may access user-defined real and integer -C work arrays, RPAR and IPAR, whose dimensions are set by the -C user in the main program. -C -C MF = The method flag. Used only for input. The legal values of -C MF are 10, 11, 12, 13, 14, 15, 20, 21, 22, 23, 24, 25, -C -11, -12, -14, -15, -21, -22, -24, -25. -C MF is a signed two-digit integer, MF = JSV*(10*METH + MITER). -C JSV = SIGN(MF) indicates the Jacobian-saving strategy.. -C JSV = 1 means a copy of the Jacobian is saved for reuse -C in the corrector iteration algorithm. -C JSV = -1 means a copy of the Jacobian is not saved - -C (valid only for MITER = 1, 2, 4, or 5). -C METH indicates the basic linear multistep method.. -C METH = 1 means the implicit Adams method. -C METH = 2 means the method based on backward -C differentiation formulas (BDF-s). -C MITER indicates the corrector iteration method.. -C MITER = 0 means functional iteration (no Jacobian matrix -C is involved). -C MITER = 1 means chord iteration with a user-supplied -C full (NEQ by NEQ) Jacobian. -C MITER = 2 means chord iteration with an internally -C generated (difference quotient) full Jacobian -C (using NEQ extra calls to F per df/dy value). -C MITER = 3 means chord iteration with an internally -C generated diagonal Jacobian approximation -C (using 1 extra call to F per df/dy evaluation). -C MITER = 4 means chord iteration with a user-supplied -C banded Jacobian. -C MITER = 5 means chord iteration with an internally -C generated banded Jacobian (using ML+MU+1 extra -C calls to F per df/dy evaluation). -C If MITER = 1 or 4, the user must supply a subroutine JAC -C (the name is arbitrary) as described above under JAC. -C For other values of MITER, a dummy argument can be used. - -C -C RPAR User-specified array used to communicate real parameters -C to user-supplied subroutines. If RPAR is a vector, then -C it must be dimensioned in the user's main program. If it -C is unused or it is a scalar, then it need not be -C dimensioned. -C -C IPAR User-specified array used to communicate integer parameter -C to user-supplied subroutines. The comments on dimensioning -C RPAR apply to IPAR. -C----------------------------------------------------------------------- -C Optional Input. - -C -C The following is a list of the optional input provided for in the -C call sequence. (See also Part ii.) For each such input variable, -C this table lists its name as used in this documentation, its -C location in the call sequence, its meaning, and the default value. -C The use of any of this input requires IOPT = 1, and in that -C case all of this input is examined. A value of zero for any -C of these optional input variables will cause the default value to be -C used. Thus to use a subset of the optional input, simply preload -C locations 5 to 10 in RWORK and IWORK to 0.0 and 0 respectively, and -C then set those of interest to nonzero values. -C -C NAME LOCATION MEANING AND DEFAULT VALUE -C -C H0 RWORK(5) The step size to be attempted on the first step. - -C The default value is determined by the solver. -C - -C HMAX RWORK(6) The maximum absolute step size allowed. -C The default value is infinite. -C - -C HMIN RWORK(7) The minimum absolute step size allowed. -C The default value is 0. (This lower bound is not - -C enforced on the final step before reaching TCRIT -C when ITASK = 4 or 5.) -C -C MAXORD IWORK(5) The maximum order to be allowed. The default -C value is 12 if METH = 1, and 5 if METH = 2. -C If MAXORD exceeds the default value, it will -C be reduced to the default value. -C If MAXORD is changed during the problem, it may -C cause the current order to be reduced. -C -C MXSTEP IWORK(6) Maximum number of (internally defined) steps -C allowed during one call to the solver. -C The default value is 500. -C -C MXHNIL IWORK(7) Maximum number of messages printed (per problem) -C warning that T + H = T on a step (H = step size). -C This must be positive to result in a non-default -C value. The default value is 10. -C -C----------------------------------------------------------------------- -C Optional Output. -C -C As optional additional output from DVODE, the variables listed -C below are quantities related to the performance of DVODE -C which are available to the user. These are communicated by way of -C the work arrays, but also have internal mnemonic names as shown. -C Except where stated otherwise, all of this output is defined -C on any successful return from DVODE, and on any return with -C ISTATE = -1, -2, -4, -5, or -6. On an illegal input return -C (ISTATE = -3), they will be unchanged from their existing values -C (if any), except possibly for TOLSF, LENRW, and LENIW. - -C On any error return, output relevant to the error will be defined, -C as noted below. -C -C NAME LOCATION MEANING -C -C HU RWORK(11) The step size in t last used (successfully). -C -C HCUR RWORK(12) The step size to be attempted on the next step. -C -C TCUR RWORK(13) The current value of the independent variable -C which the solver has actually reached, i.e. the -C current internal mesh point in t. In the output, -C TCUR will always be at least as far from the -C initial value of t as the current argument T, -C but may be farther (if interpolation was done). -C -C TOLSF RWORK(14) A tolerance scale factor, greater than 1.0, -C computed when a request for too much accuracy was -C detected (ISTATE = -3 if detected at the start of -C the problem, ISTATE = -2 otherwise). If ITOL is - -C left unaltered but RTOL and ATOL are uniformly -C scaled up by a factor of TOLSF for the next call, -C then the solver is deemed likely to succeed. -C (The user may also ignore TOLSF and alter the -C tolerance parameters in any other way appropriate.) -C -C NST IWORK(11) The number of steps taken for the problem so far. -C -C NFE IWORK(12) The number of f evaluations for the problem so far. -C -C NJE IWORK(13) The number of Jacobian evaluations so far. -C - - -C NQU IWORK(14) The method order last used (successfully). -C -C NQCUR IWORK(15) The order to be attempted on the next step. -C -C IMXER IWORK(16) The index of the component of largest magnitude in -C the weighted local error vector ( e(i)/EWT(i) ), -C on an error return with ISTATE = -4 or -5. -C -C LENRW IWORK(17) The length of RWORK actually required. -C This is defined on normal returns and on an illegal -C input return for insufficient storage. -C -C LENIW IWORK(18) The length of IWORK actually required. -C This is defined on normal returns and on an illegal -C input return for insufficient storage. -C -C NLU IWORK(19) The number of matrix LU decompositions so far. -C -C NNI IWORK(20) The number of nonlinear (Newton) iterations so far. -C -C NCFN IWORK(21) The number of convergence failures of the nonlinear -C solver so far. -C -C NETF IWORK(22) The number of error test failures of the integrator -C so far. -C -C The following two arrays are segments of the RWORK array which -C may also be of interest to the user as optional output. -C For each array, the table below gives its internal name, -C its base address in RWORK, and its description. -C -C NAME BASE ADDRESS DESCRIPTION -C -C YH 21 The Nordsieck history array, of size NYH by -C (NQCUR + 1), where NYH is the initial value -C of NEQ. For j = 0,1,...,NQCUR, column j+1 -C of YH contains HCUR**j/factorial(j) times -C the j-th derivative of the interpolating -C polynomial currently representing the -C solution, evaluated at t = TCUR. -C -C ACOR LENRW-NEQ+1 Array of size NEQ used for the accumulated -C corrections on each step, scaled in the output -C to represent the estimated local error in Y -C on the last step. This is the vector e in -C the description of the error control. It is - -C defined only on a successful return from DVODE. -C -C----------------------------------------------------------------------- -C Interrupting and Restarting -C -C If the integration of a given problem by DVODE is to be -C interrrupted and then later continued, such as when restarting -C an interrupted run or alternating between two or more ODE problems, -C the user should save, following the return from the last DVODE call -C prior to the interruption, the contents of the call sequence -C variables and internal COMMON blocks, and later restore these -C values before the next DVODE call for that problem. To save -C and restore the COMMON blocks, use subroutine DVSRCO, as -C described below in part ii. -C -C In addition, if non-default values for either LUN or MFLAG are -C desired, an extra call to XSETUN and/or XSETF should be made just -C before continuing the integration. See Part ii below for details. -C -C----------------------------------------------------------------------- -C Part ii. Other Routines Callable. -C -C The following are optional calls which the user may make to -C gain additional capabilities in conjunction with DVODE. -C (The routines XSETUN and XSETF are designed to conform to the -C SLATEC error handling package.) -C -C FORM OF CALL FUNCTION -C CALL XSETUN(LUN) Set the logical unit number, LUN, for -C output of messages from DVODE, if -C the default is not desired. -C The default value of LUN is 6. -C -C CALL XSETF(MFLAG) Set a flag to control the printing of -C messages by DVODE. -C MFLAG = 0 means do not print. (Danger.. -C This risks losing valuable information.) -C MFLAG = 1 means print (the default). -C -C Either of the above calls may be made at -C any time and will take effect immediately. -C - -C CALL DVSRCO(RSAV,ISAV,JOB) Saves and restores the contents of -C the internal COMMON blocks used by - -C DVODE. (See Part iii below.) -C RSAV must be a real array of length 49 -C or more, and ISAV must be an integer -C array of length 40 or more. -C JOB=1 means save COMMON into RSAV/ISAV. -C JOB=2 means restore COMMON from RSAV/ISAV. -C DVSRCO is useful if one is -C interrupting a run and restarting -C later, or alternating between two or -C more problems solved with DVODE. -C -C CALL DVINDY(,,,,,) Provide derivatives of y, of various -C (See below.) orders, at a specified point T, if -C desired. It may be called only after -C a successful return from DVODE. -C -C The detailed instructions for using DVINDY are as follows. -C The form of the call is.. -C -C CALL DVINDY (T, K, RWORK(21), NYH, DKY, IFLAG) -C -C The input parameters are.. -C -C T = Value of independent variable where answers are desired -C (normally the same as the T last returned by DVODE). -C For valid results, T must lie between TCUR - HU and TCUR. -C (See optional output for TCUR and HU.) - -C K = Integer order of the derivative desired. K must satisfy -C 0 .le. K .le. NQCUR, where NQCUR is the current order -C (see optional output). The capability corresponding -C to K = 0, i.e. computing y(T), is already provided -C by DVODE directly. Since NQCUR .ge. 1, the first -C derivative dy/dt is always available with DVINDY. -C RWORK(21) = The base address of the history array YH. -C NYH = Column length of YH, equal to the initial value of NEQ. -C -C The output parameters are.. -C -C DKY = A real array of length NEQ containing the computed value -C of the K-th derivative of y(t). -C IFLAG = Integer flag, returned as 0 if K and T were legal, -C -1 if K was illegal, and -2 if T was illegal. -C On an error return, a message is also written. -C----------------------------------------------------------------------- -C Part iii. COMMON Blocks. -C If DVODE is to be used in an overlay situation, the user -C must declare, in the primary overlay, the variables in.. -C (1) the call sequence to DVODE, -C (2) the two internal COMMON blocks -C /DVOD01/ of length 81 (48 double precision words -C followed by 33 integer words), -C /DVOD02/ of length 9 (1 double precision word -C followed by 8 integer words), -C - -C If DVODE is used on a system in which the contents of internal -C COMMON blocks are not preserved between calls, the user should -C declare the above two COMMON blocks in his main program to insure -C that their contents are preserved. -C -C----------------------------------------------------------------------- -C Part iv. Optionally Replaceable Solver Routines. -C -C Below are descriptions of two routines in the DVODE package which -C relate to the measurement of errors. Either routine can be -C replaced by a user-supplied version, if desired. However, since such -C a replacement may have a major impact on performance, it should be -C done only when absolutely necessary, and only with great caution. -C (Note.. The means by which the package version of a routine is - - -C superseded by the user's version may be system-dependent.) -C - -C (a) DEWSET. -C The following subroutine is called just before each internal -C integration step, and sets the array of error weights, EWT, as -C described under ITOL/RTOL/ATOL above.. - -C SUBROUTINE DEWSET (NEQ, ITOL, RTOL, ATOL, YCUR, EWT) -C where NEQ, ITOL, RTOL, and ATOL are as in the DVODE call sequence, -C YCUR contains the current dependent variable vector, and -C EWT is the array of weights set by DEWSET. -C -C If the user supplies this subroutine, it must return in EWT(i) -C (i = 1,...,NEQ) a positive quantity suitable for comparison with -C errors in Y(i). The EWT array returned by DEWSET is passed to the -C DVNORM routine (See below.), and also used by DVODE in the computation -C of the optional output IMXER, the diagonal Jacobian approximation, -C and the increments for difference quotient Jacobians. -C -C In the user-supplied version of DEWSET, it may be desirable to use -C the current values of derivatives of y. Derivatives up to order NQ -C are available from the history array YH, described above under -C Optional Output. In DEWSET, YH is identical to the YCUR array, -C extended to NQ + 1 columns with a column length of NYH and scale -C factors of h**j/factorial(j). On the first call for the problem, -C given by NST = 0, NQ is 1 and H is temporarily set to 1.0. -C NYH is the initial value of NEQ. The quantities NQ, H, and NST -C can be obtained by including in DEWSET the statements.. -C DOUBLE PRECISION RVOD, H, HU -C COMMON /DVOD01/ RVOD(48), IVOD(33) -C COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST - -C NQ = IVOD(28) -C H = RVOD(21) -C Thus, for example, the current value of dy/dt can be obtained as -C YCUR(NYH+i)/H (i=1,...,NEQ) (and the division by H is -C unnecessary when NST = 0). -C -C (b) DVNORM. -C The following is a real function routine which computes the weighted -C root-mean-square norm of a vector v.. -C D = DVNORM (N, V, W) -C where.. - -C N = the length of the vector, -C V = real array of length N containing the vector, -C W = real array of length N containing weights, - -C D = sqrt( (1/N) * sum(V(i)*W(i))**2 ). -C DVNORM is called with N = NEQ and with W(i) = 1.0/EWT(i), where -C EWT is as set by subroutine DEWSET. - -C -C If the user supplies this function, it should return a non-negative -C value of DVNORM suitable for use in the error control in DVODE. -C None of the arguments should be altered by DVNORM. -C For example, a user-supplied DVNORM routine might.. -C -substitute a max-norm of (V(i)*W(i)) for the rms-norm, or -C -ignore some components of V in the norm, with the effect of -C suppressing the error control on those components of Y. -C----------------------------------------------------------------------- -C Other Routines in the DVODE Package. -C -C In addition to subroutine DVODE, the DVODE package includes the -C following subroutines and function routines.. -C DVHIN computes an approximate step size for the initial step. -C DVINDY computes an interpolated value of the y vector at t = TOUT. -C DVSTEP is the core integrator, which does one step of the -C integration and the associated error control. -C DVSET sets all method coefficients and test constants. -C DVNLSD solves the underlying nonlinear system -- the corrector. -C DVJAC computes and preprocesses the Jacobian matrix J = df/dy -C and the Newton iteration matrix P = I - (h/l1)*J. - -C DVSOL manages solution of linear system in chord iteration. - -C DVJUST adjusts the history array on a change of order. -C DEWSET sets the error weight vector EWT before each step. -C DVNORM computes the weighted r.m.s. norm of a vector. - -C DVSRCO is a user-callable routines to save and restore -C the contents of the internal COMMON blocks. -C DACOPY is a routine to copy one two-dimensional array to another. -C DGEFA and DGESL are routines from LINPACK for solving full -C systems of linear algebraic equations. -C DGBFA and DGBSL are routines from LINPACK for solving banded -C linear systems. -C DAXPY, DSCAL, and DCOPY are basic linear algebra modules (BLAS). -C D1MACH sets the unit roundoff of the machine. -C XERRWD, XSETUN, XSETF, LUNSAV, and MFLGSV handle the printing of all -C error messages and warnings. XERRWD is machine-dependent. -C Note.. DVNORM, D1MACH, LUNSAV, and MFLGSV are function routines. -C All the others are subroutines. -C -C The intrinsic and external routines used by the DVODE package are.. -C ABS, MAX, MIN, REAL, SIGN, SQRT, and WRITE. -C -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - DOUBLE PRECISION HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - EXTERNAL DVNLSD - LOGICAL IHIT - DOUBLE PRECISION ATOLI, BIG, EWTI, FOUR, H0, HMAX, HMX, HUN, ONE, - 1 PT2, RH, RTOLI, SIZE, TCRIT, TNEXT, TOLSF, TP, TWO, ZERO - INTEGER I, IER, IFLAG, IMXER, JCO, KGO, LENIW, LENJ, LENP, LENRW, - 1 LENWM, LF0, MBAND, ML, MORD, MU, MXHNL0, MXSTP0, NITER, NSLAST - CHARACTER*80 MSG - -C -C Type declaration for function subroutines called --------------------- -C - DOUBLE PRECISION D1MACH, DVNORM -C - - DIMENSION MORD(2) - -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to DVODE. -C----------------------------------------------------------------------- - SAVE MORD, MXHNL0, MXSTP0 - - SAVE ZERO, ONE, TWO, FOUR, PT2, HUN -C----------------------------------------------------------------------- -C The following internal COMMON blocks contain variables which are -C communicated between subroutines in the DVODE package, or which are - - -C to be saved between calls to DVODE. -C In each block, real variables precede integers. -C The block /DVOD01/ appears in subroutines DVODE, DVINDY, DVSTEP, -C DVSET, DVNLSD, DVJAC, DVSOL, DVJUST and DVSRCO. -C The block /DVOD02/ appears in subroutines DVODE, DVINDY, DVSTEP, -C DVNLSD, DVJAC, and DVSRCO. -C -C The variables stored in the internal COMMON blocks are as follows.. -C -C ACNRM = Weighted r.m.s. norm of accumulated correction vectors. -C CCMXJ = Threshhold on DRC for updating the Jacobian. (See DRC.) -C CONP = The saved value of TQ(5). -C CRATE = Estimated corrector convergence rate constant. -C DRC = Relative change in H*RL1 since last DVJAC call. -C EL = Real array of integration coefficients. See DVSET. -C ETA = Saved tentative ratio of new to old H. - -C ETAMAX = Saved maximum value of ETA to be allowed. -C H = The step size. -C HMIN = The minimum absolute value of the step size H to be used. -C HMXI = Inverse of the maximum absolute value of H to be used. -C HMXI = 0.0 is allowed and corresponds to an infinite HMAX. -C HNEW = The step size to be attempted on the next step. -C HSCAL = Stepsize in scaling of YH array. - -C PRL1 = The saved value of RL1. -C RC = Ratio of current H*RL1 to value on last DVJAC call. -C RL1 = The reciprocal of the coefficient EL(1). -C TAU = Real vector of past NQ step sizes, length 13. -C TQ = A real vector of length 5 in which DVSET stores constants -C used for the convergence test, the error test, and the -C selection of H at a new order. -C TN = The independent variable, updated on each step taken. -C UROUND = The machine unit roundoff. The smallest positive real number -C such that 1.0 + UROUND .ne. 1.0 -C ICF = Integer flag for convergence failure in DVNLSD.. -C 0 means no failures. - -C 1 means convergence failure with out of date Jacobian -C (recoverable error). -C 2 means convergence failure with current Jacobian or -C singular matrix (unrecoverable error). -C INIT = Saved integer flag indicating whether initialization of the -C problem has been done (INIT = 1) or not. -C IPUP = Saved flag to signal updating of Newton matrix. -C JCUR = Output flag from DVJAC showing Jacobian status.. -C JCUR = 0 means J is not current. -C JCUR = 1 means J is current. -C JSTART = Integer flag used as input to DVSTEP.. -C 0 means perform the first step. -C 1 means take a new step continuing from the last. -C -1 means take the next step with a new value of MAXORD, -C HMIN, HMXI, N, METH, MITER, and/or matrix parameters. -C On return, DVSTEP sets JSTART = 1. -C JSV = Integer flag for Jacobian saving, = sign(MF). -C KFLAG = A completion code from DVSTEP with the following meanings.. -C 0 the step was succesful. -C -1 the requested error could not be achieved. -C -2 corrector convergence could not be achieved. -C -3, -4 fatal error in VNLS (can not occur here). -C KUTH = Input flag to DVSTEP showing whether H was reduced by the -C driver. KUTH = 1 if H was reduced, = 0 otherwise. -C L = Integer variable, NQ + 1, current order plus one. -C LMAX = MAXORD + 1 (used for dimensioning). -C LOCJS = A pointer to the saved Jacobian, whose storage starts at -C WM(LOCJS), if JSV = 1. -C LYH, LEWT, LACOR, LSAVF, LWM, LIWM = Saved integer pointers -C to segments of RWORK and IWORK. -C MAXORD = The maximum order of integration method to be allowed. -C METH/MITER = The method flags. See MF. -C MSBJ = The maximum number of steps between J evaluations, = 50. -C MXHNIL = Saved value of optional input MXHNIL. -C MXSTEP = Saved value of optional input MXSTEP. -C N = The number of first-order ODEs, = NEQ. -C NEWH = Saved integer to flag change of H. -C NEWQ = The method order to be used on the next step. -C NHNIL = Saved counter for occurrences of T + H = T. -C NQ = Integer variable, the current integration method order. -C NQNYH = Saved value of NQ*NYH. -C NQWAIT = A counter controlling the frequency of order changes. -C An order change is about to be considered if NQWAIT = 1. -C NSLJ = The number of steps taken as of the last Jacobian update. - -C NSLP = Saved value of NST as of last Newton matrix update. -C NYH = Saved value of the initial value of NEQ. -C HU = The step size in t last used. -C NCFN = Number of nonlinear convergence failures so far. -C NETF = The number of error test failures of the integrator so far. -C NFE = The number of f evaluations for the problem so far. -C NJE = The number of Jacobian evaluations so far. -C NLU = The number of matrix LU decompositions so far. - -C NNI = Number of nonlinear iterations so far. -C NQU = The method order last used. -C NST = The number of steps taken for the problem so far. -C----------------------------------------------------------------------- - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - DATA MORD(1) /12/, MORD(2) /5/, MXSTP0 /500/, MXHNL0 /10/ - DATA ZERO /0.0D0/, ONE /1.0D0/, TWO /2.0D0/, FOUR /4.0D0/, - 1 PT2 /0.2D0/, HUN /100.0D0/ -C----------------------------------------------------------------------- -C Block A. -C This code block is executed on every call. -C It tests ISTATE and ITASK for legality and branches appropriately. -C If ISTATE .gt. 1 but the flag INIT shows that initialization has -C not yet been done, an error return occurs. -C If ISTATE = 1 and TOUT = T, return immediately. -C----------------------------------------------------------------------- - IF (ISTATE .LT. 1 .OR. ISTATE .GT. 3) GO TO 601 - IF (ITASK .LT. 1 .OR. ITASK .GT. 5) GO TO 602 - IF (ISTATE .EQ. 1) GO TO 10 - IF (INIT .NE. 1) GO TO 603 - IF (ISTATE .EQ. 2) GO TO 200 - GO TO 20 - 10 INIT = 0 - IF (TOUT .EQ. T) RETURN -C----------------------------------------------------------------------- -C Block B. -C The next code block is executed for the initial call (ISTATE = 1), -C or for a continuation call with parameter changes (ISTATE = 3). -C It contains checking of all input and various initializations. -C -C First check legality of the non-optional input NEQ, ITOL, IOPT, -C MF, ML, and MU. - -C----------------------------------------------------------------------- - 20 IF (NEQ .LE. 0) GO TO 604 - - IF (ISTATE .EQ. 1) GO TO 25 - IF (NEQ .GT. N) GO TO 605 - 25 N = NEQ - - IF (ITOL .LT. 1 .OR. ITOL .GT. 4) GO TO 606 - IF (IOPT .LT. 0 .OR. IOPT .GT. 1) GO TO 607 - JSV = SIGN(1,MF) - MF = ABS(MF) - METH = MF/10 - MITER = MF - 10*METH - IF (METH .LT. 1 .OR. METH .GT. 2) GO TO 608 - IF (MITER .LT. 0 .OR. MITER .GT. 5) GO TO 608 - IF (MITER .LE. 3) GO TO 30 - ML = IWORK(1) - MU = IWORK(2) - IF (ML .LT. 0 .OR. ML .GE. N) GO TO 609 - IF (MU .LT. 0 .OR. MU .GE. N) GO TO 610 - 30 CONTINUE -C Next process and check the optional input. --------------------------- - IF (IOPT .EQ. 1) GO TO 40 - MAXORD = MORD(METH) - MXSTEP = MXSTP0 - MXHNIL = MXHNL0 - IF (ISTATE .EQ. 1) H0 = ZERO - HMXI = ZERO - HMIN = ZERO - GO TO 60 - 40 MAXORD = IWORK(5) - IF (MAXORD .LT. 0) GO TO 611 - IF (MAXORD .EQ. 0) MAXORD = 100 - MAXORD = MIN(MAXORD,MORD(METH)) - MXSTEP = IWORK(6) - IF (MXSTEP .LT. 0) GO TO 612 - - IF (MXSTEP .EQ. 0) MXSTEP = MXSTP0 - MXHNIL = IWORK(7) - IF (MXHNIL .LT. 0) GO TO 613 - IF (MXHNIL .EQ. 0) MXHNIL = MXHNL0 - IF (ISTATE .NE. 1) GO TO 50 - H0 = RWORK(5) - - IF ((TOUT - T)*H0 .LT. ZERO) GO TO 614 - 50 HMAX = RWORK(6) - IF (HMAX .LT. ZERO) GO TO 615 - HMXI = ZERO - IF (HMAX .GT. ZERO) HMXI = ONE/HMAX - HMIN = RWORK(7) - IF (HMIN .LT. ZERO) GO TO 616 -C----------------------------------------------------------------------- -C Set work array pointers and check lengths LRW and LIW. -C Pointers to segments of RWORK and IWORK are named by prefixing L to -C the name of the segment. E.g., the segment YH starts at RWORK(LYH). -C Segments of RWORK (in order) are denoted YH, WM, EWT, SAVF, ACOR. -C Within WM, LOCJS is the location of the saved Jacobian (JSV .gt. 0). -C----------------------------------------------------------------------- - 60 LYH = 21 - IF (ISTATE .EQ. 1) NYH = N - LWM = LYH + (MAXORD + 1)*NYH - JCO = MAX(0,JSV) - IF (MITER .EQ. 0) LENWM = 0 - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN - LENWM = 2 + (1 + JCO)*N*N - LOCJS = N*N + 3 - ENDIF - IF (MITER .EQ. 3) LENWM = 2 + N - - IF (MITER .EQ. 4 .OR. MITER .EQ. 5) THEN - MBAND = ML + MU + 1 - LENP = (MBAND + ML)*N - LENJ = MBAND*N - - LENWM = 2 + LENP + JCO*LENJ - LOCJS = LENP + 3 - ENDIF - LEWT = LWM + LENWM - LSAVF = LEWT + N - LACOR = LSAVF + N - LENRW = LACOR + N - 1 - IWORK(17) = LENRW - LIWM = 1 - LENIW = 30 + N - IF (MITER .EQ. 0 .OR. MITER .EQ. 3) LENIW = 30 - IWORK(18) = LENIW - IF (LENRW .GT. LRW) GO TO 617 - IF (LENIW .GT. LIW) GO TO 618 -C Check RTOL and ATOL for legality. ------------------------------------ - RTOLI = RTOL - ATOLI = ATOL(1) - DO 70 I = 1,N - IF (ITOL .GE. 3) RTOLI = RTOL - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - IF (RTOLI .LT. ZERO) GO TO 619 - IF (ATOLI .LT. ZERO) GO TO 620 - 70 CONTINUE - IF (ISTATE .EQ. 1) GO TO 100 - -C If ISTATE = 3, set flag to signal parameter changes to DVSTEP. ------- - JSTART = -1 - IF (NQ .LE. MAXORD) GO TO 90 -C MAXORD was reduced below NQ. Copy YH(*,MAXORD+2) into SAVF. --------- - CALL DCOPY (N, RWORK(LWM), 1, RWORK(LSAVF), 1) -C Reload WM(1) = RWORK(LWM), since LWM may have changed. --------------- - 90 IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) -C----------------------------------------------------------------------- -C Block C. -C The next block is for the initial call only (ISTATE = 1). -C It contains all remaining initializations, the initial call to F, - -C and the calculation of the initial step size. -C The error weights in EWT are inverted after being loaded. -C----------------------------------------------------------------------- - 100 UROUND = D1MACH(4) - TN = T - - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 110 - TCRIT = RWORK(1) - IF ((TCRIT - TOUT)*(TOUT - T) .LT. ZERO) GO TO 625 - IF (H0 .NE. ZERO .AND. (T + H0 - TCRIT)*H0 .GT. ZERO) - 1 H0 = TCRIT - T - 110 JSTART = 0 - - IF (MITER .GT. 0) RWORK(LWM) = SQRT(UROUND) - CCMXJ = PT2 - MSBJ = 50 - NHNIL = 0 - NST = 0 - NJE = 0 - NNI = 0 - NCFN = 0 - NETF = 0 - NLU = 0 - NSLJ = 0 - NSLAST = 0 - HU = ZERO - NQU = 0 -C Initial call to F. (LF0 points to YH(*,2).) ------------------------- - LF0 = LYH + NYH - - CALL F (N, T, Y, RWORK(LF0), RPAR, IPAR) - NFE = 1 -C Load the initial value vector in YH. --------------------------------- - CALL DCOPY (N, Y, 1, RWORK(LYH), 1) -C Load and invert the EWT array. (H is temporarily set to 1.0.) ------- - NQ = 1 - H = ONE - CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 120 I = 1,N - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 621 - - 120 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - IF (H0 .NE. ZERO) GO TO 180 -C Call DVHIN to set initial step size H0 to be attempted. -------------- - CALL DVHIN (N, T, RWORK(LYH), RWORK(LF0), F, RPAR, IPAR, TOUT, - 1 UROUND, RWORK(LEWT), ITOL, ATOL, Y, RWORK(LACOR), H0, - 2 NITER, IER) - NFE = NFE + NITER - IF (IER .NE. 0) GO TO 622 -C Adjust H0 if necessary to meet HMAX bound. --------------------------- - 180 RH = ABS(H0)*HMXI - IF (RH .GT. ONE) H0 = H0/RH -C Load H with H0 and scale YH(*,2) by H0. ------------------------------ - H = H0 - CALL DSCAL (N, H0, RWORK(LF0), 1) - - GO TO 270 -C----------------------------------------------------------------------- -C Block D. -C The next code block is for continuation calls only (ISTATE = 2 or 3) -C and is to check stop conditions before taking a step. -C----------------------------------------------------------------------- - 200 NSLAST = NST - KUTH = 0 - GO TO (210, 250, 220, 230, 240), ITASK - 210 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 220 TP = TN - HU*(ONE + HUN*UROUND) - - IF ((TP - TOUT)*H .GT. ZERO) GO TO 623 - - IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - GO TO 400 - 230 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - IF ((TCRIT - TOUT)*H .LT. ZERO) GO TO 625 - - IF ((TN - TOUT)*H .LT. ZERO) GO TO 245 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - IF (IFLAG .NE. 0) GO TO 627 - T = TOUT - GO TO 420 - 240 TCRIT = RWORK(1) - IF ((TN - TCRIT)*H .GT. ZERO) GO TO 624 - 245 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + HNEW*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - KUTH = 1 -C----------------------------------------------------------------------- -C Block E. -C The next block is normally executed for all calls and contains -C the call to the one-step core integrator DVSTEP. -C - - -C This is a looping point for the integration steps. - -C -C First check for too many steps being taken, update EWT (if not at -C start of problem), check for too much accuracy being requested, and -C check for H below the roundoff level in T. -C----------------------------------------------------------------------- - 250 CONTINUE - IF ((NST-NSLAST) .GE. MXSTEP) GO TO 500 - CALL DEWSET (N, ITOL, RTOL, ATOL, RWORK(LYH), RWORK(LEWT)) - DO 260 I = 1,N - IF (RWORK(I+LEWT-1) .LE. ZERO) GO TO 510 - 260 RWORK(I+LEWT-1) = ONE/RWORK(I+LEWT-1) - 270 TOLSF = UROUND*DVNORM (N, RWORK(LYH), RWORK(LEWT)) - IF (TOLSF .LE. ONE) GO TO 280 - TOLSF = TOLSF*TWO - IF (NST .EQ. 0) GO TO 626 - GO TO 520 - 280 IF ((TN + H) .NE. TN) GO TO 290 - NHNIL = NHNIL + 1 - IF (NHNIL .GT. MXHNIL) GO TO 290 - MSG = 'DVODE-- Warning..internal T (=R1) and H (=R2) are' - CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG=' such that in the machine, T + H = T on the next step ' - CALL XERRWD (MSG, 60, 101, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' (H = step size). solver will continue anyway' - CALL XERRWD (MSG, 50, 101, 1, 0, 0, 0, 2, TN, H) - IF (NHNIL .LT. MXHNIL) GO TO 290 - MSG = 'DVODE-- Above warning has been issued I1 times. ' - CALL XERRWD (MSG, 50, 102, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' it will not be issued again for this problem' - CALL XERRWD (MSG, 50, 102, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) - 290 CONTINUE -C----------------------------------------------------------------------- -C CALL DVSTEP (Y, YH, NYH, YH, EWT, SAVF, VSAV, ACOR, -C WM, IWM, F, JAC, F, DVNLSD, RPAR, IPAR) -C----------------------------------------------------------------------- - CALL DVSTEP (Y, RWORK(LYH), NYH, RWORK(LYH), RWORK(LEWT), - 1 RWORK(LSAVF), Y, RWORK(LACOR), RWORK(LWM), IWORK(LIWM), - - 2 F, JAC, F, DVNLSD, RPAR, IPAR) - KGO = 1 - KFLAG -C Branch on KFLAG. Note..In this version, KFLAG can not be set to -3. -C KFLAG .eq. 0, -1, -2 - GO TO (300, 530, 540), KGO -C----------------------------------------------------------------------- -C Block F. -C The following block handles the case of a successful return from the -C core integrator (KFLAG = 0). Test for stop conditions. -C----------------------------------------------------------------------- - - - 300 INIT = 1 - KUTH = 0 - GO TO (310, 400, 330, 340, 350), ITASK -C ITASK = 1. If TOUT has been reached, interpolate. ------------------- - 310 IF ((TN - TOUT)*H .LT. ZERO) GO TO 250 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - - T = TOUT - GO TO 420 -C ITASK = 3. Jump to exit if TOUT was reached. ------------------------ - 330 IF ((TN - TOUT)*H .GE. ZERO) GO TO 400 - GO TO 250 -C ITASK = 4. See if TOUT or TCRIT was reached. Adjust H if necessary. - 340 IF ((TN - TOUT)*H .LT. ZERO) GO TO 345 - CALL DVINDY (TOUT, 0, RWORK(LYH), NYH, Y, IFLAG) - T = TOUT - GO TO 420 - 345 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX - IF (IHIT) GO TO 400 - TNEXT = TN + HNEW*(ONE + FOUR*UROUND) - IF ((TNEXT - TCRIT)*H .LE. ZERO) GO TO 250 - H = (TCRIT - TN)*(ONE - FOUR*UROUND) - KUTH = 1 - GO TO 250 -C ITASK = 5. See if TCRIT was reached and jump to exit. --------------- - - 350 HMX = ABS(TN) + ABS(H) - IHIT = ABS(TN - TCRIT) .LE. HUN*UROUND*HMX -C----------------------------------------------------------------------- -C Block G. -C The following block handles all successful returns from DVODE. -C If ITASK .ne. 1, Y is loaded from YH and T is set accordingly. -C ISTATE is set to 2, and the optional output is loaded into the work -C arrays before returning. -C----------------------------------------------------------------------- - 400 CONTINUE - CALL DCOPY (N, RWORK(LYH), 1, Y, 1) - T = TN - IF (ITASK .NE. 4 .AND. ITASK .NE. 5) GO TO 420 - IF (IHIT) T = TCRIT - 420 ISTATE = 2 - RWORK(11) = HU - RWORK(12) = HNEW - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NEWQ - IWORK(19) = NLU - IWORK(20) = NNI - IWORK(21) = NCFN - IWORK(22) = NETF - RETURN -C----------------------------------------------------------------------- -C Block H. -C The following block handles all unsuccessful returns other than -C those for illegal input. First the error message routine is called. -C if there was an error test or convergence test failure, IMXER is set. -C Then Y is loaded from YH, T is set to TN, and the illegal input -C The optional output is loaded into the work arrays before returning. -C----------------------------------------------------------------------- -C The maximum number of steps was taken before reaching TOUT. ---------- - 500 MSG = 'DVODE-- At current T (=R1), MXSTEP (=I1) steps ' - CALL XERRWD (MSG, 50, 201, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' taken on this call before reaching TOUT ' - CALL XERRWD (MSG, 50, 201, 1, 1, MXSTEP, 0, 1, TN, ZERO) - ISTATE = -1 - GO TO 580 -C EWT(i) .le. 0.0 for some i (not at start of problem). ---------------- - 510 EWTI = RWORK(LEWT+I-1) - MSG = 'DVODE-- At T (=R1), EWT(I1) has become R2 .le. 0.' - CALL XERRWD (MSG, 50, 202, 1, 1, I, 0, 2, TN, EWTI) - ISTATE = -6 - GO TO 580 -C Too much accuracy requested for machine precision. ------------------- - 520 MSG = 'DVODE-- At T (=R1), too much accuracy requested ' - CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' for precision of machine.. see TOLSF (=R2) ' - CALL XERRWD (MSG, 50, 203, 1, 0, 0, 0, 2, TN, TOLSF) - RWORK(14) = TOLSF - ISTATE = -2 - GO TO 580 -C KFLAG = -1. Error test failed repeatedly or with ABS(H) = HMIN. ----- - 530 MSG = 'DVODE-- At T(=R1) and step size H(=R2), the error' - CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' test failed repeatedly or with abs(H) = HMIN' - CALL XERRWD (MSG, 50, 204, 1, 0, 0, 0, 2, TN, H) - ISTATE = -4 - GO TO 560 -C KFLAG = -2. Convergence failed repeatedly or with abs(H) = HMIN. ---- - 540 MSG = 'DVODE-- At T (=R1) and step size H (=R2), the ' - CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' corrector convergence failed repeatedly ' - CALL XERRWD (MSG, 50, 205, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG = ' or with abs(H) = HMIN ' - CALL XERRWD (MSG, 30, 205, 1, 0, 0, 0, 2, TN, H) - ISTATE = -5 -C Compute IMXER if relevant. ------------------------------------------- - 560 BIG = ZERO - IMXER = 1 - DO 570 I = 1,N - SIZE = ABS(RWORK(I+LACOR-1)*RWORK(I+LEWT-1)) - IF (BIG .GE. SIZE) GO TO 570 - BIG = SIZE - IMXER = I - 570 CONTINUE - IWORK(16) = IMXER -C Set Y vector, T, and optional output. -------------------------------- - 580 CONTINUE - CALL DCOPY (N, RWORK(LYH), 1, Y, 1) - T = TN - RWORK(11) = HU - RWORK(12) = H - RWORK(13) = TN - IWORK(11) = NST - IWORK(12) = NFE - IWORK(13) = NJE - IWORK(14) = NQU - IWORK(15) = NQ - IWORK(19) = NLU - IWORK(20) = NNI - IWORK(21) = NCFN - IWORK(22) = NETF - RETURN -C----------------------------------------------------------------------- -C Block I. - -C The following block handles all error returns due to illegal input -C (ISTATE = -3), as detected before calling the core integrator. -C First the error message routine is called. If the illegal input -C is a negative ISTATE, the run is aborted (apparent infinite loop). -C----------------------------------------------------------------------- - 601 MSG = 'DVODE-- ISTATE (=I1) illegal ' - CALL XERRWD (MSG, 30, 1, 1, 1, ISTATE, 0, 0, ZERO, ZERO) - IF (ISTATE .LT. 0) GO TO 800 - GO TO 700 - - - 602 MSG = 'DVODE-- ITASK (=I1) illegal ' - CALL XERRWD (MSG, 30, 2, 1, 1, ITASK, 0, 0, ZERO, ZERO) - GO TO 700 - 603 MSG='DVODE-- ISTATE (=I1) .gt. 1 but DVODE not initialized ' - CALL XERRWD (MSG, 60, 3, 1, 1, ISTATE, 0, 0, ZERO, ZERO) - GO TO 700 - 604 MSG = 'DVODE-- NEQ (=I1) .lt. 1 ' - CALL XERRWD (MSG, 30, 4, 1, 1, NEQ, 0, 0, ZERO, ZERO) - GO TO 700 - - 605 MSG = 'DVODE-- ISTATE = 3 and NEQ increased (I1 to I2) ' - CALL XERRWD (MSG, 50, 5, 1, 2, N, NEQ, 0, ZERO, ZERO) - GO TO 700 - - 606 MSG = 'DVODE-- ITOL (=I1) illegal ' - CALL XERRWD (MSG, 30, 6, 1, 1, ITOL, 0, 0, ZERO, ZERO) - GO TO 700 - 607 MSG = 'DVODE-- IOPT (=I1) illegal ' - CALL XERRWD (MSG, 30, 7, 1, 1, IOPT, 0, 0, ZERO, ZERO) - GO TO 700 - 608 MSG = 'DVODE-- MF (=I1) illegal ' - CALL XERRWD (MSG, 30, 8, 1, 1, MF, 0, 0, ZERO, ZERO) - GO TO 700 - 609 MSG = 'DVODE-- ML (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' - CALL XERRWD (MSG, 50, 9, 1, 2, ML, NEQ, 0, ZERO, ZERO) - - - GO TO 700 - 610 MSG = 'DVODE-- MU (=I1) illegal.. .lt.0 or .ge.NEQ (=I2)' - CALL XERRWD (MSG, 50, 10, 1, 2, MU, NEQ, 0, ZERO, ZERO) - GO TO 700 - 611 MSG = 'DVODE-- MAXORD (=I1) .lt. 0 ' - CALL XERRWD (MSG, 30, 11, 1, 1, MAXORD, 0, 0, ZERO, ZERO) - GO TO 700 - 612 MSG = 'DVODE-- MXSTEP (=I1) .lt. 0 ' - CALL XERRWD (MSG, 30, 12, 1, 1, MXSTEP, 0, 0, ZERO, ZERO) - GO TO 700 - 613 MSG = 'DVODE-- MXHNIL (=I1) .lt. 0 ' - CALL XERRWD (MSG, 30, 13, 1, 1, MXHNIL, 0, 0, ZERO, ZERO) - GO TO 700 - 614 MSG = 'DVODE-- TOUT (=R1) behind T (=R2) ' - CALL XERRWD (MSG, 40, 14, 1, 0, 0, 0, 2, TOUT, T) - MSG = ' integration direction is given by H0 (=R1) ' - CALL XERRWD (MSG, 50, 14, 1, 0, 0, 0, 1, H0, ZERO) - GO TO 700 - 615 MSG = 'DVODE-- HMAX (=R1) .lt. 0.0 ' - CALL XERRWD (MSG, 30, 15, 1, 0, 0, 0, 1, HMAX, ZERO) - GO TO 700 - 616 MSG = 'DVODE-- HMIN (=R1) .lt. 0.0 ' - CALL XERRWD (MSG, 30, 16, 1, 0, 0, 0, 1, HMIN, ZERO) - GO TO 700 - 617 CONTINUE - MSG='DVODE-- RWORK length needed, LENRW (=I1), exceeds LRW (=I2)' - CALL XERRWD (MSG, 60, 17, 1, 2, LENRW, LRW, 0, ZERO, ZERO) - GO TO 700 - 618 CONTINUE - MSG='DVODE-- IWORK length needed, LENIW (=I1), exceeds LIW (=I2)' - CALL XERRWD (MSG, 60, 18, 1, 2, LENIW, LIW, 0, ZERO, ZERO) - - GO TO 700 - 619 MSG = 'DVODE-- RTOL is R1 .lt. 0.0 ' - CALL XERRWD (MSG, 40, 19, 1, 1, I, 0, 1, RTOLI, ZERO) - GO TO 700 - 620 MSG = 'DVODE-- ATOL(I1) is R1 .lt. 0.0 ' - CALL XERRWD (MSG, 40, 20, 1, 1, I, 0, 1, ATOLI, ZERO) - - GO TO 700 - - 621 EWTI = RWORK(LEWT+I-1) - MSG = 'DVODE-- EWT(I1) is R1 .le. 0.0 ' - CALL XERRWD (MSG, 40, 21, 1, 1, I, 0, 1, EWTI, ZERO) - GO TO 700 - 622 CONTINUE - MSG='DVODE-- TOUT (=R1) too close to T(=R2) to start integration' - CALL XERRWD (MSG, 60, 22, 1, 0, 0, 0, 2, TOUT, T) - GO TO 700 - 623 CONTINUE - MSG='DVODE-- ITASK = I1 and TOUT (=R1) behind TCUR - HU (= R2) ' - CALL XERRWD (MSG, 60, 23, 1, 1, ITASK, 0, 2, TOUT, TP) - GO TO 700 - 624 CONTINUE - - MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TCUR (=R2) ' - CALL XERRWD (MSG, 60, 24, 1, 0, 0, 0, 2, TCRIT, TN) - GO TO 700 - 625 CONTINUE - MSG='DVODE-- ITASK = 4 or 5 and TCRIT (=R1) behind TOUT (=R2) ' - CALL XERRWD (MSG, 60, 25, 1, 0, 0, 0, 2, TCRIT, TOUT) - GO TO 700 - - 626 MSG = 'DVODE-- At start of problem, too much accuracy ' - CALL XERRWD (MSG, 50, 26, 1, 0, 0, 0, 0, ZERO, ZERO) - MSG=' requested for precision of machine.. see TOLSF (=R1) ' - CALL XERRWD (MSG, 60, 26, 1, 0, 0, 0, 1, TOLSF, ZERO) - RWORK(14) = TOLSF - GO TO 700 - 627 MSG='DVODE-- Trouble from DVINDY. ITASK = I1, TOUT = R1. ' - CALL XERRWD (MSG, 60, 27, 1, 1, ITASK, 0, 1, TOUT, ZERO) -C - 700 CONTINUE - ISTATE = -3 - RETURN -C - 800 MSG = 'DVODE-- Run aborted.. apparent infinite loop ' - CALL XERRWD (MSG, 50, 303, 2, 0, 0, 0, 0, ZERO, ZERO) - RETURN -C----------------------- End of Subroutine DVODE ----------------------- - END -*DECK DVHIN - SUBROUTINE DVHIN (N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, - 1 EWT, ITOL, ATOL, Y, TEMP, H0, NITER, IER) - EXTERNAL F - DOUBLE PRECISION T0, Y0, YDOT, RPAR, TOUT, UROUND, EWT, ATOL, Y, - 1 TEMP, H0 - INTEGER N, IPAR, ITOL, NITER, IER - DIMENSION Y0(*), YDOT(*), EWT(*), ATOL(*), Y(*), - 1 TEMP(*) -C----------------------------------------------------------------------- -C Call sequence input -- N, T0, Y0, YDOT, F, RPAR, IPAR, TOUT, UROUND, -C EWT, ITOL, ATOL, Y, TEMP -C Call sequence output -- H0, NITER, IER -C COMMON block variables accessed -- None -C -C Subroutines called by DVHIN.. F -C Function routines called by DVHIN.. DVNORM -C----------------------------------------------------------------------- -C This routine computes the step size, H0, to be attempted on the -C first step, when the user has not supplied a value for this. -C -C First we check that TOUT - T0 differs significantly from zero. Then -C an iteration is done to approximate the initial second derivative -C and this is used to define h from w.r.m.s.norm(h**2 * yddot / 2) = 1. -C A bias factor of 1/2 is applied to the resulting h. -C The sign of H0 is inferred from the initial values of TOUT and T0. -C -C Communication with DVHIN is done with the following variables.. -C -C N = Size of ODE system, input. -C T0 = Initial value of independent variable, input. -C Y0 = Vector of initial conditions, input. -C YDOT = Vector of initial first derivatives, input. -C F = Name of subroutine for right-hand side f(t,y), input. -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C TOUT = First output value of independent variable -C UROUND = Machine unit roundoff -C EWT, ITOL, ATOL = Error weights and tolerance parameters -C as described in the driver routine, input. -C Y, TEMP = Work arrays of length N. -C H0 = Step size to be attempted, output. -C NITER = Number of iterations (and of f evaluations) to compute H0, -C output. -C IER = The error flag, returned with the value -C IER = 0 if no trouble occurred, or -C IER = -1 if TOUT and T0 are considered too close to proceed. -C----------------------------------------------------------------------- -C -C Type declarations for local variables -------------------------------- -C - DOUBLE PRECISION AFI, ATOLI, DELYI, HALF, HG, HLB, HNEW, HRAT, - 1 HUB, HUN, PT1, T1, TDIST, TROUND, TWO, YDDNRM - - INTEGER I, ITER -C -C Type declaration for function subroutines called --------------------- -C - DOUBLE PRECISION DVNORM -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE HALF, HUN, PT1, TWO - DATA HALF /0.5D0/, HUN /100.0D0/, PT1 /0.1D0/, TWO /2.0D0/ -C - - NITER = 0 - TDIST = ABS(TOUT - T0) - TROUND = UROUND*MAX(ABS(T0),ABS(TOUT)) - IF (TDIST .LT. TWO*TROUND) GO TO 100 -C -C Set a lower bound on h based on the roundoff level in T0 and TOUT. --- - HLB = HUN*TROUND -C Set an upper bound on h based on TOUT-T0 and the initial Y and YDOT. - - HUB = PT1*TDIST - ATOLI = ATOL(1) - DO 10 I = 1, N - IF (ITOL .EQ. 2 .OR. ITOL .EQ. 4) ATOLI = ATOL(I) - DELYI = PT1*ABS(Y0(I)) + ATOLI - AFI = ABS(YDOT(I)) - IF (AFI*HUB .GT. DELYI) HUB = DELYI/AFI - 10 CONTINUE -C -C Set initial guess for h as geometric mean of upper and lower bounds. - - ITER = 0 - HG = SQRT(HLB*HUB) -C If the bounds have crossed, exit with the mean value. ---------------- - IF (HUB .LT. HLB) THEN - H0 = HG - GO TO 90 - ENDIF -C -C Looping point for iteration. ----------------------------------------- - 50 CONTINUE -C Estimate the second derivative as a difference quotient in f. -------- - T1 = T0 + HG - DO 60 I = 1, N - 60 Y(I) = Y0(I) + HG*YDOT(I) - CALL F (N, T1, Y, TEMP, RPAR, IPAR) - DO 70 I = 1, N - 70 TEMP(I) = (TEMP(I) - YDOT(I))/HG - YDDNRM = DVNORM (N, TEMP, EWT) -C Get the corresponding new value of h. -------------------------------- - IF (YDDNRM*HUB*HUB .GT. TWO) THEN - HNEW = SQRT(TWO/YDDNRM) - ELSE - HNEW = SQRT(HG*HUB) - ENDIF - ITER = ITER + 1 -C----------------------------------------------------------------------- -C Test the stopping conditions. -C Stop if the new and previous h values differ by a factor of .lt. 2. -C Stop if four iterations have been done. Also, stop with previous h -C if HNEW/HG .gt. 2 after first iteration, as this probably means that -C the second derivative value is bad because of cancellation error. -C----------------------------------------------------------------------- - IF (ITER .GE. 4) GO TO 80 - HRAT = HNEW/HG - IF ( (HRAT .GT. HALF) .AND. (HRAT .LT. TWO) ) GO TO 80 - IF ( (ITER .GE. 2) .AND. (HNEW .GT. TWO*HG) ) THEN - HNEW = HG - GO TO 80 - ENDIF - HG = HNEW - GO TO 50 -C -C Iteration done. Apply bounds, bias factor, and sign. Then exit. ---- - 80 H0 = HNEW*HALF - IF (H0 .LT. HLB) H0 = HLB - IF (H0 .GT. HUB) H0 = HUB - 90 H0 = SIGN(H0, TOUT - T0) - NITER = ITER - IER = 0 - RETURN -C Error return for TOUT - T0 too small. -------------------------------- - 100 IER = -1 - RETURN -C----------------------- End of Subroutine DVHIN ----------------------- - END -*DECK DVINDY - SUBROUTINE DVINDY (T, K, YH, LDYH, DKY, IFLAG) - DOUBLE PRECISION T, YH, DKY - INTEGER K, LDYH, IFLAG - DIMENSION YH(LDYH,*), DKY(*) -C----------------------------------------------------------------------- -C Call sequence input -- T, K, YH, LDYH - -C Call sequence output -- DKY, IFLAG -C COMMON block variables accessed.. -C /DVOD01/ -- H, TN, UROUND, L, N, NQ -C /DVOD02/ -- HU -C -C Subroutines called by DVINDY.. DSCAL, XERRWD -C Function routines called by DVINDY.. None -C----------------------------------------------------------------------- -C DVINDY computes interpolated values of the K-th derivative of the -C dependent variable vector y, and stores it in DKY. This routine -C is called within the package with K = 0 and T = TOUT, but may -C also be called by the user for any K up to the current order. -C (See detailed instructions in the usage documentation.) -C----------------------------------------------------------------------- -C The computed values in DKY are gotten by interpolation using the -C Nordsieck history array YH. This array corresponds uniquely to a -C vector-valued polynomial of degree NQCUR or less, and DKY is set -C to the K-th derivative of this polynomial at T. -C The formula for DKY is.. -C q -C DKY(i) = sum c(j,K) * (T - TN)**(j-K) * H**(-j) * YH(i,j+1) -C j=K -C where c(j,K) = j*(j-1)*...*(j-K+1), q = NQCUR, TN = TCUR, H = HCUR. -C The quantities NQ = NQCUR, L = NQ+1, N, TN, and H are -C communicated by COMMON. The above sum is done in reverse order. -C IFLAG is returned negative if either K or T is out of bounds. -C -C Discussion above and comments in driver explain all variables. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - DOUBLE PRECISION HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - DOUBLE PRECISION C, HUN, R, S, TFUZZ, TN1, TP, ZERO - INTEGER I, IC, J, JB, JB2, JJ, JJ1, JP1 - CHARACTER*80 MSG -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE HUN, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - DATA HUN /100.0D0/, ZERO /0.0D0/ -C - IFLAG = 0 - IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80 - TFUZZ = HUN*UROUND*(TN + HU) - TP = TN - HU - TFUZZ - - TN1 = TN + TFUZZ - - IF ((T-TP)*(T-TN1) .GT. ZERO) GO TO 90 -C - S = (T - TN)/H - IC = 1 - IF (K .EQ. 0) GO TO 15 - JJ1 = L - K - DO 10 JJ = JJ1, NQ - 10 IC = IC*JJ - 15 C = REAL(IC) - DO 20 I = 1, N - 20 DKY(I) = C*YH(I,L) - IF (K .EQ. NQ) GO TO 55 - - JB2 = NQ - K - DO 50 JB = 1, JB2 - J = NQ - JB - JP1 = J + 1 - - - IC = 1 - IF (K .EQ. 0) GO TO 35 - JJ1 = JP1 - K - DO 30 JJ = JJ1, J - 30 IC = IC*JJ - 35 C = REAL(IC) - DO 40 I = 1, N - 40 DKY(I) = C*YH(I,JP1) + S*DKY(I) - 50 CONTINUE - IF (K .EQ. 0) RETURN - 55 R = H**(-K) - CALL DSCAL (N, R, DKY, 1) - RETURN -C - 80 MSG = 'DVINDY-- K (=I1) illegal ' - CALL XERRWD (MSG, 30, 51, 1, 1, K, 0, 0, ZERO, ZERO) - IFLAG = -1 - RETURN - 90 MSG = 'DVINDY-- T (=R1) illegal ' - CALL XERRWD (MSG, 30, 52, 1, 0, 0, 0, 1, T, ZERO) - MSG=' T not in interval TCUR - HU (= R1) to TCUR (=R2) ' - CALL XERRWD (MSG, 60, 52, 1, 0, 0, 0, 2, TP, TN) - IFLAG = -2 - RETURN -C----------------------- End of Subroutine DVINDY ---------------------- - END -*DECK DVSTEP - SUBROUTINE DVSTEP (Y, YH, LDYH, YH1, EWT, SAVF, VSAV, ACOR, - 1 WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR) - EXTERNAL F, JAC, PSOL, VNLS - DOUBLE PRECISION Y, YH, YH1, EWT, SAVF, VSAV, ACOR, WM, RPAR - INTEGER LDYH, IWM, IPAR - DIMENSION Y(*), YH(LDYH,*), YH1(*), EWT(*), SAVF(*), VSAV(*), - 1 ACOR(*), WM(*), IWM(*) -C----------------------------------------------------------------------- -C Call sequence input -- Y, YH, LDYH, YH1, EWT, SAVF, VSAV, -C ACOR, WM, IWM, F, JAC, PSOL, VNLS, RPAR, IPAR -C Call sequence output -- YH, ACOR, WM, IWM -C COMMON block variables accessed.. -C /DVOD01/ ACNRM, EL(13), H, HMIN, HMXI, HNEW, HSCAL, RC, TAU(13), -C TQ(5), TN, JCUR, JSTART, KFLAG, KUTH, -C L, LMAX, MAXORD, MITER, N, NEWQ, NQ, NQWAIT -C /DVOD02/ HU, NCFN, NETF, NFE, NQU, NST -C -C Subroutines called by DVSTEP.. F, DAXPY, DCOPY, DSCAL, -C DVJUST, VNLS, DVSET -C Function routines called by DVSTEP.. DVNORM -C----------------------------------------------------------------------- -C DVSTEP performs one step of the integration of an initial value -C problem for a system of ordinary differential equations. -C DVSTEP calls subroutine VNLS for the solution of the nonlinear system -C arising in the time step. Thus it is independent of the problem -C Jacobian structure and the type of nonlinear system solution method. -C DVSTEP returns a completion flag KFLAG (in COMMON). -C A return with KFLAG = -1 or -2 means either ABS(H) = HMIN or 10 -C consecutive failures occurred. On a return with KFLAG negative, -C the values of TN and the YH array are as of the beginning of the last - -C step, and H is the last step size attempted. -C -C Communication with DVSTEP is done with the following variables.. -C -C Y = An array of length N used for the dependent variable vector. -C YH = An LDYH by LMAX array containing the dependent variables -C and their approximate scaled derivatives, where -C LMAX = MAXORD + 1. YH(i,j+1) contains the approximate -C j-th derivative of y(i), scaled by H**j/factorial(j) -C (j = 0,1,...,NQ). On entry for the first step, the first -C two columns of YH must be set from the initial values. -C LDYH = A constant integer .ge. N, the first dimension of YH. -C N is the number of ODEs in the system. -C YH1 = A one-dimensional array occupying the same space as YH. - -C EWT = An array of length N containing multiplicative weights -C for local error measurements. Local errors in y(i) are -C compared to 1.0/EWT(i) in various error tests. -C SAVF = An array of working storage, of length N. - - -C also used for input of YH(*,MAXORD+2) when JSTART = -1 -C and MAXORD .lt. the current order NQ. -C VSAV = A work array of length N passed to subroutine VNLS. -C ACOR = A work array of length N, used for the accumulated -C corrections. On a successful return, ACOR(i) contains -C the estimated one-step local error in y(i). -C WM,IWM = Real and integer work arrays associated with matrix -C operations in VNLS. -C F = Dummy name for the user supplied subroutine for f. -C JAC = Dummy name for the user supplied Jacobian subroutine. -C PSOL = Dummy name for the subroutine passed to VNLS, for -C possible use there. -C VNLS = Dummy name for the nonlinear system solving subroutine, -C whose real name is dependent on the method used. -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH - -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - - DOUBLE PRECISION HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - DOUBLE PRECISION ADDON, BIAS1,BIAS2,BIAS3, CNQUOT, DDN, DSM, DUP, - - - 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, - 2 ETAQ, ETAQM1, ETAQP1, FLOTL, ONE, ONEPSM, - 3 R, THRESH, TOLD, ZERO - INTEGER I, I1, I2, IBACK, J, JB, KFC, KFH, MXNCF, NCF, NFLAG -C -C Type declaration for function subroutines called --------------------- -C - DOUBLE PRECISION DVNORM -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE ADDON, BIAS1, BIAS2, BIAS3, - - 1 ETACF, ETAMIN, ETAMX1, ETAMX2, ETAMX3, ETAMXF, - 2 KFC, KFH, MXNCF, ONEPSM, THRESH, ONE, ZERO -C----------------------------------------------------------------------- - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - - DATA KFC/-3/, KFH/-7/, MXNCF/10/ - DATA ADDON /1.0D-6/, BIAS1 /6.0D0/, BIAS2 /6.0D0/, - 1 BIAS3 /10.0D0/, ETACF /0.25D0/, ETAMIN /0.1D0/, - 2 ETAMXF /0.2D0/, ETAMX1 /1.0D4/, ETAMX2 /10.0D0/, - 3 ETAMX3 /10.0D0/, ONEPSM /1.00001D0/, THRESH /1.5D0/ - DATA ONE/1.0D0/, ZERO/0.0D0/ -C - KFLAG = 0 - TOLD = TN - NCF = 0 - JCUR = 0 - NFLAG = 0 - IF (JSTART .GT. 0) GO TO 20 - IF (JSTART .EQ. -1) GO TO 100 -C----------------------------------------------------------------------- -C On the first call, the order is set to 1, and other variables are -C initialized. ETAMAX is the maximum ratio by which H can be increased -C in a single step. It is normally 1.5, but is larger during the -C first 10 steps to compensate for the small initial H. If a failure -C occurs (in corrector convergence or error test), ETAMAX is set to 1 -C for the next increase. -C----------------------------------------------------------------------- - LMAX = MAXORD + 1 - NQ = 1 - L = 2 - NQNYH = NQ*LDYH - TAU(1) = H - PRL1 = ONE - RC = ZERO - ETAMAX = ETAMX1 - NQWAIT = 2 - HSCAL = H - GO TO 200 -C----------------------------------------------------------------------- -C Take preliminary actions on a normal continuation step (JSTART.GT.0). - - -C If the driver changed H, then ETA must be reset and NEWH set to 1. -C If a change of order was dictated on the previous step, then -C it is done here and appropriate adjustments in the history are made. -C On an order decrease, the history array is adjusted by DVJUST. -C On an order increase, the history array is augmented by a column. -C On a change of step size H, the history array YH is rescaled. -C----------------------------------------------------------------------- - 20 CONTINUE - - IF (KUTH .EQ. 1) THEN - ETA = MIN(ETA,H/HSCAL) - NEWH = 1 - ENDIF - 50 IF (NEWH .EQ. 0) GO TO 200 - IF (NEWQ .EQ. NQ) GO TO 150 - IF (NEWQ .LT. NQ) THEN - CALL DVJUST (YH, LDYH, -1) - NQ = NEWQ - L = NQ + 1 - NQWAIT = L - GO TO 150 - ENDIF - IF (NEWQ .GT. NQ) THEN - CALL DVJUST (YH, LDYH, 1) - NQ = NEWQ - L = NQ + 1 - NQWAIT = L - GO TO 150 - ENDIF -C----------------------------------------------------------------------- -C The following block handles preliminaries needed when JSTART = -1. -C If N was reduced, zero out part of YH to avoid undefined references. -C If MAXORD was reduced to a value less than the tentative order NEWQ, -C then NQ is set to MAXORD, and a new H ratio ETA is chosen. -C Otherwise, we take the same preliminary actions as for JSTART .gt. 0. -C In any case, NQWAIT is reset to L = NQ + 1 to prevent further -C changes in order for that many steps. -C The new H ratio ETA is limited by the input H if KUTH = 1, -C by HMIN if KUTH = 0, and by HMXI in any case. -C Finally, the history array YH is rescaled. -C----------------------------------------------------------------------- - 100 CONTINUE - LMAX = MAXORD + 1 - IF (N .EQ. LDYH) GO TO 120 - I1 = 1 + (NEWQ + 1)*LDYH - I2 = (MAXORD + 1)*LDYH - IF (I1 .GT. I2) GO TO 120 - DO 110 I = I1, I2 - 110 YH1(I) = ZERO - 120 IF (NEWQ .LE. MAXORD) GO TO 140 - FLOTL = REAL(LMAX) - IF (MAXORD .LT. NQ-1) THEN - DDN = DVNORM (N, SAVF, EWT)/TQ(1) - ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) - - ENDIF - IF (MAXORD .EQ. NQ .AND. NEWQ .EQ. NQ+1) ETA = ETAQ - IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ+1) THEN - ETA = ETAQM1 - CALL DVJUST (YH, LDYH, -1) - ENDIF - IF (MAXORD .EQ. NQ-1 .AND. NEWQ .EQ. NQ) THEN - DDN = DVNORM (N, SAVF, EWT)/TQ(1) - ETA = ONE/((BIAS1*DDN)**(ONE/FLOTL) + ADDON) - CALL DVJUST (YH, LDYH, -1) - ENDIF - ETA = MIN(ETA,ONE) - NQ = MAXORD - L = LMAX - 140 IF (KUTH .EQ. 1) ETA = MIN(ETA,ABS(H/HSCAL)) - IF (KUTH .EQ. 0) ETA = MAX(ETA,HMIN/ABS(HSCAL)) - ETA = ETA/MAX(ONE,ABS(HSCAL)*HMXI*ETA) - NEWH = 1 - - NQWAIT = L - IF (NEWQ .LE. MAXORD) GO TO 50 -C Rescale the history array for a change in H by a factor of ETA. ------ - 150 R = ONE - DO 180 J = 2, L - R = R*ETA - CALL DSCAL (N, R, YH(1,J), 1 ) - 180 CONTINUE - H = HSCAL*ETA - HSCAL = H - RC = RC*ETA - NQNYH = NQ*LDYH -C----------------------------------------------------------------------- -C This section computes the predicted values by effectively -C multiplying the YH array by the Pascal triangle matrix. -C DVSET is called to calculate all integration coefficients. -C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. -C----------------------------------------------------------------------- - 200 TN = TN + H - I1 = NQNYH + 1 - DO 220 JB = 1, NQ - I1 = I1 - LDYH - DO 210 I = I1, NQNYH - 210 YH1(I) = YH1(I) + YH1(I+LDYH) - 220 CONTINUE - CALL DVSET - - RL1 = ONE/EL(2) - RC = RC*(RL1/PRL1) - PRL1 = RL1 -C -C Call the nonlinear system solver. ------------------------------------ -C - CALL VNLS (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, - 1 F, JAC, PSOL, NFLAG, RPAR, IPAR) -C - IF (NFLAG .EQ. 0) GO TO 450 - -C----------------------------------------------------------------------- -C The VNLS routine failed to achieve convergence (NFLAG .NE. 0). -C The YH array is retracted to its values before prediction. -C The step size H is reduced and the step is retried, if possible. -C Otherwise, an error exit is taken. -C----------------------------------------------------------------------- - NCF = NCF + 1 - NCFN = NCFN + 1 - ETAMAX = ONE - TN = TOLD - I1 = NQNYH + 1 - DO 430 JB = 1, NQ - I1 = I1 - LDYH - DO 420 I = I1, NQNYH - 420 YH1(I) = YH1(I) - YH1(I+LDYH) - 430 CONTINUE - IF (NFLAG .LT. -1) GO TO 680 - IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 670 - IF (NCF .EQ. MXNCF) GO TO 670 - - ETA = ETACF - ETA = MAX(ETA,HMIN/ABS(H)) - NFLAG = -1 - GO TO 150 -C----------------------------------------------------------------------- -C The corrector has converged (NFLAG = 0). The local error test is -C made and control passes to statement 500 if it fails. -C----------------------------------------------------------------------- - 450 CONTINUE - DSM = ACNRM/TQ(2) - IF (DSM .GT. ONE) GO TO 500 -C----------------------------------------------------------------------- -C After a successful step, update the YH and TAU arrays and decrement -C NQWAIT. If NQWAIT is then 1 and NQ .lt. MAXORD, then ACOR is saved -C for use in a possible order increase on the next step. -C If ETAMAX = 1 (a failure occurred this step), keep NQWAIT .ge. 2. -C----------------------------------------------------------------------- - KFLAG = 0 - NST = NST + 1 - HU = H - NQU = NQ - DO 470 IBACK = 1, NQ - I = L - IBACK - 470 TAU(I+1) = TAU(I) - TAU(1) = H - DO 480 J = 1, L - CALL DAXPY (N, EL(J), ACOR, 1, YH(1,J), 1 ) - 480 CONTINUE - NQWAIT = NQWAIT - 1 - IF ((L .EQ. LMAX) .OR. (NQWAIT .NE. 1)) GO TO 490 - CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1 ) - CONP = TQ(5) - 490 IF (ETAMAX .NE. ONE) GO TO 560 - IF (NQWAIT .LT. 2) NQWAIT = 2 - NEWQ = NQ - NEWH = 0 - ETA = ONE - HNEW = H - GO TO 690 -C----------------------------------------------------------------------- -C The error test failed. KFLAG keeps track of multiple failures. -C Restore TN and the YH array to their previous values, and prepare -C to try the step again. Compute the optimum step size for the -C same order. After repeated failures, H is forced to decrease -C more rapidly. -C----------------------------------------------------------------------- - 500 KFLAG = KFLAG - 1 - NETF = NETF + 1 - NFLAG = -2 - TN = TOLD - I1 = NQNYH + 1 - DO 520 JB = 1, NQ - I1 = I1 - LDYH - DO 510 I = I1, NQNYH - 510 YH1(I) = YH1(I) - YH1(I+LDYH) - 520 CONTINUE - IF (ABS(H) .LE. HMIN*ONEPSM) GO TO 660 - ETAMAX = ONE - IF (KFLAG .LE. KFC) GO TO 530 -C Compute ratio of new H to current H at the current order. ------------ - FLOTL = REAL(L) - ETA = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) - ETA = MAX(ETA,HMIN/ABS(H),ETAMIN) - IF ((KFLAG .LE. -2) .AND. (ETA .GT. ETAMXF)) ETA = ETAMXF - GO TO 150 -C----------------------------------------------------------------------- - -C Control reaches this section if 3 or more consecutive failures -C have occurred. It is assumed that the elements of the YH array -C have accumulated errors of the wrong order. The order is reduced -C by one, if possible. Then H is reduced by a factor of 0.1 and -C the step is retried. After a total of 7 consecutive failures, - -C an exit is taken with KFLAG = -1. -C----------------------------------------------------------------------- - 530 IF (KFLAG .EQ. KFH) GO TO 660 - IF (NQ .EQ. 1) GO TO 540 - ETA = MAX(ETAMIN,HMIN/ABS(H)) - CALL DVJUST (YH, LDYH, -1) - L = NQ - NQ = NQ - 1 - NQWAIT = L - GO TO 150 - 540 ETA = MAX(ETAMIN,HMIN/ABS(H)) - H = H*ETA - HSCAL = H - TAU(1) = H - CALL F (N, TN, Y, SAVF, RPAR, IPAR) - NFE = NFE + 1 - DO 550 I = 1, N - 550 YH(I,2) = H*SAVF(I) - NQWAIT = 10 - GO TO 200 -C----------------------------------------------------------------------- -C If NQWAIT = 0, an increase or decrease in order by one is considered. -C Factors ETAQ, ETAQM1, ETAQP1 are computed by which H could -C be multiplied at order q, q-1, or q+1, respectively. -C The largest of these is determined, and the new order and -C step size set accordingly. -C A change of H or NQ is made only if H increases by at least a -C factor of THRESH. If an order change is considered and rejected, - -C then NQWAIT is set to 2 (reconsider it after 2 steps). -C----------------------------------------------------------------------- -C Compute ratio of new H to current H at the current order. ------------ - 560 FLOTL = REAL(L) - ETAQ = ONE/((BIAS2*DSM)**(ONE/FLOTL) + ADDON) - IF (NQWAIT .NE. 0) GO TO 600 - NQWAIT = 2 - ETAQM1 = ZERO - IF (NQ .EQ. 1) GO TO 570 -C Compute ratio of new H to current H at the current order less one. --- - - DDN = DVNORM (N, YH(1,L), EWT)/TQ(1) - ETAQM1 = ONE/((BIAS1*DDN)**(ONE/(FLOTL - ONE)) + ADDON) - 570 ETAQP1 = ZERO - IF (L .EQ. LMAX) GO TO 580 -C Compute ratio of new H to current H at current order plus one. ------- - - CNQUOT = (TQ(5)/CONP)*(H/TAU(2))**L - - - DO 575 I = 1, N - 575 SAVF(I) = ACOR(I) - CNQUOT*YH(I,LMAX) - DUP = DVNORM (N, SAVF, EWT)/TQ(3) - ETAQP1 = ONE/((BIAS3*DUP)**(ONE/(FLOTL + ONE)) + ADDON) - 580 IF (ETAQ .GE. ETAQP1) GO TO 590 - IF (ETAQP1 .GT. ETAQM1) GO TO 620 - GO TO 610 - 590 IF (ETAQ .LT. ETAQM1) GO TO 610 - 600 ETA = ETAQ - NEWQ = NQ - GO TO 630 - 610 ETA = ETAQM1 - NEWQ = NQ - 1 - GO TO 630 - 620 ETA = ETAQP1 - NEWQ = NQ + 1 - CALL DCOPY (N, ACOR, 1, YH(1,LMAX), 1) -C Test tentative new H against THRESH, ETAMAX, and HMXI, then exit. ---- - 630 IF (ETA .LT. THRESH .OR. ETAMAX .EQ. ONE) GO TO 640 - ETA = MIN(ETA,ETAMAX) - ETA = ETA/MAX(ONE,ABS(H)*HMXI*ETA) - NEWH = 1 - HNEW = H*ETA - GO TO 690 - 640 NEWQ = NQ - NEWH = 0 - ETA = ONE - HNEW = H - GO TO 690 -C----------------------------------------------------------------------- -C All returns are made through this section. -C On a successful return, ETAMAX is reset and ACOR is scaled. - -C----------------------------------------------------------------------- - 660 KFLAG = -1 - GO TO 720 - 670 KFLAG = -2 - GO TO 720 - 680 IF (NFLAG .EQ. -2) KFLAG = -3 - IF (NFLAG .EQ. -3) KFLAG = -4 - GO TO 720 - 690 ETAMAX = ETAMX3 - IF (NST .LE. 10) ETAMAX = ETAMX2 - 700 R = ONE/TQ(2) - CALL DSCAL (N, R, ACOR, 1) - 720 JSTART = 1 - RETURN -C----------------------- End of Subroutine DVSTEP ---------------------- - - END -*DECK DVSET - SUBROUTINE DVSET -C----------------------------------------------------------------------- -C Call sequence communication.. None -C COMMON block variables accessed.. -C /DVOD01/ -- EL(13), H, TAU(13), TQ(5), L(= NQ + 1), - -C METH, NQ, NQWAIT -C -C Subroutines called by DVSET.. None -C Function routines called by DVSET.. None -C----------------------------------------------------------------------- -C DVSET is called by DVSTEP and sets coefficients for use there. -C -C For each order NQ, the coefficients in EL are calculated by use of -C the generating polynomial lambda(x), with coefficients EL(i). -C lambda(x) = EL(1) + EL(2)*x + ... + EL(NQ+1)*(x**NQ). -C For the backward differentiation formulas, -C NQ-1 -C lambda(x) = (1 + x/xi*(NQ)) * product (1 + x/xi(i) ) . -C i = 1 -C For the Adams formulas, -C NQ-1 - -C (d/dx) lambda(x) = c * product (1 + x/xi(i) ) , - -C i = 1 -C lambda(-1) = 0, lambda(0) = 1, -C where c is a normalization constant. -C In both cases, xi(i) is defined by -C H*xi(i) = t sub n - t sub (n-i) - -C = H + TAU(1) + TAU(2) + ... TAU(i-1). - -C -C -C In addition to variables described previously, communication -C with DVSET uses the following.. -C TAU = A vector of length 13 containing the past NQ values -C of H. -C EL = A vector of length 13 in which vset stores the -C coefficients for the corrector formula. -C TQ = A vector of length 5 in which vset stores constants -C used for the convergence test, the error test, and the -C selection of H at a new order. -C METH = The basic method indicator. -C NQ = The current order. -C L = NQ + 1, the length of the vector stored in EL, and -C the number of columns of the YH array being used. -C NQWAIT = A counter controlling the frequency of order changes. -C An order change is about to be considered if NQWAIT = 1. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for local variables -------------------------------- -C - DOUBLE PRECISION AHATN0, ALPH0, CNQM1, CORTES, CSUM, ELP, EM, - 1 EM0, FLOTI, FLOTL, FLOTNQ, HSUM, ONE, RXI, RXIS, S, SIX, - 2 T1, T2, T3, T4, T5, T6, TWO, XI, ZERO - INTEGER I, IBACK, J, JP1, NQM1, NQM2 -C - DIMENSION EM(13) -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE CORTES, ONE, SIX, TWO, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH -C - DATA CORTES /0.1D0/ - DATA ONE /1.0D0/, SIX /6.0D0/, TWO /2.0D0/, ZERO /0.0D0/ -C - FLOTL = REAL(L) - NQM1 = NQ - 1 - NQM2 = NQ - 2 - GO TO (100, 200), METH -C -C Set coefficients for Adams methods. ---------------------------------- - 100 IF (NQ .NE. 1) GO TO 110 - EL(1) = ONE - EL(2) = ONE - TQ(1) = ONE - TQ(2) = TWO - TQ(3) = SIX*TQ(2) - TQ(5) = ONE - GO TO 300 - 110 HSUM = H - EM(1) = ONE - FLOTNQ = FLOTL - ONE - DO 115 I = 2, L - 115 EM(I) = ZERO - DO 150 J = 1, NQM1 - IF ((J .NE. NQM1) .OR. (NQWAIT .NE. 1)) GO TO 130 - S = ONE - CSUM = ZERO - - DO 120 I = 1, NQM1 - CSUM = CSUM + S*EM(I)/REAL(I+1) - 120 S = -S - TQ(1) = EM(NQM1)/(FLOTNQ*CSUM) - 130 RXI = H/HSUM - DO 140 IBACK = 1, J - I = (J + 2) - IBACK - 140 EM(I) = EM(I) + EM(I-1)*RXI - HSUM = HSUM + TAU(J) - 150 CONTINUE -C Compute integral from -1 to 0 of polynomial and of x times it. ------- - S = ONE - EM0 = ZERO - CSUM = ZERO - DO 160 I = 1, NQ - FLOTI = REAL(I) - EM0 = EM0 + S*EM(I)/FLOTI - CSUM = CSUM + S*EM(I)/(FLOTI+ONE) - 160 S = -S -C In EL, form coefficients of normalized integrated polynomial. -------- - S = ONE/EM0 - EL(1) = ONE - DO 170 I = 1, NQ - 170 EL(I+1) = S*EM(I)/REAL(I) - XI = HSUM/H - TQ(2) = XI*EM0/CSUM - TQ(5) = XI/EL(L) - IF (NQWAIT .NE. 1) GO TO 300 -C For higher order control constant, multiply polynomial by 1+x/xi(q). - - RXI = ONE/XI - DO 180 IBACK = 1, NQ - I = (L + 1) - IBACK - 180 EM(I) = EM(I) + EM(I-1)*RXI -C Compute integral of polynomial. -------------------------------------- - S = ONE - - CSUM = ZERO - DO 190 I = 1, L - CSUM = CSUM + S*EM(I)/REAL(I+1) - 190 S = -S - TQ(3) = FLOTL*EM0/CSUM - GO TO 300 -C -C Set coefficients for BDF methods. ------------------------------------ - 200 DO 210 I = 3, L - 210 EL(I) = ZERO - EL(1) = ONE - EL(2) = ONE - ALPH0 = -ONE - AHATN0 = -ONE - HSUM = H - RXI = ONE - RXIS = ONE - IF (NQ .EQ. 1) GO TO 240 - - DO 230 J = 1, NQM2 -C In EL, construct coefficients of (1+x/xi(1))*...*(1+x/xi(j+1)). ------ - HSUM = HSUM + TAU(J) - RXI = H/HSUM - JP1 = J + 1 - ALPH0 = ALPH0 - ONE/REAL(JP1) - DO 220 IBACK = 1, JP1 - I = (J + 3) - IBACK - 220 EL(I) = EL(I) + EL(I-1)*RXI - 230 CONTINUE - ALPH0 = ALPH0 - ONE/REAL(NQ) - RXIS = -EL(2) - ALPH0 - HSUM = HSUM + TAU(NQM1) - RXI = H/HSUM - AHATN0 = -EL(2) - RXI - DO 235 IBACK = 1, NQ - I = (NQ + 2) - IBACK - 235 EL(I) = EL(I) + EL(I-1)*RXIS - 240 T1 = ONE - AHATN0 + ALPH0 - T2 = ONE + REAL(NQ)*T1 - TQ(2) = ABS(ALPH0*T2/T1) - TQ(5) = ABS(T2/(EL(L)*RXI/RXIS)) - IF (NQWAIT .NE. 1) GO TO 300 - CNQM1 = RXIS/EL(L) - T3 = ALPH0 + ONE/REAL(NQ) - T4 = AHATN0 + RXI - ELP = T3/(ONE - T4 + T3) - TQ(1) = ABS(ELP/CNQM1) - HSUM = HSUM + TAU(NQ) - RXI = H/HSUM - T5 = ALPH0 - ONE/REAL(NQ+1) - T6 = AHATN0 - RXI - ELP = T2/(ONE - T6 + T5) - TQ(3) = ABS(ELP*RXI*(FLOTL + ONE)*T5) - 300 TQ(4) = CORTES*TQ(2) - RETURN -C----------------------- End of Subroutine DVSET ----------------------- - END -*DECK DVJUST - SUBROUTINE DVJUST (YH, LDYH, IORD) - DOUBLE PRECISION YH - INTEGER LDYH, IORD - - DIMENSION YH(LDYH,*) -C----------------------------------------------------------------------- -C Call sequence input -- YH, LDYH, IORD -C Call sequence output -- YH -C COMMON block input -- NQ, METH, LMAX, HSCAL, TAU(13), N -C COMMON block variables accessed.. -C /DVOD01/ -- HSCAL, TAU(13), LMAX, METH, N, NQ, -C -C Subroutines called by DVJUST.. DAXPY -C Function routines called by DVJUST.. None -C----------------------------------------------------------------------- -C This subroutine adjusts the YH array on reduction of order, -C and also when the order is increased for the stiff option (METH = 2). -C Communication with DVJUST uses the following.. -C IORD = An integer flag used when METH = 2 to indicate an order -C increase (IORD = +1) or an order decrease (IORD = -1). -C HSCAL = Step size H used in scaling of Nordsieck array YH. -C (If IORD = +1, DVJUST assumes that HSCAL = TAU(1).) -C See References 1 and 2 for details. -C----------------------------------------------------------------------- -C - -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for local variables -------------------------------- -C - DOUBLE PRECISION ALPH0, ALPH1, HSUM, ONE, PROD, T1, XI,XIOLD, ZERO - INTEGER I, IBACK, J, JP1, LP1, NQM1, NQM2, NQP1 -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE ONE, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH -C - DATA ONE /1.0D0/, ZERO /0.0D0/ -C - IF ((NQ .EQ. 2) .AND. (IORD .NE. 1)) RETURN - NQM1 = NQ - 1 - NQM2 = NQ - 2 - GO TO (100, 200), METH - -C----------------------------------------------------------------------- -C Nonstiff option... -C Check to see if the order is being increased or decreased. -C----------------------------------------------------------------------- - 100 CONTINUE - IF (IORD .EQ. 1) GO TO 180 - -C Order decrease. ------------------------------------------------------ - DO 110 J = 1, LMAX - 110 EL(J) = ZERO - EL(2) = ONE - HSUM = ZERO - DO 130 J = 1, NQM2 -C Construct coefficients of x*(x+xi(1))*...*(x+xi(j)). ----------------- - HSUM = HSUM + TAU(J) - XI = HSUM/HSCAL - JP1 = J + 1 - DO 120 IBACK = 1, JP1 - I = (J + 3) - IBACK - 120 EL(I) = EL(I)*XI + EL(I-1) - 130 CONTINUE -C Construct coefficients of integrated polynomial. --------------------- - DO 140 J = 2, NQM1 - 140 EL(J+1) = REAL(NQ)*EL(J)/REAL(J) -C Subtract correction terms from YH array. ----------------------------- - DO 170 J = 3, NQ - DO 160 I = 1, N - 160 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) - 170 CONTINUE - RETURN -C Order increase. ------------------------------------------------------ -C Zero out next column in YH array. ------------------------------------ - 180 CONTINUE - LP1 = L + 1 - DO 190 I = 1, N - 190 YH(I,LP1) = ZERO - RETURN -C----------------------------------------------------------------------- -C Stiff option... -C Check to see if the order is being increased or decreased. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (IORD .EQ. 1) GO TO 300 - -C Order decrease. ------------------------------------------------------ - DO 210 J = 1, LMAX - 210 EL(J) = ZERO - EL(3) = ONE - HSUM = ZERO - DO 230 J = 1,NQM2 -C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- - HSUM = HSUM + TAU(J) - XI = HSUM/HSCAL - - JP1 = J + 1 - DO 220 IBACK = 1, JP1 - I = (J + 4) - IBACK - 220 EL(I) = EL(I)*XI + EL(I-1) - 230 CONTINUE -C Subtract correction terms from YH array. ----------------------------- - DO 250 J = 3,NQ - DO 240 I = 1, N - 240 YH(I,J) = YH(I,J) - YH(I,L)*EL(J) - 250 CONTINUE - RETURN -C Order increase. ------------------------------------------------------ - 300 DO 310 J = 1, LMAX - 310 EL(J) = ZERO - EL(3) = ONE - ALPH0 = -ONE - ALPH1 = ONE - PROD = ONE - XIOLD = ONE - HSUM = HSCAL - IF (NQ .EQ. 1) GO TO 340 - DO 330 J = 1, NQM1 -C Construct coefficients of x*x*(x+xi(1))*...*(x+xi(j)). --------------- - JP1 = J + 1 - HSUM = HSUM + TAU(JP1) - XI = HSUM/HSCAL - PROD = PROD*XI - ALPH0 = ALPH0 - ONE/REAL(JP1) - ALPH1 = ALPH1 + ONE/XI - DO 320 IBACK = 1, JP1 - I = (J + 4) - IBACK - 320 EL(I) = EL(I)*XIOLD + EL(I-1) - XIOLD = XI - 330 CONTINUE - 340 CONTINUE - T1 = (-ALPH0 - ALPH1)/PROD -C Load column L + 1 in YH array. --------------------------------------- - LP1 = L + 1 - DO 350 I = 1, N - - 350 YH(I,LP1) = T1*YH(I,LMAX) -C Add correction terms to YH array. ------------------------------------ - NQP1 = NQ + 1 - DO 370 J = 3, NQP1 - CALL DAXPY (N, EL(J), YH(1,LP1), 1, YH(1,J), 1 ) - 370 CONTINUE - RETURN -C----------------------- End of Subroutine DVJUST ---------------------- - END -*DECK DVNLSD - SUBROUTINE DVNLSD (Y, YH, LDYH, VSAV, SAVF, EWT, ACOR, IWM, WM, - 1 F, JAC, PDUM, NFLAG, RPAR, IPAR) - - EXTERNAL F, JAC, PDUM - DOUBLE PRECISION Y, YH, VSAV, SAVF, EWT, ACOR, WM, RPAR - INTEGER LDYH, IWM, NFLAG, IPAR - DIMENSION Y(*), YH(LDYH,*), VSAV(*), SAVF(*), EWT(*), ACOR(*), - 1 IWM(*), WM(*) -C----------------------------------------------------------------------- - -C Call sequence input -- Y, YH, LDYH, SAVF, EWT, ACOR, IWM, WM, -C F, JAC, NFLAG, RPAR, IPAR -C Call sequence output -- YH, ACOR, WM, IWM, NFLAG -C COMMON block variables accessed.. -C /DVOD01/ ACNRM, CRATE, DRC, H, RC, RL1, TQ(5), TN, ICF, - -C JCUR, METH, MITER, N, NSLP -C /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Subroutines called by DVNLSD.. F, DAXPY, DCOPY, DSCAL, DVJAC, DVSOL -C Function routines called by DVNLSD.. DVNORM - -C----------------------------------------------------------------------- -C Subroutine DVNLSD is a nonlinear system solver, which uses functional -C iteration or a chord (modified Newton) method. For the chord method -C direct linear algebraic system solvers are used. Subroutine DVNLSD -C then handles the corrector phase of this integration package. -C -C Communication with DVNLSD is done with the following variables. (For -C more details, please see the comments in the driver subroutine.) -C -C Y = The dependent variable, a vector of length N, input. -C YH = The Nordsieck (Taylor) array, LDYH by LMAX, input -C and output. On input, it contains predicted values. -C LDYH = A constant .ge. N, the first dimension of YH, input. -C VSAV = Unused work array. -C SAVF = A work array of length N. -C EWT = An error weight vector of length N, input. -C ACOR = A work array of length N, used for the accumulated -C corrections to the predicted y vector. -C WM,IWM = Real and integer work arrays associated with matrix -C operations in chord iteration (MITER .ne. 0). -C F = Dummy name for user supplied routine for f. -C JAC = Dummy name for user supplied Jacobian routine. -C PDUM = Unused dummy subroutine name. Included for uniformity -C over collection of integrators. -C NFLAG = Input/output flag, with values and meanings as follows.. -C INPUT -C 0 first call for this time step. -C -1 convergence failure in previous call to DVNLSD. -C -2 error test failure in DVSTEP. -C OUTPUT -C 0 successful completion of nonlinear solver. -C -1 convergence failure or singular matrix. -C -2 unrecoverable error in matrix preprocessing -C (cannot occur here). -C -3 unrecoverable error in solution (cannot occur -C here). -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C -C IPUP = Own variable flag with values and meanings as follows.. -C 0, do not update the Newton matrix. -C MITER .ne. 0, update Newton matrix, because it is the -C initial step, order was changed, the error -C test failed, or an update is indicated by -C the scalar RC or step counter NST. -C -C For more details, see comments in driver subroutine. -C----------------------------------------------------------------------- -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - DOUBLE PRECISION HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C -C Type declarations for local variables -------------------------------- -C - DOUBLE PRECISION CCMAX, CRDOWN, CSCALE, DCON, DEL, DELP, ONE, - 1 RDIV, TWO, ZERO - INTEGER I, IERPJ, IERSL, M, MAXCOR, MSBP - -C -C Type declaration for function subroutines called --------------------- -C - DOUBLE PRECISION DVNORM -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE CCMAX, CRDOWN, MAXCOR, MSBP, RDIV, ONE, TWO, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - DATA CCMAX /0.3D0/, CRDOWN /0.3D0/, MAXCOR /3/, MSBP /20/, - 1 RDIV /2.0D0/ - - DATA ONE /1.0D0/, TWO /2.0D0/, ZERO /0.0D0/ -C----------------------------------------------------------------------- -C On the first step, on a change of method order, or after a -C nonlinear convergence failure with NFLAG = -2, set IPUP = MITER -C to force a Jacobian update when MITER .ne. 0. -C----------------------------------------------------------------------- - IF (JSTART .EQ. 0) NSLP = 0 - IF (NFLAG .EQ. 0) ICF = 0 - IF (NFLAG .EQ. -2) IPUP = MITER - IF ( (JSTART .EQ. 0) .OR. (JSTART .EQ. -1) ) IPUP = MITER -C If this is functional iteration, set CRATE .eq. 1 and drop to 220 - IF (MITER .EQ. 0) THEN - CRATE = ONE - GO TO 220 - ENDIF -C----------------------------------------------------------------------- -C RC is the ratio of new to old values of the coefficient H/EL(2)=h/l1. -C When RC differs from 1 by more than CCMAX, IPUP is set to MITER -C to force DVJAC to be called, if a Jacobian is involved. -C In any case, DVJAC is called at least every MSBP steps. -C----------------------------------------------------------------------- - DRC = ABS(RC-ONE) - IF (DRC .GT. CCMAX .OR. NST .GE. NSLP+MSBP) IPUP = MITER -C----------------------------------------------------------------------- -C Up to MAXCOR corrector iterations are taken. A convergence test is -C made on the r.m.s. norm of each correction, weighted by the error -C weight vector EWT. The sum of the corrections is accumulated in the -C vector ACOR(i). The YH array is not altered in the corrector loop. -C----------------------------------------------------------------------- - 220 M = 0 - DELP = ZERO - CALL DCOPY (N, YH(1,1), 1, Y, 1 ) - CALL F (N, TN, Y, SAVF, RPAR, IPAR) - NFE = NFE + 1 - IF (IPUP .LE. 0) GO TO 250 -C----------------------------------------------------------------------- -C If indicated, the matrix P = I - h*rl1*J is reevaluated and -C preprocessed before starting the corrector iteration. IPUP is set -C to 0 as an indicator that this has been done. -C----------------------------------------------------------------------- - CALL DVJAC (Y, YH, LDYH, EWT, ACOR, SAVF, WM, IWM, F, JAC, IERPJ, - 1 RPAR, IPAR) - IPUP = 0 - RC = ONE - DRC = ZERO - CRATE = ONE - NSLP = NST -C If matrix is singular, take error return to force cut in step size. -- - IF (IERPJ .NE. 0) GO TO 430 - 250 DO 260 I = 1,N - 260 ACOR(I) = ZERO - -C This is a looping point for the corrector iteration. ----------------- - 270 IF (MITER .NE. 0) GO TO 350 -C----------------------------------------------------------------------- -C In the case of functional iteration, update Y directly from -C the result of the last function evaluation. -C----------------------------------------------------------------------- - DO 280 I = 1,N - 280 SAVF(I) = RL1*(H*SAVF(I) - YH(I,2)) - DO 290 I = 1,N - 290 Y(I) = SAVF(I) - ACOR(I) - DEL = DVNORM (N, Y, EWT) - DO 300 I = 1,N - 300 Y(I) = YH(I,1) + SAVF(I) - CALL DCOPY (N, SAVF, 1, ACOR, 1) - GO TO 400 -C----------------------------------------------------------------------- -C In the case of the chord method, compute the corrector error, - -C and solve the linear system with that as right-hand side and -C P as coefficient matrix. The correction is scaled by the factor -C 2/(1+RC) to account for changes in h*rl1 since the last DVJAC call. -C----------------------------------------------------------------------- - 350 DO 360 I = 1,N - 360 Y(I) = (RL1*H)*SAVF(I) - (RL1*YH(I,2) + ACOR(I)) - CALL DVSOL (WM, IWM, Y, IERSL) - NNI = NNI + 1 - IF (IERSL .GT. 0) GO TO 410 - IF (METH .EQ. 2 .AND. RC .NE. ONE) THEN - CSCALE = TWO/(ONE + RC) - CALL DSCAL (N, CSCALE, Y, 1) - - ENDIF - DEL = DVNORM (N, Y, EWT) - CALL DAXPY (N, ONE, Y, 1, ACOR, 1) - DO 380 I = 1,N - 380 Y(I) = YH(I,1) + ACOR(I) -C----------------------------------------------------------------------- -C Test for convergence. If M .gt. 0, an estimate of the convergence -C rate constant is stored in CRATE, and this is used in the test. -C----------------------------------------------------------------------- - 400 IF (M .NE. 0) CRATE = MAX(CRDOWN*CRATE,DEL/DELP) - DCON = DEL*MIN(ONE,CRATE)/TQ(4) - IF (DCON .LE. ONE) GO TO 450 - M = M + 1 - IF (M .EQ. MAXCOR) GO TO 410 - IF (M .GE. 2 .AND. DEL .GT. RDIV*DELP) GO TO 410 - DELP = DEL - CALL F (N, TN, Y, SAVF, RPAR, IPAR) - NFE = NFE + 1 - GO TO 270 - -C - - 410 IF (MITER .EQ. 0 .OR. JCUR .EQ. 1) GO TO 430 - ICF = 1 - IPUP = MITER - - GO TO 220 -C - 430 CONTINUE - NFLAG = -1 - ICF = 2 - IPUP = MITER - RETURN - -C -C Return for successful step. ------------------------------------------ - 450 NFLAG = 0 - JCUR = 0 - ICF = 0 - IF (M .EQ. 0) ACNRM = DEL - IF (M .GT. 0) ACNRM = DVNORM (N, ACOR, EWT) - RETURN -C----------------------- End of Subroutine DVNLSD ---------------------- - END -*DECK DVJAC - SUBROUTINE DVJAC (Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, F, JAC, - 1 IERPJ, RPAR, IPAR) - EXTERNAL F, JAC - DOUBLE PRECISION Y, YH, EWT, FTEM, SAVF, WM, RPAR - INTEGER LDYH, IWM, IERPJ, IPAR - DIMENSION Y(*), YH(LDYH,*), EWT(*), FTEM(*), SAVF(*), - 1 WM(*), IWM(*) -C----------------------------------------------------------------------- -C Call sequence input -- Y, YH, LDYH, EWT, FTEM, SAVF, WM, IWM, -C F, JAC, RPAR, IPAR -C Call sequence output -- WM, IWM, IERPJ -C COMMON block variables accessed.. -C /DVOD01/ CCMXJ, DRC, H, RL1, TN, UROUND, ICF, JCUR, LOCJS, -C MSBJ, NSLJ -C /DVOD02/ NFE, NST, NJE, NLU - -C - -C Subroutines called by DVJAC.. F, JAC, DACOPY, DCOPY, DGBFA, DGEFA, - -C DSCAL -C Function routines called by DVJAC.. DVNORM -C----------------------------------------------------------------------- -C DVJAC is called by DVSTEP to compute and process the matrix -C P = I - h*rl1*J , where J is an approximation to the Jacobian. -C Here J is computed by the user-supplied routine JAC if -C MITER = 1 or 4, or by finite differencing if MITER = 2, 3, or 5. -C If MITER = 3, a diagonal approximation to J is used. -C If JSV = -1, J is computed from scratch in all cases. -C If JSV = 1 and MITER = 1, 2, 4, or 5, and if the saved value of J is -C considered acceptable, then P is constructed from the saved J. -C J is stored in wm and replaced by P. If MITER .ne. 3, P is then -C subjected to LU decomposition in preparation for later solution -C of linear systems with P as coefficient matrix. This is done -C by DGEFA if MITER = 1 or 2, and by DGBFA if MITER = 4 or 5. -C -C Communication with DVJAC is done with the following variables. (For -C more details, please see the comments in the driver subroutine.) -C Y = Vector containing predicted values on entry. -C YH = The Nordsieck array, an LDYH by LMAX array, input. -C LDYH = A constant .ge. N, the first dimension of YH, input. -C EWT = An error weight vector of length N. -C SAVF = Array containing f evaluated at predicted y, input. -C WM = Real work space for matrices. In the output, it containS -C the inverse diagonal matrix if MITER = 3 and the LU -C decomposition of P if MITER is 1, 2 , 4, or 5. -C Storage of matrix elements starts at WM(3). -C Storage of the saved Jacobian starts at WM(LOCJS). -C WM also contains the following matrix-related data.. -C WM(1) = SQRT(UROUND), used in numerical Jacobian step. -C WM(2) = H*RL1, saved for later use if MITER = 3. -C IWM = Integer work space containing pivot information, -C starting at IWM(31), if MITER is 1, 2, 4, or 5. - -C IWM also contains band parameters ML = IWM(1) and -C MU = IWM(2) if MITER is 4 or 5. -C F = Dummy name for the user supplied subroutine for f. -C JAC = Dummy name for the user supplied Jacobian subroutine. -C RPAR, IPAR = Dummy names for user's real and integer work arrays. -C RL1 = 1/EL(2) (input). -C IERPJ = Output error flag, = 0 if no trouble, 1 if the P -C matrix is found to be singular. -C JCUR = Output flag to indicate whether the Jacobian matrix -C (or approximation) is now current. -C JCUR = 0 means J is not current. - -C JCUR = 1 means J is current. -C----------------------------------------------------------------------- - -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for labeled COMMON block DVOD02 -------------------- -C - DOUBLE PRECISION HU - INTEGER NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST - -C -C Type declarations for local variables -------------------------------- -C - DOUBLE PRECISION CON, DI, FAC, HRL1, ONE, PT1, R, R0, SRUR, THOU, - 1 YI, YJ, YJJ, ZERO - INTEGER I, I1, I2, IER, II, J, J1, JJ, JOK, LENP, MBA, MBAND, - 1 MEB1, MEBAND, ML, ML3, MU, NP1 -C -C Type declaration for function subroutines called --------------------- -C - DOUBLE PRECISION DVNORM -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the - -C listed (local) variables to be saved between calls to this subroutine. -C----------------------------------------------------------------------- - SAVE ONE, PT1, THOU, ZERO - -C----------------------------------------------------------------------- - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH - COMMON /DVOD02/ HU, NCFN, NETF, NFE, NJE, NLU, NNI, NQU, NST -C - DATA ONE /1.0D0/, THOU /1000.0D0/, ZERO /0.0D0/, PT1 /0.1D0/ -C - IERPJ = 0 - HRL1 = H*RL1 -C See whether J should be evaluated (JOK = -1) or not (JOK = 1). ------- - JOK = JSV - IF (JSV .EQ. 1) THEN - IF (NST .EQ. 0 .OR. NST .GT. NSLJ+MSBJ) JOK = -1 - IF (ICF .EQ. 1 .AND. DRC .LT. CCMXJ) JOK = -1 - IF (ICF .EQ. 2) JOK = -1 - ENDIF -C End of setting JOK. -------------------------------------------------- -C - IF (JOK .EQ. -1 .AND. MITER .EQ. 1) THEN -C If JOK = -1 and MITER = 1, call JAC to evaluate Jacobian. ------------ - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - LENP = N*N - DO 110 I = 1,LENP - 110 WM(I+2) = ZERO - CALL JAC (N, TN, Y, 0, 0, WM(3), N, RPAR, IPAR) - IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) - - ENDIF -C - IF (JOK .EQ. -1 .AND. MITER .EQ. 2) THEN -C If MITER = 2, make N calls to F to approximate the Jacobian. --------- - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - FAC = DVNORM (N, SAVF, EWT) - R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - SRUR = WM(1) - J1 = 2 - DO 230 J = 1,N - - YJ = Y(J) - R = MAX(SRUR*ABS(YJ),R0/EWT(J)) - Y(J) = Y(J) + R - FAC = ONE/R - CALL F (N, TN, Y, FTEM, RPAR, IPAR) - DO 220 I = 1,N - 220 WM(I+J1) = (FTEM(I) - SAVF(I))*FAC - Y(J) = YJ - J1 = J1 + N - - 230 CONTINUE - NFE = NFE + N - - LENP = N*N - IF (JSV .EQ. 1) CALL DCOPY (LENP, WM(3), 1, WM(LOCJS), 1) - ENDIF -C - IF (JOK .EQ. 1 .AND. (MITER .EQ. 1 .OR. MITER .EQ. 2)) THEN - JCUR = 0 - LENP = N*N - CALL DCOPY (LENP, WM(LOCJS), 1, WM(3), 1) - ENDIF -C - IF (MITER .EQ. 1 .OR. MITER .EQ. 2) THEN -C Multiply Jacobian by scalar, add identity, and do LU decomposition. -- - CON = -HRL1 - CALL DSCAL (LENP, CON, WM(3), 1) - J = 3 - NP1 = N + 1 - DO 250 I = 1,N - WM(J) = WM(J) + ONE - 250 J = J + NP1 - NLU = NLU + 1 - CALL DGEFA (WM(3), N, N, IWM(31), IER) - - IF (IER .NE. 0) IERPJ = 1 - RETURN - ENDIF -C End of code block for MITER = 1 or 2. -------------------------------- -C - IF (MITER .EQ. 3) THEN -C If MITER = 3, construct a diagonal approximation to J and P. --------- - NJE = NJE + 1 - JCUR = 1 - WM(2) = HRL1 - R = RL1*PT1 - DO 310 I = 1,N - 310 Y(I) = Y(I) + R*(H*SAVF(I) - YH(I,2)) - CALL F (N, TN, Y, WM(3), RPAR, IPAR) - NFE = NFE + 1 - DO 320 I = 1,N - R0 = H*SAVF(I) - YH(I,2) - DI = PT1*R0 - H*(WM(I+2) - SAVF(I)) - WM(I+2) = ONE - IF (ABS(R0) .LT. UROUND/EWT(I)) GO TO 320 - IF (ABS(DI) .EQ. ZERO) GO TO 330 - WM(I+2) = PT1*R0/DI - 320 CONTINUE - RETURN - 330 IERPJ = 1 - RETURN - ENDIF -C End of code block for MITER = 3. ------------------------------------- - -C -C Set constants for MITER = 4 or 5. ------------------------------------ - ML = IWM(1) - MU = IWM(2) - ML3 = ML + 3 - MBAND = ML + MU + 1 - MEBAND = MBAND + ML - LENP = MEBAND*N -C - IF (JOK .EQ. -1 .AND. MITER .EQ. 4) THEN -C If JOK = -1 and MITER = 4, call JAC to evaluate Jacobian. ------------ - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - DO 410 I = 1,LENP - 410 WM(I+2) = ZERO - CALL JAC (N, TN, Y, ML, MU, WM(ML3), MEBAND, RPAR, IPAR) - IF (JSV .EQ. 1) - 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) - ENDIF -C - - IF (JOK .EQ. -1 .AND. MITER .EQ. 5) THEN -C If MITER = 5, make N calls to F to approximate the Jacobian. --------- - NJE = NJE + 1 - NSLJ = NST - JCUR = 1 - MBA = MIN(MBAND,N) - MEB1 = MEBAND - 1 - SRUR = WM(1) - FAC = DVNORM (N, SAVF, EWT) - R0 = THOU*ABS(H)*UROUND*REAL(N)*FAC - IF (R0 .EQ. ZERO) R0 = ONE - DO 560 J = 1,MBA - DO 530 I = J,N,MBAND - YI = Y(I) - R = MAX(SRUR*ABS(YI),R0/EWT(I)) - - 530 Y(I) = Y(I) + R - CALL F (N, TN, Y, FTEM, RPAR, IPAR) - DO 550 JJ = J,N,MBAND - Y(JJ) = YH(JJ,1) - YJJ = Y(JJ) - R = MAX(SRUR*ABS(YJJ),R0/EWT(JJ)) - FAC = ONE/R - I1 = MAX(JJ-MU,1) - I2 = MIN(JJ+ML,N) - II = JJ*MEB1 - ML + 2 - DO 540 I = I1,I2 - 540 WM(II+I) = (FTEM(I) - SAVF(I))*FAC - 550 CONTINUE - 560 CONTINUE - NFE = NFE + MBA - IF (JSV .EQ. 1) - 1 CALL DACOPY (MBAND, N, WM(ML3), MEBAND, WM(LOCJS), MBAND) - ENDIF -C - IF (JOK .EQ. 1) THEN - JCUR = 0 - CALL DACOPY (MBAND, N, WM(LOCJS), MBAND, WM(ML3), MEBAND) - ENDIF -C -C Multiply Jacobian by scalar, add identity, and do LU decomposition. - CON = -HRL1 - - CALL DSCAL (LENP, CON, WM(3), 1 ) - II = MBAND + 2 - DO 580 I = 1,N - WM(II) = WM(II) + ONE - 580 II = II + MEBAND - NLU = NLU + 1 - CALL DGBFA (WM(3), MEBAND, N, ML, MU, IWM(31), IER) - IF (IER .NE. 0) IERPJ = 1 - RETURN -C End of code block for MITER = 4 or 5. -------------------------------- -C -C----------------------- End of Subroutine DVJAC ----------------------- - END - - -*DECK DACOPY - SUBROUTINE DACOPY (NROW, NCOL, A, NROWA, B, NROWB) - DOUBLE PRECISION A, B - INTEGER NROW, NCOL, NROWA, NROWB - DIMENSION A(NROWA,NCOL), B(NROWB,NCOL) -C----------------------------------------------------------------------- -C Call sequence input -- NROW, NCOL, A, NROWA, NROWB -C Call sequence output -- B -C COMMON block variables accessed -- None -C -C Subroutines called by DACOPY.. DCOPY -C Function routines called by DACOPY.. None -C----------------------------------------------------------------------- - -C This routine copies one rectangular array, A, to another, B, -C where A and B may have different row dimensions, NROWA and NROWB. -C The data copied consists of NROW rows and NCOL columns. -C----------------------------------------------------------------------- - INTEGER IC -C - DO 20 IC = 1,NCOL - CALL DCOPY (NROW, A(1,IC), 1, B(1,IC), 1) - 20 CONTINUE -C - RETURN -C----------------------- End of Subroutine DACOPY ---------------------- - END -*DECK DVSOL - SUBROUTINE DVSOL (WM, IWM, X, IERSL) - DOUBLE PRECISION WM, X - INTEGER IWM, IERSL - DIMENSION WM(*), IWM(*), X(*) -C----------------------------------------------------------------------- -C Call sequence input -- WM, IWM, X - -C Call sequence output -- X, IERSL -C COMMON block variables accessed.. -C /DVOD01/ -- H, RL1, MITER, N -C -C Subroutines called by DVSOL.. DGESL, DGBSL -C Function routines called by DVSOL.. None -C----------------------------------------------------------------------- -C This routine manages the solution of the linear system arising from -C a chord iteration. It is called if MITER .ne. 0. -C If MITER is 1 or 2, it calls DGESL to accomplish this. -C If MITER = 3 it updates the coefficient H*RL1 in the diagonal -C matrix, and then computes the solution. -C If MITER is 4 or 5, it calls DGBSL. -C Communication with DVSOL uses the following variables.. -C WM = Real work space containing the inverse diagonal matrix if -C MITER = 3 and the LU decomposition of the matrix otherwise. -C Storage of matrix elements starts at WM(3). -C WM also contains the following matrix-related data.. -C WM(1) = SQRT(UROUND) (not used here), -C WM(2) = HRL1, the previous value of H*RL1, used if MITER = 3. - -C IWM = Integer work space containing pivot information, starting at -C IWM(31), if MITER is 1, 2, 4, or 5. IWM also contains band -C parameters ML = IWM(1) and MU = IWM(2) if MITER is 4 or 5. -C X = The right-hand side vector on input, and the solution vector -C on output, of length N. -C IERSL = Output flag. IERSL = 0 if no trouble occurred. -C IERSL = 1 if a singular matrix arose with MITER = 3. -C----------------------------------------------------------------------- -C -C Type declarations for labeled COMMON block DVOD01 -------------------- -C - DOUBLE PRECISION ACNRM, CCMXJ, CONP, CRATE, DRC, EL, - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU, TQ, TN, UROUND - INTEGER ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 1 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 2 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 3 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 4 NSLP, NYH -C -C Type declarations for local variables -------------------------------- -C - INTEGER I, MEBAND, ML, MU - DOUBLE PRECISION DI, HRL1, ONE, PHRL1, R, ZERO -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE ONE, ZERO -C - COMMON /DVOD01/ ACNRM, CCMXJ, CONP, CRATE, DRC, EL(13), - 1 ETA, ETAMAX, H, HMIN, HMXI, HNEW, HSCAL, PRL1, - 2 RC, RL1, TAU(13), TQ(5), TN, UROUND, - 3 ICF, INIT, IPUP, JCUR, JSTART, JSV, KFLAG, KUTH, - 4 L, LMAX, LYH, LEWT, LACOR, LSAVF, LWM, LIWM, - 5 LOCJS, MAXORD, METH, MITER, MSBJ, MXHNIL, MXSTEP, - 6 N, NEWH, NEWQ, NHNIL, NQ, NQNYH, NQWAIT, NSLJ, - 7 NSLP, NYH -C - DATA ONE /1.0D0/, ZERO /0.0D0/ -C - - IERSL = 0 - - GO TO (100, 100, 300, 400, 400), MITER - 100 CALL DGESL (WM(3), N, N, IWM(31), X, 0) - RETURN -C - 300 PHRL1 = WM(2) - HRL1 = H*RL1 - - WM(2) = HRL1 - IF (HRL1 .EQ. PHRL1) GO TO 330 - R = HRL1/PHRL1 - DO 320 I = 1,N - DI = ONE - R*(ONE - ONE/WM(I+2)) - IF (ABS(DI) .EQ. ZERO) GO TO 390 - 320 WM(I+2) = ONE/DI -C - 330 DO 340 I = 1,N - 340 X(I) = WM(I+2)*X(I) - RETURN - - 390 IERSL = 1 - RETURN -C - 400 ML = IWM(1) - MU = IWM(2) - MEBAND = 2*ML + MU + 1 - CALL DGBSL (WM(3), MEBAND, N, ML, MU, IWM(31), X, 0) - RETURN -C----------------------- End of Subroutine DVSOL ----------------------- - END -*DECK DVSRCO - - SUBROUTINE DVSRCO (RSAV, ISAV, JOB) - DOUBLE PRECISION RSAV - INTEGER ISAV, JOB - DIMENSION RSAV(*), ISAV(*) -C----------------------------------------------------------------------- -C Call sequence input -- RSAV, ISAV, JOB -C Call sequence output -- RSAV, ISAV -C COMMON block variables accessed -- All of /DVOD01/ and /DVOD02/ -C -C Subroutines/functions called by DVSRCO.. None -C----------------------------------------------------------------------- -C This routine saves or restores (depending on JOB) the contents of the -C COMMON blocks DVOD01 and DVOD02, which are used internally by DVODE. -C -C RSAV = real array of length 49 or more. -C ISAV = integer array of length 41 or more. -C JOB = flag indicating to save or restore the COMMON blocks.. -C JOB = 1 if COMMON is to be saved (written to RSAV/ISAV). -C JOB = 2 if COMMON is to be restored (read from RSAV/ISAV). -C A call with JOB = 2 presumes a prior call with JOB = 1. -C----------------------------------------------------------------------- - DOUBLE PRECISION RVOD1, RVOD2 - INTEGER IVOD1, IVOD2 - INTEGER I, LENIV1, LENIV2, LENRV1, LENRV2 -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the - -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE LENRV1, LENIV1, LENRV2, LENIV2 -C - COMMON /DVOD01/ RVOD1(48), IVOD1(33) - COMMON /DVOD02/ RVOD2(1), IVOD2(8) - DATA LENRV1/48/, LENIV1/33/, LENRV2/1/, LENIV2/8/ -C - IF (JOB .EQ. 2) GO TO 100 - DO 10 I = 1,LENRV1 - 10 RSAV(I) = RVOD1(I) - DO 15 I = 1,LENRV2 - - 15 RSAV(LENRV1+I) = RVOD2(I) -C - DO 20 I = 1,LENIV1 - 20 ISAV(I) = IVOD1(I) - DO 25 I = 1,LENIV2 - 25 ISAV(LENIV1+I) = IVOD2(I) -C - RETURN -C - 100 CONTINUE - DO 110 I = 1,LENRV1 - 110 RVOD1(I) = RSAV(I) - DO 115 I = 1,LENRV2 - 115 RVOD2(I) = RSAV(LENRV1+I) -C - DO 120 I = 1,LENIV1 - 120 IVOD1(I) = ISAV(I) - DO 125 I = 1,LENIV2 - 125 IVOD2(I) = ISAV(LENIV1+I) -C - RETURN -C----------------------- End of Subroutine DVSRCO ---------------------- - - END -*DECK DEWSET - SUBROUTINE DEWSET (N, ITOL, RTOL, ATOL, YCUR, EWT) - DOUBLE PRECISION RTOL, ATOL, YCUR, EWT - INTEGER N, ITOL - DIMENSION ATOL(*), YCUR(N), EWT(N) -C----------------------------------------------------------------------- -C Call sequence input -- N, ITOL, RTOL, ATOL, YCUR -C Call sequence output -- EWT -C COMMON block variables accessed -- None -C -C Subroutines/functions called by DEWSET.. None -C----------------------------------------------------------------------- -C This subroutine sets the error weight vector EWT according to -C EWT(i) = RTOL(i)*abs(YCUR(i)) + ATOL(i), i = 1,...,N, -C with the subscript on RTOL and/or ATOL possibly replaced by 1 above, -C depending on the value of ITOL. -C----------------------------------------------------------------------- - INTEGER I -C - GO TO (10, 20, 30, 40), ITOL - 10 CONTINUE - DO 15 I = 1, N - 15 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(1) - RETURN - 20 CONTINUE - DO 25 I = 1, N - 25 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(I) - RETURN - 30 CONTINUE - - DO 35 I = 1, N - - 35 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(1) - RETURN - 40 CONTINUE - DO 45 I = 1, N - 45 EWT(I) = RTOL*ABS(YCUR(I)) + ATOL(I) - RETURN - -C----------------------- End of Subroutine DEWSET ---------------------- - - END -*DECK DVNORM - DOUBLE PRECISION FUNCTION DVNORM (N, V, W) - DOUBLE PRECISION V, W - INTEGER N - DIMENSION V(N), W(N) -C----------------------------------------------------------------------- - -C Call sequence input -- N, V, W -C Call sequence output -- None -C COMMON block variables accessed -- None -C -C Subroutines/functions called by DVNORM.. None -C----------------------------------------------------------------------- -C This function routine computes the weighted root-mean-square norm -C of the vector of length N contained in the array V, with weights -C contained in the array W of length N.. -C DVNORM = sqrt( (1/N) * sum( V(i)*W(i) )**2 ) -C----------------------------------------------------------------------- - DOUBLE PRECISION SUM - INTEGER I -C - SUM = 0.0D0 - DO 10 I = 1, N - 10 SUM = SUM + (V(I)*W(I))**2 - DVNORM = SQRT(SUM/REAL(N)) - RETURN -C----------------------- End of Function DVNORM ------------------------ - END -*DECK D1MACH - DOUBLE PRECISION FUNCTION D1MACH (IDUM) - INTEGER IDUM -C----------------------------------------------------------------------- -C This routine computes the unit roundoff of the machine. -C This is defined as the smallest positive machine number -C u such that 1.0 + u .ne. 1.0 -C -C Subroutines/functions called by D1MACH.. None -C----------------------------------------------------------------------- - DOUBLE PRECISION U, COMP - U = 1.0D0 - 10 U = U*0.5D0 - COMP = 1.0D0 + U - IF (COMP .NE. 1.0D0) GO TO 10 - D1MACH = U*2.0D0 - RETURN -C----------------------- End of Function D1MACH ------------------------ - END - -*DECK XERRWD - - SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) - DOUBLE PRECISION R1, R2 - - INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR - CHARACTER*1 MSG(NMES),ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - COMMON/NXER/NXE -C NXE (NO. OF CALLS TO THIS ROUTINE) IS PASSED BACK TO MAIN FOR -C WRITING TO THE SCREEN. - - - - - -C----------------------------------------------------------------------- -C Subroutines XERRWD, XSETF, XSETUN, and the two function routines -C MFLGSV and LUNSAV, as given here, constitute a simplified version of -C the SLATEC error handling package. - -C Written by A. C. Hindmarsh and P. N. Brown at LLNL. - -C Version of 13 April, 1989. -C This version is in double precision. -C -C All arguments are input arguments. -C -C MSG = The message (character array). -C NMES = The length of MSG (number of characters). -C NERR = The error number (not used). - -C LEVEL = The error level.. -C 0 or 1 means recoverable (control returns to caller). -C 2 means fatal (run is aborted--see note below). -C NI = Number of integers (0, 1, or 2) to be printed with message. -C I1,I2 = Integers to be printed, depending on NI. -C NR = Number of reals (0, 1, or 2) to be printed with message. -C R1,R2 = Reals to be printed, depending on NR. -C - -C Note.. this routine is machine-dependent and specialized for use - -C in limited context, in the following ways.. -C 1. The argument MSG is assumed to be of type CHARACTER, and -C the message is printed with a format of (1X,80A1). -C 2. The message is assumed to take only one line. -C Multi-line messages are generated by repeated calls. -C 3. If LEVEL = 2, control passes to the statement STOP -C to abort the run. This statement may be machine-dependent. -C 4. R1 and R2 are assumed to be in double precision and are printed -C in D21.13 format. -C -C For a different default logical unit number, change the data - -C statement in function routine LUNSAV. -C For a different run-abort command, change the statement following -C statement 100 at the end. -C----------------------------------------------------------------------- -C Subroutines called by XERRWD.. None -C Function routines called by XERRWD.. MFLGSV, LUNSAV -C----------------------------------------------------------------------- -C - INTEGER I, LUNIT, LUNSAV, MESFLG, MFLGSV - -C SKIP ALL ERROR MESSAGES, SIMPLY GO TO LABEL 100. BUT KEEP A RUNNING - -C TOTAL OF CALLS TO THIS ROUTINE, NXE, AND RETURN IT TO MAIN FOR -C OUTPUT. - - NXE = NXE + 1 - GO TO 100 - - - -C Get message print flag and logical unit number. ---------------------- - - MESFLG = MFLGSV (0,.FALSE.) - LUNIT = LUNSAV (0,.FALSE.) - - IF (MESFLG .EQ. 0) GO TO 100 -C Write the message. --------------------------------------------------- - WRITE (LUNIT,10) (MSG(I),I=1,NMES) - 10 FORMAT(1X,80A1) - IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 - - 20 FORMAT(6X,'In above message, I1 =',I10) - IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 - 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) - IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 - 40 FORMAT(6X,'In above message, R1 =',D21.13) - IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 - 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) -C Abort the run if LEVEL = 2. ------------------------------------------ - 100 IF (LEVEL .NE. 2) RETURN - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - WRITE(47,51) - 51 FORMAT(/' LEVEL 2 (FATAL) IN SUBROUTINE XERRWD. '/) - CLOSE(47) - - - - CALL PAUSE - STOP -C----------------------- End of Subroutine XERRWD ---------------------- - END -*DECK XSETF - SUBROUTINE XSETF (MFLAG) -C----------------------------------------------------------------------- -C This routine resets the print control flag MFLAG. -C -C Subroutines called by XSETF.. None -C Function routines called by XSETF.. MFLGSV -C----------------------------------------------------------------------- - INTEGER MFLAG, JUNK, MFLGSV -C - IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = MFLGSV (MFLAG,.TRUE.) - RETURN - -C----------------------- End of Subroutine XSETF ----------------------- - END -*DECK XSETUN - SUBROUTINE XSETUN (LUN) -C----------------------------------------------------------------------- -C This routine resets the logical unit number for messages. -C -C Subroutines called by XSETUN.. None -C Function routines called by XSETUN.. LUNSAV -C----------------------------------------------------------------------- - INTEGER LUN, JUNK, LUNSAV -C - - IF (LUN .GT. 0) JUNK = LUNSAV (LUN,.TRUE.) - - RETURN -C----------------------- End of Subroutine XSETUN ---------------------- - END -*DECK MFLGSV - INTEGER FUNCTION MFLGSV (IVALUE, ISET) - LOGICAL ISET - INTEGER IVALUE -C----------------------------------------------------------------------- -C MFLGSV saves and recalls the parameter MESFLG which controls the -C printing of the error messages. -C -C Saved local variable.. - -C -C MESFLG = Print control flag.. -C 1 means print all messages (the default). -C 0 means no printing. -C -C On input.. -C -C IVALUE = The value to be set for the MESFLG parameter, -C if ISET is .TRUE. . -C -C ISET = Logical flag to indicate whether to read or write. - -C If ISET=.TRUE., the MESFLG parameter will be given -C the value IVALUE. If ISET=.FALSE., the MESFLG -C parameter will be unchanged, and IVALUE is a dummy -C parameter. -C -C On return.. -C -C The (old) value of the MESFLG parameter will be returned -C in the function value, MFLGSV. -C -C This is a modification of the SLATEC library routine J4SAVE. -C -C Subroutines/functions called by MFLGSV.. None -C----------------------------------------------------------------------- - INTEGER MESFLG -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. - -C----------------------------------------------------------------------- - SAVE MESFLG - DATA MESFLG/1/ -C - MFLGSV = MESFLG - IF (ISET) MESFLG = IVALUE - RETURN -C----------------------- End of Function MFLGSV ------------------------ - END -*DECK LUNSAV - INTEGER FUNCTION LUNSAV (IVALUE, ISET) - LOGICAL ISET - INTEGER IVALUE -C----------------------------------------------------------------------- -C LUNSAV saves and recalls the parameter LUNIT which is the logical -C unit number to which error messages are printed. -C -C Saved local variable.. -C -C LUNIT = Logical unit number for messages. -C The default is 6 (machine-dependent). -C -C On input.. -C -C IVALUE = The value to be set for the LUNIT parameter, -C if ISET is .TRUE. . -C -C ISET = Logical flag to indicate whether to read or write. -C If ISET=.TRUE., the LUNIT parameter will be given -C the value IVALUE. If ISET=.FALSE., the LUNIT -C parameter will be unchanged, and IVALUE is a dummy -C parameter. -C - -C On return.. -C -C The (old) value of the LUNIT parameter will be returned -C in the function value, LUNSAV. -C -C This is a modification of the SLATEC library routine J4SAVE. -C -C Subroutines/functions called by LUNSAV.. None -C----------------------------------------------------------------------- - INTEGER LUNIT -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this integrator. -C----------------------------------------------------------------------- - SAVE LUNIT - DATA LUNIT/6/ -C - LUNSAV = LUNIT - IF (ISET) LUNIT = IVALUE - RETURN -C----------------------- End of Function LUNSAV ------------------------ - END - -C*********************************************************************** -C*********************************************************************** - -C VODEXT.FOR IS SIMPLY A CONCATENATION OF 9 MODULES NEEDED BY -C VODE.FOR. THEY ARE FOUND IN ftp.netlib.org on the web. - -C In \BLAS -c DCOPY.F DSCAL.F DAXPY.F DDOT.F IDAMAX.F - -C In \LINPACK -c DGEFA.F DGESL.F DGBFA.F DGBSL.F - -C ALL ABOVE MODULES HAVE BEEN COPIED INTO FILES WITH EXTENSION .FOR. - - -C----------------------------------------------------------------------- - - subroutine dgefa(a,lda,n,ipvt,info) - integer lda,n,ipvt(1),info - - double precision a(lda,1) - -c -c dgefa factors a double precision matrix by gaussian elimination. -c -c dgefa is usually called by dgeco, but it can be called -c directly with a saving in time if rcond is not needed. -c (time for dgeco) = (1 + 9/n)*(time for dgefa) . -c -c on entry -c -c a double precision(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return - -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. - -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgesl or dgedi will divide by zero -c if called. use rcond in dgeco for a reliable -c indication of singularity. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions - -c -c blas daxpy,dscal,idamax -c - - -c internal variables -c - double precision t - integer idamax,j,k,kp1,l,nm1 -c -c -c gaussian elimination with partial pivoting -c - info = 0 - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 k = 1, nm1 - kp1 = k + 1 -c -c find l = pivot index -c - l = idamax(n-k+1,a(k,k),1) + k - 1 - ipvt(k) = l -c -c zero pivot implies this column already triangularized -c - if (a(l,k) .eq. 0.0d0) go to 40 -c -c interchange if necessary -c - if (l .eq. k) go to 10 - t = a(l,k) - a(l,k) = a(k,k) - a(k,k) = t - 10 continue -c -c compute multipliers -c - t = -1.0d0/a(k,k) - call dscal(n-k,t,a(k+1,k),1) -c -c row elimination with column indexing -c - do 30 j = kp1, n - t = a(l,j) - if (l .eq. k) go to 20 - - a(l,j) = a(k,j) - a(k,j) = t - 20 continue - call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) - 30 continue - go to 50 - 40 continue - info = k - 50 continue - 60 continue - 70 continue - ipvt(n) = n - if (a(n,n) .eq. 0.0d0) info = n - return - end - -C----------------------------------------------------------------------- - - subroutine dgesl(a,lda,n,ipvt,b,job) - - integer lda,n,ipvt(1),job - double precision a(lda,1),b(1) -c - -c dgesl solves the double precision system -c a * x = b or trans(a) * x = b -c using the factors computed by dgeco or dgefa. -c -c on entry -c -c a double precision(lda, n) -c the output from dgeco or dgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from dgeco or dgefa. -c -c b double precision(n) -c the right hand side vector. - -c -c job integer -c = 0 to solve a*x = b , -c = nonzero to solve trans(a)*x = b where -c trans(a) is the transpose. -c -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero will occur if the input factor contains a -c zero on the diagonal. technically this indicates singularity -c but it is often caused by improper arguments or improper -c setting of lda . it will not occur if the subroutines are -c called correctly and if dgeco has set rcond .gt. 0.0 -c or dgefa has set info .eq. 0 . -c -c to compute inverse(a) * c where c is a matrix -c with p columns -c call dgeco(a,lda,n,ipvt,rcond,z) -c if (rcond is too small) go to ... -c do 10 j = 1, p -c call dgesl(a,lda,n,ipvt,c(1,j),0) -c 10 continue -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,ddot -c -c internal variables -c - double precision ddot,t - integer k,kb,l,nm1 - - -c - nm1 = n - 1 - if (job .ne. 0) go to 50 -c -c job = 0 , solve a * x = b -c first solve l*y = b -c - if (nm1 .lt. 1) go to 30 - do 20 k = 1, nm1 - l = ipvt(k) - t = b(l) - if (l .eq. k) go to 10 - b(l) = b(k) - b(k) = t - 10 continue - call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) - 20 continue - 30 continue -c -c now solve u*x = y -c - do 40 kb = 1, n - k = n + 1 - kb - - - b(k) = b(k)/a(k,k) - t = -b(k) - call daxpy(k-1,t,a(1,k),1,b(1),1) - 40 continue - go to 100 - 50 continue -c -c job = nonzero, solve trans(a) * x = b -c first solve trans(u)*y = b -c - do 60 k = 1, n - - t = ddot(k-1,a(1,k),1,b(1),1) - b(k) = (b(k) - t)/a(k,k) - 60 continue -c -c now solve trans(l)*x = y -c - if (nm1 .lt. 1) go to 90 - do 80 kb = 1, nm1 - k = n - kb - b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) - l = ipvt(k) - if (l .eq. k) go to 70 - t = b(l) - b(l) = b(k) - - b(k) = t - 70 continue - 80 continue - 90 continue - 100 continue - - return - end - -C----------------------------------------------------------------------- - - subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) - integer lda,n,ml,mu,ipvt(1),info - double precision abd(lda,1) -c -c dgbfa factors a double precision band matrix by elimination. - -c -c dgbfa is usually called by dgbco, but it can be called -c directly with a saving in time if rcond is not needed. -c -c on entry -c -c abd double precision(lda, n) -c contains the matrix in band storage. the columns -c of the matrix are stored in the columns of abd and -c the diagonals of the matrix are stored in rows -c ml+1 through 2*ml+mu+1 of abd . -c see the comments below for details. -c -c lda integer -c the leading dimension of the array abd . -c lda must be .ge. 2*ml + mu + 1 . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c 0 .le. ml .lt. n . - -c -c mu integer -c number of diagonals above the main diagonal. -c 0 .le. mu .lt. n . -c more efficient if ml .le. mu . -c on return -c -c abd an upper triangular matrix in band storage and - -c the multipliers which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgbsl will divide by zero if - -c called. use rcond in dgbco for a reliable -c indication of singularity. -c -c band storage -c - -c if a is a band matrix, the following program segment -c will set up the input. -c -c ml = (band width below the diagonal) -c mu = (band width above the diagonal) -c m = ml + mu + 1 -c do 20 j = 1, n -c i1 = max0(1, j-mu) -c i2 = min0(n, j+ml) - - -c do 10 i = i1, i2 -c k = i - j + m -c abd(k,j) = a(i,j) - -c 10 continue -c 20 continue -c -c this uses rows ml+1 through 2*ml+mu+1 of abd . -c in addition, the first ml rows in abd are used for -c elements generated during the triangularization. -c the total number of rows needed in abd is 2*ml+mu+1 . -c the ml+mu by ml+mu upper left triangle and the -c ml by ml lower right triangle are not referenced. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,idamax -c fortran max0,min0 - -c -c internal variables -c - double precision t - integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 -c -c - m = ml + mu + 1 - info = 0 -c -c zero initial fill-in columns -c - - j0 = mu + 2 - j1 = min0(n,m) - 1 - if (j1 .lt. j0) go to 30 - do 20 jz = j0, j1 - i0 = m + 1 - jz - do 10 i = i0, ml - abd(i,jz) = 0.0d0 - 10 continue - 20 continue - 30 continue - jz = j1 - ju = 0 -c -c gaussian elimination with partial pivoting -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 130 - do 120 k = 1, nm1 - kp1 = k + 1 -c -c zero next fill-in column -c - jz = jz + 1 - if (jz .gt. n) go to 50 - - - if (ml .lt. 1) go to 50 - do 40 i = 1, ml - abd(i,jz) = 0.0d0 - 40 continue - 50 continue -c -c find l = pivot index -c - lm = min0(ml,n-k) - l = idamax(lm+1,abd(m,k),1) + m - 1 - ipvt(k) = l + k - m -c -c zero pivot implies this column already triangularized -c - if (abd(l,k) .eq. 0.0d0) go to 100 -c -c interchange if necessary -c - if (l .eq. m) go to 60 - t = abd(l,k) - abd(l,k) = abd(m,k) - abd(m,k) = t - - 60 continue -c -c compute multipliers -c - t = -1.0d0/abd(m,k) - call dscal(lm,t,abd(m+1,k),1) -c -c row elimination with column indexing -c - ju = min0(max0(ju,mu+ipvt(k)),n) - mm = m - if (ju .lt. kp1) go to 90 - do 80 j = kp1, ju - l = l - 1 - mm = mm - 1 - t = abd(l,j) - if (l .eq. mm) go to 70 - - abd(l,j) = abd(mm,j) - abd(mm,j) = t - 70 continue - call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) - 80 continue - 90 continue - go to 110 - 100 continue - info = k - - 110 continue - 120 continue - - 130 continue - - ipvt(n) = n - if (abd(m,n) .eq. 0.0d0) info = n - return - end - -C----------------------------------------------------------------------- - - subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) - integer lda,n,ml,mu,ipvt(1),job - - double precision abd(lda,1),b(1) -c -c dgbsl solves the double precision band system -c a * x = b or trans(a) * x = b - -c using the factors computed by dgbco or dgbfa. -c -c on entry -c -c abd double precision(lda, n) -c the output from dgbco or dgbfa. -c -c lda integer -c the leading dimension of the array abd . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c -c mu integer -c number of diagonals above the main diagonal. -c -c ipvt integer(n) -c the pivot vector from dgbco or dgbfa. -c - -c b double precision(n) -c the right hand side vector. -c -c job integer -c = 0 to solve a*x = b , -c = nonzero to solve trans(a)*x = b , where -c trans(a) is the transpose. -c -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero will occur if the input factor contains a -c zero on the diagonal. technically this indicates singularity -c but it is often caused by improper arguments or improper - -c setting of lda . it will not occur if the subroutines are -c called correctly and if dgbco has set rcond .gt. 0.0 -c or dgbfa has set info .eq. 0 . -c -c to compute inverse(a) * c where c is a matrix -c with p columns -c call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) -c if (rcond is too small) go to ... -c do 10 j = 1, p -c call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) -c 10 continue -c -c linpack. this version dated 08/14/78 . - - -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,ddot -c fortran min0 -c -c internal variables -c - double precision ddot,t - integer k,kb,l,la,lb,lm,m,nm1 -c - - m = mu + ml + 1 - nm1 = n - 1 - - if (job .ne. 0) go to 50 - -c -c job = 0 , solve a * x = b -c first solve l*y = b -c - if (ml .eq. 0) go to 30 - if (nm1 .lt. 1) go to 30 - do 20 k = 1, nm1 - lm = min0(ml,n-k) - l = ipvt(k) - t = b(l) - if (l .eq. k) go to 10 - b(l) = b(k) - b(k) = t - - - 10 continue - call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) - 20 continue - 30 continue -c -c now solve u*x = y -c - do 40 kb = 1, n - k = n + 1 - kb - b(k) = b(k)/abd(m,k) - lm = min0(k,m) - 1 - la = m - lm - lb = k - lm - t = -b(k) - call daxpy(lm,t,abd(la,k),1,b(lb),1) - 40 continue - go to 100 - 50 continue -c -c job = nonzero, solve trans(a) * x = b -c first solve trans(u)*y = b -c - do 60 k = 1, n - lm = min0(k,m) - 1 - la = m - lm - lb = k - lm - t = ddot(lm,abd(la,k),1,b(lb),1) - b(k) = (b(k) - t)/abd(m,k) - 60 continue -c -c now solve trans(l)*x = y -c - if (ml .eq. 0) go to 90 - if (nm1 .lt. 1) go to 90 - do 80 kb = 1, nm1 - k = n - kb - lm = min0(ml,n-k) - b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) - l = ipvt(k) - if (l .eq. k) go to 70 - t = b(l) - b(l) = b(k) - b(k) = t - 70 continue - 80 continue - 90 continue - 100 continue - return - end - - - subroutine checkd(corden,new,nactveold,ab,maxgrd,nvar,iclose) - - implicit real*8 (a-h,o-z) - real*8 ab(30,2), corden(maxgrd,1) - iclose=0 - do ibas=1,nactveold - sum=0. - do i=1,nvar - sum=sum+abs(corden(new,i)-corden(ibas,i))/(ab(i,2)-ab(i,1)) - enddo - if(sum.le.1.d-4) then - iclose=1 - return - endif - enddo - return - end - - - subroutine emint(psi,ldpsi,theta,ldtheta,npoint,nsub,ijob, - & x,dx,y,dy,fobj,gap,nvar,keep,IHESS) - - implicit real*8 (a-h,o-z) - real*8 mu - dimension psi(ldpsi,*),theta(ldtheta,*),x(*),dx(*),y(*),dy(*) - - -c This subroutine solves the 'EM' problem of maximizing the function - -c fobj(x) = sum_i (log[sum_j ( psi(i,j) * x(j)) ] ), -c j=1,..,npoint and i=1,...,nsub -c subject to: x(j) >= 0, sum_j x(j) = 1 (i.e. x is a probability -c vector of length npoint) -c where psi(i,j) is a fixed non-negative data array representing the -c likelihood of point j for subject i - -c inputs: psi,ldpsi,npoint,nsub,nvar -c psi contains the likelihood vectors for each subject - the i-th -c row of psi is likelikhood vector for subject i. Thus psi(i,j) is -c likelihood of the j-th point for c the i-th subject. The input value -c ldpsi is the 'leading dimension of psi' - i.e. the first dimension of the -c array psi as dimensioned in the calling program. -c -c input work arrays: dx(*), y(*), dy(*) - should be at least large enough to -c contain npoint points, as should the probabiltiy array x(*) - -c -c outputs: x(*), fobj -c x(i) is final probability for point i -c fobj - optimal value of the objective function - -c note - usually npoint is much larger than nsub; here we dimension - -c some internal work arrays with the maximum expected number of subjects -c MAXSUBem and the maximum number of points MAXACTem -c are be set in the parameter statement - - - parameter (MAXSUBem=999,MAXACTem=10000000) - dimension w(MAXSUBem),dw(MAXSUBem),Ptx(MAXSUBem), - & hess(MAXSUBem,2*MAXSUBem) - dimension psisum(MAXSUBem) - - integer kpvt(MAXSUBem), ipivot(MAXACTem), list(MAXACTem) - - CHARACTER ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - -C DATA ILOOP/0/ -C ILOOP IS USED BELOW TO KNOW WHEN TO WRITE MESSAGE TO USER IN CASE -C THE OPTIMIZATION TAKES A 'LONG' TIME. - - -c here w(*) is a vector if `dual variables' -c dw(*) is a calculated change (as a Newton step) in w(*) -c Ptx(*) (Psi times x) is the vector Ptx(j) = sum_i Psi(j,i)*x(i) -c first , perform some dimension checks to make sure no internal dimensions -c are exceeded - keep = nactve - - - - if(nsub.gt.MAXSUBem) then - - - - write(6,*) 'nsub =',nsub, ' is greater than MAXSUBem=',MAXSUBem - write(6,*) 'MAXSUBem needs to be reset as large as nsub' - write(6,*) 'in PARAMETER statement in subroutine emint' - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - write(47,*) 'nsub =',nsub, ' is greater than MAXSUBem=',MAXSUBem - write(47,*) 'MAXSUBem needs to be reset as large as nsub' - write(47,*) 'in PARAMETER statement in subroutine emint' - CLOSE(47) - - - - CALL PAUSE - stop - - - - endif - - - - if(npoint.gt.MAXACTem) then - - - - write(6,*) 'npoint=',npoint,' is larger than MAXACTem=',MAXACTem - write(6,*) 'MAXACTem needs to be reset as large as npoint' - write(6,*) 'in PARAMETER statement in subroutine emint' - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - write(47,*) 'npoint=',npoint,' is larger than MAXACTem=',MAXACTem - write(47,*) 'MAXACTem needs to be reset as large as npoint' - write(47,*) 'in PARAMETER statement in subroutine emint' - CLOSE(47) - - - - CALL PAUSE - stop - - - - endif - - - -c Second, check that psi is non-negative - psimin=0. - do j=1,nsub - do i=1,npoint - if(psi(j,i).le.psimin) psimin=psi(j,i) - enddo - enddo - - - - if(psimin.lt.0) then - - - - write(6,*) 'Psi matrix not non-negative -stop' - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - write(47,*) 'Psi matrix not non-negative -stop' - CLOSE(47) - - - - CALL PAUSE - stop - - - - endif - - - -c Third,check that the row sums of psi are positive - no zero rows -c also initialize x and w - colsummin=1.e10 - do j=1,nsub - s=0. - do i=1,npoint - x(i)=1.d0 - s=s+psi(j,i) - enddo - psisum(j) = s - Ptx(j)=s - if(s.le.colsummin) colsummin=s - - - - if(s.le.0) then - - - - write(6,*) 'psi has a zero row -stop' - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE - -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - write(47,*) 'psi has a zero row -stop' - CLOSE(47) - - - - CALL PAUSE - stop - - - - endif - - - - w(j)=1./s - enddo -c calc ptw = w'*psi - shrink=0. - do i=1,npoint - sum=0.d0 - do j=1,nsub - sum=sum+psi(j,i)*w(j) - enddo - y(i)=sum - if(sum.gt.shrink) shrink=sum - enddo - shrink=2.d0*shrink - - if(s.le.0) then - - write(6,*) 'Psi has a zero column -stop' - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - write(47,*) 'Psi has a zero column -stop' - CLOSE(47) - - CALL PAUSE - stop - - endif - -c stopping tolerance - eps=1.d-10 - sig=0.d0 - mu=0.d0 - do i=1,npoint -c x = x*shrink; - x(i)=1.d0*shrink -c Ptw = Ptw/shrink; - y(i)=y(i)/shrink -c y = ecol-Ptw; - y(i)=1.d0-y(i) -c mu = (x'*y)/npoint; - mu=mu+x(i)*y(i) - enddo - mu=mu/npoint - rmax = -1.e38 - do j=1,nsub -c w = w/shrink; - w(j)=w(j)/shrink -c Plam = Plam*shrink; - - Ptx(j)=Ptx(j)*shrink -c -c R = erow-w.*Plam; - if(dabs(1.d0-w(j)*Ptx(j)).ge.rmax) rmax = - & dabs(1.d0-w(j)*Ptx(j)) - enddo - gap=1.d0 -c start of iterations - iter=0 -100 continue -c following is iteration termination condition - - - conval = mu - if(conval .lt. rmax) conval = rmax - if(conval .lt. gap) conval = gap - convcrit = eps/conval -C IF(ILOOP .GT. 0) WRITE(*,123) iter,convcrit -C123 FORMAT(' Iteration ',I9,' CONV. CRIT = ',G15.2,' (1 OR HIGHER FOR -C 1CONVERGENCE)') - -C ABOVE WRITE STATEMENT ADDED IN bigmlt12.f SO THE USER WILL KNOW -C THE PROGRAM HAS NOT 'HUNG' IF THE OPTIMIZATION TAKES A 'LONG' TIME. - - - if(mu.le.eps.and.rmax.le.eps.and.gap.le.eps) go to 9000 - iter=iter+1 - - ILOOP = ILOOP + 1 - - tbuilda=0 - smu=sig*mu -c zero out hessian - do j=1,nsub - do k=1,nsub - hess(j,k)=0. - enddo - enddo -c do outer product portion of Hessian - do i=1,npoint - scale=x(i)/y(i) - do j=1,nsub - fact=scale*psi(j,i) - do k=j,nsub - hess(k,j)=hess(k,j)+fact*psi(k,i) - enddo - enddo - enddo - do j=1,nsub-1 - do k=j+1,nsub - - hess(j,k)=hess(k,j) - enddo - enddo -c do diagonal portion of hessian - do j=1,nsub - hess(j,j)=hess(j,j)+Ptx(j)/w(j) - enddo - tbuildb=0 - tbuild=tbuildb-tbuilda - - -c now do cholesky decomposition-for time bing, use simple dpofa -c from LINPACK -c call dpofa(hess,MAXSUBem,nsub,info) -c call dsifa(hess,MAXSUBem,nsub,kpvt,info) -c note dpofa is cholesky factorization routine from LINPACK -c dsifa is symmetric indefintie factorization routine from LINAPCK -c DPOTRF is Cholesky factorization routine from LAPACK -c DPOTRF is fastest of the three, but DSIFA may be more reliable for -c nearly singular cases -c Regardless of which of the three routines is used, it must be matched -c with the proper solve routine (dposl for dpofa, dsisl for dsifa, -c DPOTRS for DPOTRF below - - - CALL DPOTRF( 'L', nsub, hess, MAXSUBem, INFO ) - tbuildc=0 - tfactor=tbuildc-tbuildb - - -c As of npageng18.f, set IHESS = 0. If info .ne. 0, reset it = -1 and, -c after writing the indicated message to the screen (and also now to -c the output file), return to MAIN, where IHESS = -1 tells the program -c to create the output files before stopping (previously, if -c info .ne. 0, the program would simply stop after writing the -c indicated message to the screen). - - IHESS = 0 - - if(info .ne. 0) then - - IHESS = -1 - - WRITE(*,163) - 163 FORMAT(//' Hessian matrix in interior point EM algorithm'/ - 1' is singular. Possibly number of grid points is too small,'/ - 2' or assay coefficients are too large. '// - 3' Try again with a new assay polynomial or larger grid.'// - 4' Suggested quick fix: rerun and select error model 2)'/ - 5' in response to the initial question; then enter a'/ - 6' initial value gamma = 10.0 in response to the prompt for'/ - 7' that value.'// - 8' THIS IS IN MODULE NPAGFULL.FOR. '//) - - - WRITE(*,164) info - 164 FORMAT(//' NOTE THAT IN SUBROUTINE emint, THE VALUE OF INFO'/ - 1' IS ',i6,// - 2' IF THIS VALUE IS POSTIVE, IT IS LIKELY THE NO. OF THE SUBJECT'/ - 3' (OR AT LEAST THE FIRST SUBJECT) WHICH CAUSED THE HESSIAN '/ - - 4' ERROR. SO IN THIS CASE, YOU MIGHT ALSO WANT TO EXAMINE THE'/ - 5' DATA IN THIS SUBJECT TO VERIFY THEY ARE CORRECT.'//) - -c As of npageng22.f, the following PAUSE is commented out ... since -c it --> the program will not complete properly if it is run under -c Pmetrics (which cannot supply a keyboard response during a run). -c CALL PAUSE - -c As of npageng18.f, the program does not stop here; it returns to -c MAIN to write out the output files and then stops. - - return - - endif - - - -c construct rhs for linear equation system - do j=1,nsub - sum=0.d0 - do i=1,npoint - - sum=sum+psi(j,i)*smu/y(i) - enddo - dw(j)=1.d0/w(j)-sum - enddo -c now solve linear system with LINPACK routine dposl -c and put answer in dw -c note - these routines match the factor routines dpofa, dsifa, and DPOTRF, respectively -c see note about 15 lines back where the factor routine is called -c call dposl(hess,MAXSUBem,nsub,dw) - -c call dsisl(hess,MAXSUBem,nsub,kpvt,dw) - call DPOTRS( 'L', nsub, 1, hess, MAXSUBem, dw, nsub, INFO ) -c now compute dy and dx from dw - - do i=1,npoint - sum=0. - do j=1,nsub - sum=sum+psi(j,i)*dw(j) - enddo - dy(i)=-sum - dx(i)=smu/y(i)-x(i)-dy(i)*x(i)/y(i) - enddo -c damp the Newton step - alfpri=-.5 - do i=1,npoint - if(dx(i)/x(i).le.alfpri) alfpri=dx(i)/x(i) - enddo - alfpri=-1.d0/alfpri - alfpri=min(1.d0,0.99995*alfpri) - alfdual=-0.5d0 - do i=1,npoint - if(dy(i)/y(i).le.alfdual) alfdual=dy(i)/y(i) - enddo - alfdual=-1.d0/alfdual - - alfdual=min(1.d0,0.99995*alfdual) - mu=0.d0 - do i=1,npoint - x(i)=x(i)+alfpri*dx(i) - y(i)=y(i)+alfdual*dy(i) - mu=mu+x(i)*y(i) - enddo - mu=mu/npoint - do j=1,nsub - sum=0.d0 - do i=1,npoint - sum=sum+psi(j,i)*x(i) - enddo - - Ptx(j)=sum - enddo - do j=1,nsub - w(j)=w(j)+alfdual*dw(j) - - enddo -c compute rmax (norm(r,inf)-note we don't really need to compute r - rmax=0. - do j=1,nsub - rtest=1.d0-w(j)*Ptx(j) - if(dabs(rtest).gt.rmax) rmax=dabs(rtest) - enddo - sumlogw=0.d0 - sumlgPtx=0.d0 - do j=1,nsub - sumlogw=sumlogw+dlog(w(j)) - sumlgPtx=sumlgPtx+dlog(Ptx(j)) - enddo - gap = dabs(sumlogw+sumlgPtx)/(1.d0+dabs(sumlgPtx)) - if(mu.lt.eps.and.rmax.gt.eps) then - sig=1.d0 - else - c2=1.d2 - term1=(1.d0-alfpri)**2 - term2=(1.d0-alfdual)**2 - term3=(rmax-mu)/(rmax+c2*mu) - term=max(term1,term2) - term=max(term,term3) - sig=min(0.3d0,term) - endif - sumx=0.d0 - do i=1,npoint - sumx=sumx+x(i) - enddo - fobj=0. - do j=1,nsub - fobj=fobj+dlog(Ptx(j)/sumx) - enddo - go to 100 -c following is exit point -9000 continue -c finish by normalizing x to sum to 1. -c fobj has already been computed - sumx=0. - do i=1,npoint - sumx=sumx+x(i) - enddo - do i=1,npoint - x(i)=x(i)/sumx - enddo -c finished if ijob=0 - if(ijob.eq.0) return - isum=0 - xlim=0. - do i=1,npoint - if(x(i).gt.xlim) xlim=x(i) - enddo - xlim=xlim*1.d-3 - isum = 0 - do i=1,npoint - if(x(i).gt.xlim) then - isum = isum + 1 - list(isum) = i - do j=1,nsub - psi(j,isum) = psi(j,i) - enddo -cpull -c now condense the original density grid - do j=1,nvar - theta(isum,j)=theta(i,j) - enddo - x(isum)=x(i) - endif - enddo - job=1 - do k=1,npoint - ipivot(k)=0 - enddo -c save a copy of psi after current end of psi - do i=1,isum - do j=1,nsub - psi(j,i+isum)=psi(j,i) - enddo - enddo - do i=1,isum - do j=1,nsub - psi(j,i) = psi(j,i)/psisum(j) - enddo - enddo - call dqrdc(psi,ldpsi,nsub,isum,y,ipivot,dy,job) - - keep = 0 - limloop = nsub - if(isum.lt.nsub) limloop = isum - do i=1,limloop - test=dnrm2(i,psi(1,i),1) -cdebugwrite(6,*) i,psi(i,i),test,psi(i,i)/test - - if(dabs(psi(i,i)/test).ge.1.d-8) keep=keep+1 - enddo -c sort ipivot to avoid collisions during condensing - - if(isum.gt.1) then - do i=1,keep-1 - do j=i,keep - if(ipivot(i)*ipivot(j).ne.0.and.ipivot(i).gt.ipivot(j)) then - itemp=ipivot(i) - ipivot(i)=ipivot(j) - - ipivot(j)=itemp - endif - enddo - enddo - endif - do i=1,isum - do j=1,nsub - psi(j,i)=psi(j,i+isum) - enddo - enddo -c restore psi - - - - -C CALL PAUSE - do k=1,npoint - dx(k)=0 - enddo - sumkeep = 0. - do k=1,keep - j=ipivot(k) - - if(j.ne.0) then - do jj=1,nsub - psi(jj,k)=psi(jj,j) - enddo - do jvar=1,nvar - theta(k,jvar) = theta(j,jvar) - enddo - endif - if(j.gt.0) dx(list(j))=1. - if(j.gt.0) sumkeep = sumkeep + x(list(j)) - if(j.gt.0) w(k)=x(list(j)) - enddo - return - end - subroutine dpoco(a,lda,n,rcond,z,info) - integer lda,n,info - double precision a(lda,1),z(1) - double precision rcond -c -c dpoco factors a double precision symmetric positive definite -c matrix and estimates the condition of the matrix. -c -c if rcond is not needed, dpofa is slightly faster. -c to solve a*x = b , follow dpoco by dposl. -c to compute inverse(a)*c , follow dpoco by dposl. - -c to compute determinant(a) , follow dpoco by dpodi. -c to compute inverse(a) , follow dpoco by dpodi. -c - -c on entry -c -c a double precision(lda, n) -c the symmetric matrix to be factored. only the -c diagonal and upper triangle are used. -c - -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix r so that a = trans(r)*r - -c where trans(r) is the transpose. -c the strict lower triangle is unaltered. -c if info .ne. 0 , the factorization is not complete. -c -c rcond double precision -c an estimate of the reciprocal condition of a . -c for the system a*x = b , relative perturbations -c in a and b of size epsilon may cause -c relative perturbations in x of size epsilon/rcond . -c if rcond is so small that the logical expression -c 1.0 + rcond .eq. 1.0 -c is true, then a may be singular to working -c precision. in particular, rcond is zero if -c exact singularity is detected or the estimate -c underflows. if info .ne. 0 , rcond is unchanged. -c -c z double precision(n) -c a work vector whose contents are usually unimportant. -c if a is close to a singular matrix, then z is -c an approximate null vector in the sense that -c norm(a*z) = rcond*norm(a)*norm(z) . -c if info .ne. 0 , z is unchanged. -c -c info integer -c = 0 for normal return. -c = k signals an error condition. the leading minor -c of order k is not positive definite. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c linpack dpofa - - -c blas daxpy,ddot,dscal,dasum -c fortran dabs,dmax1,dreal,dsign -c -c internal variables -c - double precision ddot,ek,t,wk,wkm - double precision anorm,s,dasum,sm,ynorm - integer i,j,jm1,k,kb,kp1 -c -c -c find norm of a using only upper half -c - do 30 j = 1, n - z(j) = dasum(j,a(1,j),1) - jm1 = j - 1 - if (jm1 .lt. 1) go to 20 - do 10 i = 1, jm1 - - z(i) = z(i) + dabs(a(i,j)) - 10 continue - - 20 continue - 30 continue - anorm = 0.0d0 - do 40 j = 1, n - anorm = dmax1(anorm,z(j)) - 40 continue -c -c factor -c - call dpofa(a,lda,n,info) - if (info .ne. 0) go to 180 -c -c rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . -c estimate = norm(z)/norm(y) where a*z = y and a*y = e . -c the components of e are chosen to cause maximum local -c growth in the elements of w where trans(r)*w = e . -c the vectors are frequently rescaled to avoid overflow. - -c -c solve trans(r)*w = e -c - ek = 1.0d0 - do 50 j = 1, n - z(j) = 0.0d0 - 50 continue - do 110 k = 1, n - if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k)) - if (dabs(ek-z(k)) .le. a(k,k)) go to 60 - s = a(k,k)/dabs(ek-z(k)) - call dscal(n,s,z,1) - ek = s*ek - 60 continue - wk = ek - z(k) - wkm = -ek - z(k) - s = dabs(wk) - sm = dabs(wkm) - wk = wk/a(k,k) - wkm = wkm/a(k,k) - kp1 = k + 1 - if (kp1 .gt. n) go to 100 - do 70 j = kp1, n - sm = sm + dabs(z(j)+wkm*a(k,j)) - z(j) = z(j) + wk*a(k,j) - s = s + dabs(z(j)) - 70 continue - if (s .ge. sm) go to 90 - t = wkm - wk - wk = wkm - do 80 j = kp1, n - z(j) = z(j) + t*a(k,j) - 80 continue - 90 continue - 100 continue - z(k) = wk - 110 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c -c solve r*y = w -c - do 130 kb = 1, n - k = n + 1 - kb - if (dabs(z(k)) .le. a(k,k)) go to 120 - s = a(k,k)/dabs(z(k)) - call dscal(n,s,z,1) - 120 continue - z(k) = z(k)/a(k,k) - t = -z(k) - call daxpy(k-1,t,a(1,k),1,z(1),1) - 130 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c - ynorm = 1.0d0 -c -c solve trans(r)*v = y -c - do 150 k = 1, n - z(k) = z(k) - ddot(k-1,a(1,k),1,z(1),1) - if (dabs(z(k)) .le. a(k,k)) go to 140 - s = a(k,k)/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 140 continue - z(k) = z(k)/a(k,k) - 150 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm - - -c -c solve r*z = v -c - do 170 kb = 1, n - k = n + 1 - kb - if (dabs(z(k)) .le. a(k,k)) go to 160 - s = a(k,k)/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 160 continue - z(k) = z(k)/a(k,k) - t = -z(k) - call daxpy(k-1,t,a(1,k),1,z(1),1) - 170 continue -c make znorm = 1.0 - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c - if (anorm .ne. 0.0d0) rcond = ynorm/anorm - if (anorm .eq. 0.0d0) rcond = 0.0d0 - 180 continue - return - end - subroutine dpofa(a,lda,n,info) - integer lda,n,info - double precision a(lda,1) -c -c dpofa factors a double precision symmetric positive definite -c matrix. -c - -c dpofa is usually called by dpoco, but it can be called -c directly with a saving in time if rcond is not needed. -c (time for dpoco) = (1 + 18/n)*(time for dpofa) . -c -c on entry -c -c a double precision(lda, n) -c the symmetric matrix to be factored. only the -c diagonal and upper triangle are used. -c -c lda integer -c the leading dimension of the array a . - -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix r so that a = trans(r)*r -c where trans(r) is the transpose. -c the strict lower triangle is unaltered. -c if info .ne. 0 , the factorization is not complete. -c -c info integer -c = 0 for normal return. -c = k signals an error condition. the leading minor -c of order k is not positive definite. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas ddot -c fortran dsqrt -c -c internal variables -c - - double precision ddot,t - double precision s - integer j,jm1,k -c begin block with ...exits to 40 - -c -c - do 30 j = 1, n - info = j - s = 0.0d0 - jm1 = j - 1 - if (jm1 .lt. 1) go to 20 - do 10 k = 1, jm1 - t = a(k,j) - ddot(k-1,a(1,k),1,a(1,j),1) - t = t/a(k,k) - a(k,j) = t - s = s + t*t - 10 continue - 20 continue - s = a(j,j) - s -c ......exit - if (s .le. 0.0d0) go to 40 - a(j,j) = dsqrt(s) - 30 continue - info = 0 - 40 continue - return - end - subroutine dposl(a,lda,n,b) - - integer lda,n - double precision a(lda,1),b(1) -c - -c dposl solves the double precision symmetric positive definite -c system a * x = b -c using the factors computed by dpoco or dpofa. -c -c on entry -c -c a double precision(lda, n) -c the output from dpoco or dpofa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer - -c the order of the matrix a . -c -c b double precision(n) -c the right hand side vector. -c - -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero will occur if the input factor contains -c a zero on the diagonal. technically this indicates -c singularity but it is usually caused by improper subroutine -c arguments. it will not occur if the subroutines are called -c correctly and info .eq. 0 . -c -c to compute inverse(a) * c where c is a matrix - -c with p columns -c call dpoco(a,lda,n,rcond,z,info) -c if (rcond is too small .or. info .ne. 0) go to ... -c do 10 j = 1, p -c call dposl(a,lda,n,c(1,j)) -c 10 continue -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c - -c subroutines and functions -c -c blas daxpy,ddot -c -c internal variables -c - double precision ddot,t - integer k,kb -c -c solve trans(r)*y = b -c - do 10 k = 1, n - - t = ddot(k-1,a(1,k),1,b(1),1) - b(k) = (b(k) - t)/a(k,k) - 10 continue -c -c solve r*x = y -c - do 20 kb = 1, n - k = n + 1 - kb - b(k) = b(k)/a(k,k) - t = -b(k) - call daxpy(k-1,t,a(1,k),1,b(1),1) - 20 continue - return - end - subroutine dsifa(a,lda,n,kpvt,info) - integer lda,n,kpvt(1),info - double precision a(lda,1) -c -c dsifa factors a double precision symmetric matrix by elimination -c with symmetric pivoting. -c -c to solve a*x = b , follow dsifa by dsisl. -c to compute inverse(a)*c , follow dsifa by dsisl. -c to compute determinant(a) , follow dsifa by dsidi. -c to compute inertia(a) , follow dsifa by dsidi. -c to compute inverse(a) , follow dsifa by dsidi. -c -c on entry -c -c a double precision(lda,n) -c the symmetric matrix to be factored. -c only the diagonal and upper triangle are used. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a a block diagonal matrix and the multipliers which -c were used to obtain it. - -c the factorization can be written a = u*d*trans(u) -c where u is a product of permutation and unit -c upper triangular matrices , trans(u) is the -c transpose of u , and d is block diagonal - -c with 1 by 1 and 2 by 2 blocks. -c -c kpvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if the k-th pivot block is singular. this is -c not an error condition for this subroutine, -c but it does indicate that dsisl or dsidi may -c divide by zero if called. -c - -c linpack. this version dated 08/14/78 . -c james bunch, univ. calif. san diego, argonne nat. lab. - -c -c subroutines and functions -c -c blas daxpy,dswap,idamax -c fortran dabs,dmax1,dsqrt -c -c internal variables -c - double precision ak,akm1,bk,bkm1,denom,mulk,mulkm1,t - double precision absakk,alpha,colmax,rowmax - integer imax,imaxp1,j,jj,jmax,k,km1,km2,kstep,idamax - logical swap -c -c -c initialize -c -c alpha is used in choosing pivot block size. - alpha = (1.0d0 + dsqrt(17.0d0))/8.0d0 -c - info = 0 -c -c main loop on k, which goes from n to 1. -c - k = n - 10 continue -c -c leave the loop if k=0 or k=1. -c -c ...exit - if (k .eq. 0) go to 200 - if (k .gt. 1) go to 20 - kpvt(1) = 1 - if (a(1,1) .eq. 0.0d0) info = 1 -c ......exit - go to 200 - 20 continue -c -c this section of code determines the kind of -c elimination to be performed. when it is completed, -c kstep will be set to the size of the pivot block, and -c swap will be set to .true. if an interchange is -c required. -c - km1 = k - 1 - absakk = dabs(a(k,k)) -c -c determine the largest off-diagonal element in -c column k. -c - - imax = idamax(k-1,a(1,k),1) - colmax = dabs(a(imax,k)) - if (absakk .lt. alpha*colmax) go to 30 - kstep = 1 - swap = .false. - go to 90 - 30 continue -c -c determine the largest off-diagonal element in -c row imax. -c - rowmax = 0.0d0 - - imaxp1 = imax + 1 - do 40 j = imaxp1, k - rowmax = dmax1(rowmax,dabs(a(imax,j))) - 40 continue - if (imax .eq. 1) go to 50 - jmax = idamax(imax-1,a(1,imax),1) - rowmax = dmax1(rowmax,dabs(a(jmax,imax))) - 50 continue - if (dabs(a(imax,imax)) .lt. alpha*rowmax) go to 60 - kstep = 1 - swap = .true. - go to 80 - 60 continue - if (absakk .lt. alpha*colmax*(colmax/rowmax)) go to 70 - kstep = 1 - swap = .false. - go to 80 - 70 continue - kstep = 2 - swap = imax .ne. km1 - 80 continue - 90 continue - if (dmax1(absakk,colmax) .ne. 0.0d0) go to 100 -c -c column k is zero. set info and iterate the loop. -c - kpvt(k) = k - info = k - go to 190 - - 100 continue - - if (kstep .eq. 2) go to 140 -c -c 1 x 1 pivot block. -c - if (.not.swap) go to 120 -c -c perform an interchange. -c - call dswap(imax,a(1,imax),1,a(1,k),1) - do 110 jj = imax, k - j = k + imax - jj - t = a(j,k) - - - a(j,k) = a(imax,j) - a(imax,j) = t - 110 continue - 120 continue -c -c perform the elimination. -c - do 130 jj = 1, km1 - j = k - jj - mulk = -a(j,k)/a(k,k) - t = mulk - call daxpy(j,t,a(1,k),1,a(1,j),1) - a(j,k) = mulk - 130 continue -c -c set the pivot array. -c - kpvt(k) = k - - if (swap) kpvt(k) = imax - go to 190 - 140 continue -c -c 2 x 2 pivot block. -c - if (.not.swap) go to 160 -c -c perform an interchange. -c - call dswap(imax,a(1,imax),1,a(1,k-1),1) - do 150 jj = imax, km1 - j = km1 + imax - jj - t = a(j,k-1) - a(j,k-1) = a(imax,j) - a(imax,j) = t - 150 continue - t = a(k-1,k) - a(k-1,k) = a(imax,k) - a(imax,k) = t - - 160 continue -c -c perform the elimination. -c - km2 = k - 2 - if (km2 .eq. 0) go to 180 - ak = a(k,k)/a(k-1,k) - akm1 = a(k-1,k-1)/a(k-1,k) - - denom = 1.0d0 - ak*akm1 - do 170 jj = 1, km2 - j = km1 - jj - bk = a(j,k)/a(k-1,k) - bkm1 = a(j,k-1)/a(k-1,k) - mulk = (akm1*bk - bkm1)/denom - - mulkm1 = (ak*bkm1 - bk)/denom - t = mulk - call daxpy(j,t,a(1,k),1,a(1,j),1) - t = mulkm1 - call daxpy(j,t,a(1,k-1),1,a(1,j),1) - a(j,k) = mulk - a(j,k-1) = mulkm1 - - - - 170 continue - - 180 continue -c -c set the pivot array. -c - kpvt(k) = 1 - k - if (swap) kpvt(k) = -imax - kpvt(k-1) = kpvt(k) - - 190 continue - k = k - kstep - go to 10 - 200 continue - return - end - subroutine dsisl(a,lda,n,kpvt,b) - integer lda,n,kpvt(1) - double precision a(lda,1),b(1) -c -c dsisl solves the double precision symmetric system -c a * x = b - -c using the factors computed by dsifa. -c -c on entry -c -c a double precision(lda,n) -c the output from dsifa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c kpvt integer(n) -c the pivot vector from dsifa. -c -c b double precision(n) -c the right hand side vector. -c -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero may occur if dsico has set rcond .eq. 0.0 - -c or dsifa has set info .ne. 0 . -c -c to compute inverse(a) * c where c is a matrix -c with p columns -c call dsifa(a,lda,n,kpvt,info) -c if (info .ne. 0) go to ... -c do 10 j = 1, p -c call dsisl(a,lda,n,kpvt,c(1,j)) -c 10 continue -c -c linpack. this version dated 08/14/78 . -c james bunch, univ. calif. san diego, argonne nat. lab. -c -c subroutines and functions -c -c blas daxpy,ddot -c fortran iabs -c -c internal variables. -c - double precision ak,akm1,bk,bkm1,ddot,denom,temp - integer k,kp - -c -c loop backward applying the transformations and -c d inverse to b. -c - k = n - 10 if (k .eq. 0) go to 80 - if (kpvt(k) .lt. 0) go to 40 -c -c 1 x 1 pivot block. -c - if (k .eq. 1) go to 30 - kp = kpvt(k) - if (kp .eq. k) go to 20 -c -c interchange. -c - - temp = b(k) - b(k) = b(kp) - - b(kp) = temp - - 20 continue -c -c apply the transformation. -c - call daxpy(k-1,b(k),a(1,k),1,b(1),1) - 30 continue -c - -c apply d inverse. -c - b(k) = b(k)/a(k,k) - k = k - 1 - go to 70 - 40 continue - -c -c 2 x 2 pivot block. -c - if (k .eq. 2) go to 60 - kp = iabs(kpvt(k)) - if (kp .eq. k - 1) go to 50 -c -c interchange. -c - temp = b(k-1) - b(k-1) = b(kp) - b(kp) = temp - 50 continue -c -c apply the transformation. -c - call daxpy(k-2,b(k),a(1,k),1,b(1),1) - call daxpy(k-2,b(k-1),a(1,k-1),1,b(1),1) - 60 continue -c -c apply d inverse. -c - ak = a(k,k)/a(k-1,k) - akm1 = a(k-1,k-1)/a(k-1,k) - bk = b(k)/a(k-1,k) - bkm1 = b(k-1)/a(k-1,k) - denom = ak*akm1 - 1.0d0 - b(k) = (akm1*bk - bkm1)/denom - b(k-1) = (ak*bkm1 - bk)/denom - k = k - 2 - 70 continue - go to 10 - 80 continue -c -c loop forward applying the transformations. -c - k = 1 - 90 if (k .gt. n) go to 160 - if (kpvt(k) .lt. 0) go to 120 -c -c 1 x 1 pivot block. -c - if (k .eq. 1) go to 110 -c -c apply the transformation. -c - b(k) = b(k) + ddot(k-1,a(1,k),1,b(1),1) - kp = kpvt(k) - if (kp .eq. k) go to 100 - -c -c interchange. -c - temp = b(k) - b(k) = b(kp) - b(kp) = temp - - - 100 continue - 110 continue - k = k + 1 - go to 150 - 120 continue -c -c 2 x 2 pivot block. -c - if (k .eq. 1) go to 140 -c -c apply the transformation. -c - b(k) = b(k) + ddot(k-1,a(1,k),1,b(1),1) - b(k+1) = b(k+1) + ddot(k-1,a(1,k+1),1,b(1),1) - kp = iabs(kpvt(k)) - if (kp .eq. k) go to 130 -c -c interchange. - - -c - temp = b(k) - b(k) = b(kp) - b(kp) = temp - 130 continue - 140 continue - k = k + 2 - 150 continue - - go to 90 - 160 continue - return - end - subroutine dqrdc(x,ldx,n,p,qraux,jpvt,work,job) - integer ldx,n,p,job - integer jpvt(1) - double precision x(ldx,1),qraux(1),work(1) -c -c dqrdc uses householder transformations to compute the qr -c factorization of an n by p matrix x. column pivoting -c based on the 2-norms of the reduced columns may be -c performed at the users option. -c -c on entry -c -c x double precision(ldx,p), where ldx .ge. n. -c x contains the matrix whose decomposition is to be - -c computed. -c -c ldx integer. -c ldx is the leading dimension of the array x. -c -c n integer. -c n is the number of rows of the matrix x. -c -c p integer. -c p is the number of columns of the matrix x. - -c -c jpvt integer(p). -c jpvt contains integers that control the selection -c of the pivot columns. the k-th column x(k) of x -c is placed in one of three classes according to the -c value of jpvt(k). -c -c if jpvt(k) .gt. 0, then x(k) is an initial -c column. - -c -c if jpvt(k) .eq. 0, then x(k) is a free column. - -c -c if jpvt(k) .lt. 0, then x(k) is a final column. -c -c before the decomposition is computed, initial columns -c are moved to the beginning of the array x and final -c columns to the end. both initial and final columns -c are frozen in place during the computation and only -c free columns are moved. at the k-th stage of the -c reduction, if x(k) is occupied by a free column -c it is interchanged with the free column of largest -c reduced norm. jpvt is not referenced if -c job .eq. 0. -c -c work double precision(p). -c work is a work array. work is not referenced if -c job .eq. 0. -c -c job integer. -c job is an integer that initiates column pivoting. -c if job .eq. 0, no pivoting is done. -c if job .ne. 0, pivoting is done. -c -c on return -c -c x x contains in its upper triangle the upper - -c triangular matrix r of the qr factorization. -c below its diagonal x contains information from -c which the orthogonal part of the decomposition -c can be recovered. note that if pivoting has - -c been requested, the decomposition is not that -c of the original matrix x but that of x -c with its columns permuted as described by jpvt. -c -c qraux double precision(p). -c qraux contains further information required to recover -c the orthogonal part of the decomposition. -c -c jpvt jpvt(k) contains the index of the column of the -c original matrix that has been interchanged into -c the k-th column, if pivoting was requested. -c -c linpack. this version dated 08/14/78 . -c g.w. stewart, university of maryland, argonne national lab. -c - -c dqrdc uses the following functions and subprograms. -c -c blas daxpy,ddot,dscal,dswap,dnrm2 -c fortran dabs,dmax1,min0,dsqrt -c -c internal variables -c - integer j,jp,l,lp1,lup,maxj,pl,pu - double precision maxnrm,dnrm2,tt - double precision ddot,nrmxl,t - logical negj,swapj -c -c - pl = 1 - pu = 0 - if (job .eq. 0) go to 60 -c -c pivoting has been requested. rearrange the columns -c according to jpvt. -c - do 20 j = 1, p - swapj = jpvt(j) .gt. 0 - negj = jpvt(j) .lt. 0 - jpvt(j) = j - if (negj) jpvt(j) = -j - if (.not.swapj) go to 10 - if (j .ne. pl) call dswap(n,x(1,pl),1,x(1,j),1) - jpvt(j) = jpvt(pl) - jpvt(pl) = j - pl = pl + 1 - 10 continue - - 20 continue - pu = p - do 50 jj = 1, p - j = p - jj + 1 - if (jpvt(j) .ge. 0) go to 40 - - jpvt(j) = -jpvt(j) - if (j .eq. pu) go to 30 - call dswap(n,x(1,pu),1,x(1,j),1) - jp = jpvt(pu) - jpvt(pu) = jpvt(j) - jpvt(j) = jp - 30 continue - pu = pu - 1 - 40 continue - 50 continue - 60 continue - -c -c compute the norms of the free columns. -c - if (pu .lt. pl) go to 80 - do 70 j = pl, pu - qraux(j) = dnrm2(n,x(1,j),1) - work(j) = qraux(j) - 70 continue - 80 continue -c -c perform the householder reduction of x. -c - lup = min0(n,p) - do 200 l = 1, lup - if (l .lt. pl .or. l .ge. pu) go to 120 - -c -c locate the column of largest norm and bring it -c into the pivot position. -c - maxnrm = 0.0d0 - - maxj = l - do 100 j = l, pu - if (qraux(j) .le. maxnrm) go to 90 - maxnrm = qraux(j) - maxj = j - 90 continue - - 100 continue - if (maxj .eq. l) go to 110 - call dswap(n,x(1,l),1,x(1,maxj),1) - qraux(maxj) = qraux(l) - work(maxj) = work(l) - jp = jpvt(maxj) - jpvt(maxj) = jpvt(l) - jpvt(l) = jp - 110 continue - 120 continue - qraux(l) = 0.0d0 - if (l .eq. n) go to 190 -c -c compute the householder transformation for column l. -c - nrmxl = dnrm2(n-l+1,x(l,l),1) - if (nrmxl .eq. 0.0d0) go to 180 - if (x(l,l) .ne. 0.0d0) nrmxl = dsign(nrmxl,x(l,l)) - call dscal(n-l+1,1.0d0/nrmxl,x(l,l),1) - x(l,l) = 1.0d0 + x(l,l) -c -c apply the transformation to the remaining columns, -c updating the norms. -c - lp1 = l + 1 - - if (p .lt. lp1) go to 170 - do 160 j = lp1, p - t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l) - call daxpy(n-l+1,t,x(l,l),1,x(l,j),1) - if (j .lt. pl .or. j .gt. pu) go to 150 - if (qraux(j) .eq. 0.0d0) go to 150 - tt = 1.0d0 - (dabs(x(l,j))/qraux(j))**2 - tt = dmax1(tt,0.0d0) - t = tt - tt = 1.0d0 + 0.05d0*tt*(qraux(j)/work(j))**2 - if (tt .eq. 1.0d0) go to 130 - qraux(j) = qraux(j)*dsqrt(t) - - go to 140 - 130 continue - qraux(j) = dnrm2(n-l,x(l+1,j),1) - work(j) = qraux(j) - 140 continue - 150 continue - 160 continue - 170 continue -c -c save the transformation. - -c - qraux(l) = x(l,l) - x(l,l) = -nrmxl - 180 continue - - 190 continue - 200 continue - return - end -C LAPACK routines follow -C note that thte call to the LAPACK auxialliary routine -C that defines NB has been rpelaced by a hardwired -C NB=16 in dpotrf.f -C This is probably OK for PCs, but workstations may be a bit faster with -C NB = 32 - SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 - -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) - -* .. -* -* Purpose -* ======= -* -* DPOTRF computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U**T * U, if UPLO = 'U', or -* A = L * L**T, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. - -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* - -* N (input) INTEGER - -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value - -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible - -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - nb = 16 - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL DPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE - -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of DPOTRF -* - END - SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* - -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - - CHARACTER UPLO - - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRS solves a system of linear equations A*X = B with a symmetric -* positive definite matrix A using the Cholesky factorization -* A = U**T*U or A = L*L**T computed by DPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* - -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The triangular factor U or L from the Cholesky factorization -* A = U**T*U or A = L*L**T, as computed by DPOTRF. -* -* LDA (input) INTEGER - -* The leading dimension of the array A. LDA >= max(1,N). - -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* - -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. - -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRS', -INFO ) - RETURN - END IF - -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Solve A*X = B where A = U'*U. -* - -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A*X = B where A = L*L'. -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) - END IF -* - RETURN -* -* End of DPOTRS -* - END - SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. - -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= - -* -* DPOTF2 computes the Cholesky factorization of a real symmetric -* positive definite matrix A. - -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments - -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular - -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - - -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER - -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== - -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT - -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of DPOTF2 -* - END - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. - -* -* Test if the characters are equal - -* - LSAME = CA.EQ.CB - - IF( LSAME ) - $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - - ZCODE = ICHAR( 'Z' ) - -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR( CA ) - INTB = ICHAR( CB ) -* - IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 - IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* - ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. - -* - IF( INTA.GE.129 .AND. INTA.LE.137 .OR. - $ INTA.GE.145 .AND. INTA.LE.153 .OR. - $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 - IF( INTB.GE.129 .AND. INTB.LE.137 .OR. - $ INTB.GE.145 .AND. INTB.LE.153 .OR. - $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 - -* - ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 - IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 - END IF - LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* - END - - SUBROUTINE XERBLA( SRNAME, INFO ) - -* -* -- LAPACK auxiliary routine (preliminary version) -- - - -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - - - INTEGER INFO - CHARACTER*6 SRNAME,ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - -* .. - -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. - -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* - WRITE( *, FMT = 9999 )SRNAME, INFO - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - WRITE( 47, FMT = 9999 )SRNAME, INFO - CLOSE(47) - - CALL PAUSE - STOP -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE GETIPATF - -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE GETNUMSF - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE WRITEPT2 - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE GETSUB - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE CALCTPRED - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE CONDENSE - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE PAUSE (IT'S IN ANOTHER MODULE) - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE NEWWORK1 - - IMPLICIT REAL*8(A-H,O-Z) - PARAMETER(MAXNUMEQ=7) - DIMENSION SIG(5000),RS(5000,34),DELTAIV(7),ORDELT(7), - 1 RSS(5000,34),SIGG(5000),TIM(594),TIMM(594),YO(594,MAXNUMEQ), - 2 TIMDELAY(99) - - CHARACTER READLINE*300,ERRFIL*20 - - COMMON/ERR/ERRFIL - -C SUBROUTINE NEWWORK1 (BASED ON THE STAND-A-LONE VERSION OF THE SAME -C NAME) READS IN A WORKING COPY PATIENT DATA FILE, AND OUTPUTS ANOTHER -C FILE WHICH IS: - -C a. EXACTLY THE SAME IF THE ORIGINAL FILE HAS NO STEADY STATE DOSE -C INDICATORS; - -C OR - -C b. ALTERED TO HAVE THE SAME INFO AS IN THE ORIGINAL FILE, BUT ALSO -C CONTAINING AN EXTRA 100 DOSES FOR EACH STEADY STATE DOSE -C INDICATOR. - -C NOTES: - -C 1. A STEADY STATE DOSE INDICATOR IS A NEGATIVE VALUE IN THE TIME -C ENTRY FOR A DOSE. THIS IS ACCOMPANIED BY INFORMATION ON THE SET OF -C DOSES IN THE IV AND BOLUS ENTRIES, AS THE FOLLOWING EXAMPLE SHOWS: - -C Time IV Bolus -C -2.0 100.0 150.0 ... - -C THE ABOVE LINE WOULD TELL THE PROGRAM: - -C a. THAT THIS WAS INFO ON 100 STEADY STATE DOSES BECAUSE OF THE -C NEGATIVE TIME VALUE; -C b. THE TIME BETWEEN CONSECUTIVE IV START TIMES = 2 HOURS, BECAUSE -C THIS IS THE ABS. VALUE OF THE TIME; -C C. THE IV RATE = 100MG/HOUR; -C D. THE TOTAL DRUG AMT. FOR EACH IV DOSE IS 150MG. - -C SO THE PROGRAM WOULD THEN ADD 100 DOSES TO THE PATIENT DATA FILE, -C STARTING AT T = 0, EACH WITH AN IV RATE = 100, AND CONTINUING FOR -C 1.5 HOURS. - -C 2. IT WILL BE ASSUMED THAT EACH STEADY STATE DOSE INDICATOR ALWAYS -C WILL BE REPLACED BY 100 IV DOSES (NOT BOLUS DOSES). -C AS OF npageng17.f, STEADY STATE DOSES MAY BE BOLUS DOSES. IN THIS -C CASE, THE IV RATE WILL BE 0.0 OF COURSE. - -C 3. ALL OTHER TIMES IN THE PATIENT DATA FILE (UP TO THE NEXT TIME -C RESET IF THERE IS ONE) WILL BE ASSUMED TO BE TIMES FROM THE END OF -C THE 100TH DOSE INTERVAL. IN THE ABOVE EXAMPLE, THE 100TH DOSE -C INTERVAL WOULD END AT T = 200 (THE LAST IV ITSELF WOULD END AT -C T = 199.5, BUT THE 100TH DOSE INTERVAL WOULD END AT T = 200). SO ALL -C OTHER TIMES IN THE DOSAGE AND OBSERVATION BLOCKS WOULD HAVE 200 ADDED -C TO THEIR VALUES. - -C 4. THE ABOVE EXAMPLE IS FOR ONE DRUG ONLY, BUT ANY OR ALL OF THE -C NDRUGS IN A PATIENT'S FILE CAN HAVE STEADY STATE DOSES. ANY DRUG -C WHICH HAS A NON-0 VALUE IN THE BOLUS COLUMN OF A STEADY STATE DOSE -C LINE (I.E., ONE WITH TIME < 0) WILL PARTICIPATE IN A STEADY STATE -C DOSE SET, GETTING THAT AMOUNT OF DRUG IN EACH OF THE 100 DOSES. IF -C THE IV COLUMN IS > 0, THEN THE DRUG WILL BE GIVEN AT THE RATE -C SHOWN IN THE IV COLUMN. IF THE IV COLUMN IS 0, THEN THE DRUG WILL -C BE GIVEN AS A BOLUS. - -C 5. THE 100 STEADY STATE DOSES CAN BE GIVEN AS THE FIRST SET OF DOSES -C IN A PATIENT'S FILE, AS INDICATED ABOVE, OR AT ANY TIME RESET. IF -C THEY ARE AT A TIME RESET, ALL THE SUBSEQUENT TIMES AFTER THAT TIME -C RESET (UP TO THE NEXT TIME RESET IF THERE IS ONE) ARE ADJUSTED AS -C INDICATED ABOVE TO BE TIMES AFTER THE END OF THAT SET OF 100 DOSES. - -C----------------------------------------------------------------------- - - -C FILE 27 WAS OPENED IN MAIN AND THE POINTER IS AT THE TOP OF A PATIENT -C WHOSE INFO IS TO BE PUT ONTO FILE 37. BUT IT WILL NOT BE PUT ON TO -C FILE 37 UNTIL THE DOSE BLOCK OF FILE 27 HAS BEEN READ ... AND -C EXAMINED TO SEE IF IT HAS A STEADY STATE DOSE INDICATOR. IF IT DOES, -C IT MEANS THAT THIS PART OF FILE 37 WILL HAVE AN EXTRA SET OF 100 -C DOSES FOR EACH DRUG. - -C NOTE ALSO THAT, AS OF npagen18.f, TIMOBREL(JSUB,J), J=1,M, WILL BE -C STORED AND RETURNED TO MAIN. NO! IN NPAGFULLA, TIMOBREL IS NOT -C NEEDED. - - - 1717 FORMAT(A300) - - 10 READ(27,1717) READLINE - IF(READLINE(12:23) .NE. 'NO. OF DRUGS') GO TO 10 - -C READLINE NOW CONTAINS THE NO. OF DRUGS, NDRUG. BACKSPACE AND READ -C NDRUG; THEN READ THE NO. OF ADDITIONAL COVARIATES, AND THE NO. OF - -C DOSE EVENTS. - - 3 FORMAT(T2,I5) - - BACKSPACE(27) - READ(27,3) NDRUG - READ(27,3) NADD - READ(27,3) ND - NI = 2*NDRUG + NADD - -C IF THERE ARE NO DOSE EVENTS (ND = 0), THE INFO ON FILE 37 WILL BE THE -C SAME AS ON FILE 27 (SINCE THERE CAN BE NO STEADY STATE DOSE EVENTS IF -C THERE ARE NO DOSES). IN THIS CASE, SET ICOPY = 1 (SEE BELOW). - - IF(ND .EQ. 0) ICOPY = 1 - -C IF ANY SIG(.) IS NEGATIVE, SET ICOPY = 0 SINCE A SIG(.) < 0 IS THE -C INDICATOR FOR A STEADY STATE SET OF DOSES. - - - IF(ND .GE. 1) THEN - - READ(27,*) - READ(27,*) - - ICOPY = 1 - - - DO I = 1,ND - - READ(27,*) SIG(I),(RS(I,J),J=1,NI) - - IF(SIG(I) .LT. 0.D0) ICOPY = 0 - - END DO - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ND .GE. 1) CONDITION. - - - - 140 READ(27,1717) READLINE - - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 140 - - BACKSPACE(27) - - READ(27,*) NUMEQT - READ(27,3) M - - -C IF ICOPY = 1, IT MEANS THAT THIS PATIENT DATA FILE DOES NOT HAVE -C A STEADY STATE DOSE SET, WHICH MEANS THAT THIS PART OF FILE 27 WILL -C BE COPIED LINE FOR LINE TO FILE 37 BELOW. - - IF(ICOPY .EQ. 1) THEN - - -C COPY FILE 27 TO FILE 37,LINE FOR LINE. - -C BACKSPACE FILE 27 TO THE FIRST LINE FOR THIS PATIENT. - - - 1720 BACKSPACE(27) - BACKSPACE(27) - READ(27,1717,IOSTAT=IEND) READLINE - - IF(IEND .LT. 0) THEN - -C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED, BUT IF IT'S REACHED -C AT THIS POINT, NOT ALL "ACTIVE" NSUB SUBJECT DATA SETS WERE READ -C AND WRITTEN CORRECTLY TO FILE 37. IN THIS CASE, WRITE A MESSAGE TO -C THE USER AND STOP. - - WRITE(*,1721) - 1721 FORMAT(/' PATIENT DATA INFORMATION WAS NOT READ CORRECTLY'/ - 1' FROM THE INSTRUCTION FILE, npag102.inp. IF YOU EDITED THIS'/ - 2' FILE MANUALLY, PLEASE RERUN THE PC PREP PROGRAM TO HAVE IT'/ - 3' PREPARE npag102.inp AGAIN AND THEN RERUN THIS PROGRAM.'// - 4' IF YOU DID NOT MANUALLY EDIT npag102.inp, PLEASE SEND THE'/ - 5' DETAILS OF THIS RUN (STARTING WITH THE PC PREP EXECUTION) TO'/ - 5' THE LAPK. '// - 6' THANK YOU.'/) - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - WRITE(47,1721) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - IF(READLINE(3:16) .NE. 'LAST AND FIRST') GO TO 1720 - - - WRITE(37,1717) READLINE - - 30 READ(27,1717) READLINE - WRITE(37,1717) READLINE - - IF(READLINE(12:23) .NE. 'NO. OF DOSE ') GO TO 30 - -C THE LINE JUST WRITTEN TO FILE 37 IS THE NO. OF DOSE EVENTS LINE. -C WRITE THE NEXT TWO LINES ALSO. - - DO I = 1,2 - READ(27,1717) READLINE - WRITE(37,1717) READLINE - END DO - - -C IF ND = 0, SKIP TO THE OUTPUT SECTION. OTHERWISE, WRITE THE DOSAGE -C REGIMEN TO FILE 37. - - IF(ND.EQ.0) GO TO 40 - - DO I = 1,ND - READ(27,*) SIG(I),(RS(I,J),J=1,NI) - WRITE(37,*) SIG(I),(RS(I,J),J=1,NI) - END DO - -C READ THE NO. OF OUTPUT EQUATIONS FROM THE LINE WITH 'NO. OF TOTAL' -C AS ENTRIES 12:23. THEN READ NO. OF OBSERVED VALUE TIMES, ETC., AND -C WRITE THE REST OF THE FILE 27 TO FILE 37. - - 40 READ(27,1717) READLINE - WRITE(37,1717) READLINE - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 40 - - BACKSPACE(27) - -C SINCE NUMEQT IS PROVIDED TO THIS ROUTINE IN THE ARGUMENT LIST, -C JUST READ(27,*) ON NEXT LINE. - - READ(27,*) - READ(27,3) M - -C BACKSPACE JUST ONCE TO THE LINE WITH M ON IT, SINCE THE LINE WITH - -C NUMEQT ON IT WAS ALREADY PUT INTO FILE 37. - - BACKSPACE(27) - READ(27,1717) READLINE - WRITE(37,1717) READLINE - - DO I = 1,M - READ(27,*) TIM(I),(YO(I,J),J=1,NUMEQT) - WRITE(37,*) TIM(I),(YO(I,J),J=1,NUMEQT) -C TIMOBREL(JSUB,I) = TIM(I) - END DO - -C NOW COPY LINE FOR LINE THE REST OF THIS PATIENT'S INFO TO FILE 37. -C THIS PATIENT'S INFO WILL END WHEN THE END OF THE FILE IS REACHED -C (IF THIS IS THE LAST PATIENT), OR WHEN THE START OF THE NEXT - -C PATIENT OCCURS. - - - 50 READ(27,1717,IOSTAT=IEND) READLINE - IF(IEND .LT. 0) GO TO 100 - IF(READLINE(3:16) .EQ. 'LAST AND FIRST') GO TO 100 - - WRITE(37,1717) READLINE - GO TO 50 - - - 100 BACKSPACE(27) - -C FILE 27 WAS BACKSPACED ONE LINE SO THE NEXT LINE TO BE READ IN IN -C MAIN WILL BE THE FIRST LINE OF THE NEXT SUBJECT (UNLESS THIS SUBJECT -C IS THE LAST SUBJECT, IN WHICH CASE THE BACKSPACE WON'T MATTER). - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICOPY .EQ. 1) CONDITION. - - - IF(ICOPY .EQ. 0) THEN - - -C SINCE ICOPY = 0, IT MEANS THAT THERE IS AT LEAST ONE SET OF STEADY -C STATE DOSES IN THE DOSAGE BLOCK. THE LOGIC FOR TRANSLATING THESE -C STEADY STATE DOSES TO A REGULAR DOSAGE BLOCK (EXCEPT FOR THE NEGATIVE -C DOSE TIME AT THE START OF EACH STEADY STATE DOSE SET) IS AS FOLLOWS: - -C EACH DOSAGE LINE WILL BE COPIED UNALTERED UNLESS IT IS PART OF A -C STEADY STATE SET. - -C EACH STEADY STATE SET STARTS WITH A SIG(I) < 0. IN THIS CASE, 100 -C DOSES WILL BE APPLIED AT THIS POINT WITH THE STEADY STATE DOSE FOR -C DRUG IDRUG = RS(I,2*IDRUG), WHICH WILL BE APPLIED AS A BOLUS IF -C RS(I,2*IDRUG-1) = 0, AND AS AN IV WITH DURATION -C RS(I,2*IDRUG)/RS(I,2*IDRUG-1) IF RS(I,2*IDRUG-1) > 0. -C THE REST OF THE DOSE TIMES IN THIS BLOCK OF DOSES (I.E., UNTIL THE -C NEXT TIME RESET OR STEADY STATE DOSE INDICATOR) WILL BE INCREASED -C BY 100*DELDOSE, WHERE DELDOSE = -SIG(I) = INTERDOSE INTERVAL FOR -C THIS SET. - - -C ILINE WILL BE THE RUNNING INDEX OF THE NEXT DOSAGE LINE TO BE PUT - -C INTO THE ALTERED DOSAGE REGIMEN. SIGG(ILINE) AND RSS(ILINE,.) ARE -C THE VALUES THAT GO INTO THIS LINE. DELDOSE IS THE CURRENT INTERDOSE -C TIME INTERVAL FOR THE LAST STEADY STATE SET OF DOSES ALREADY PUT -C INTO THE ALTERED DOSAGE REGIMEN (IT IS INITIALIZED TO BE 0 OF -C COURSE). - -C AND NSECTION IS INITIALIZED TO BE 0. IT WILL BE THE RUNNING NO. OF -C DOSAGE SECTIONS. EACH SECTION BEGINS WITH EITHER A 0.0 (BEGINNING -C LINE OR TIME RESET) OR A NEGATIVE NO. (STEADY STATE DOSE SET -C INDICATOR). THE TIME DELAY ASSOCIATED WITH EACH DOSE SECTION (WHICH -C WILL BE 0 IF THAT SECTION IS NOT A STEADY STATE DOSE SET), MUST BE -C STORED TO BE APPLIED TO THE CORRESPONDING SET OF OBSERVED VALUES -C BELOW. - - - ILINE = 0 - DELDOSE = 0.D0 - NSECTION = 0 - - DO ID = 1,ND - - - IF(SIG(ID) .GE. 0.D0) THEN - - CALL THESAME(SIG(ID),0.D0,ISAME) - - IF(ISAME .EQ. 1) THEN - DELDOSE = 0.D0 - NSECTION = NSECTION + 1 - - TIMDELAY(NSECTION) = 0.0 - ENDIF - -C NOTE THAT IF SIG(ID) = 0, THIS LINE IS A TIME RESET LINE, OR THE -C FIRST LINE IN THE DOSAGE REGIMEN. IF IT'S THE FIRST LINE IN THE -C DOSAGE REGIMEN, THERE ARE OBVIOUSLY NO PREVIOUS STEADY STATE DOSE -C SETS. IF ITS A TIME RESET LINE, A PREVIOUS SET OF 100 STEADY STATE -C DOSES HAS NO EFFECT ON IT. THAT'S WHY DELDOSE IS SET = 0, WHICH -C MEANS, BELOW, THAT SIGG(ILINE) WILL = SIG(ID) = 0. ALSO, THE TIME -C DELAY STORED IN TIMDELAY ABOVE IS 0 SINCE SIG(ID) .GE. 0 --> THIS -C IS NOT A STEADY STATE DOSE SET. - - ILINE = ILINE + 1 - SIGG(ILINE) = SIG(ID) + 100.D0*DELDOSE - - DO J = 1,NI - RSS(ILINE,J) = RS(ID,J) - END DO - - ENDIF - - - IF(SIG(ID) .LT. 0.D0) THEN - -C THIS LINE GIVES INFO ON A STEADY STATE SET OF 100 DOSES WHICH IS -C TO APPLIED AT THIS POINT. - - DO IDRUG = 1,NDRUG - -C FOR DRUG, IDRUG, THE AMOUNT OF DRUG FOR DRUG NO. IDRUG IN EACH OF THE -C 100 DOSES WILL BE RS(ID,2*IDRUG). IF RS(ID,2*IDRUG) > 0, DRUG, IDRUG, -C PARTICIPATES IN THE STEADY STATE DOSING. IF THIS VALUE = 0, DRUG, -C IDRUG, DOES NOT PARTICIPATE. NOTE THAT IF A DRUG PARTICIPATES, THE -C ROUTE WILL BE AS AN IV, WITH RATE RS(ID,2*IDRUG-1), IF - -C RS(ID,2*IDRUG-1) > 0. BUT IF THIS VALUE IS 0, THE DRUG WILL BE GIVEN -C AS A BOLUS. NOTE THAT THE INTERVAL BETWEEN DOSES IS -SIG(ID). - - -C IF DRUG, IDRUG, PARTICIPATES IN THE 100 STEADY STATE DOSE SET, PUT -C THE DURATION OF IV INTO DELTAIV(IDRUG) IF RS(ID,2*IDRUG-1) > 0; -C OTHERWISE PUT 0 INTO DELTAIV(IDRUG) SINCE IN THIS CASE, THE DRUG IS -C GIVEN AS A BOLUS. - - DELTAIV(IDRUG) = 0.D0 - IF(RS(ID,2*IDRUG) .GT. 0.D0 .AND. RS(ID,2*IDRUG-1) .GT. 0.D0) - 1 DELTAIV(IDRUG) = RS(ID,2*IDRUG)/RS(ID,2*IDRUG-1) - -C IT SHOULD NOT BE POSSIBLE FOR THE IV OF THIS DRUG TO BE > 0 AT THE -C SAME TIME THAT THE BOLUS ENTRY = 0. THIS WOULD MEAN THAT AN IV -C WAS TO BE GIVEN AT A SPECIFIED RATE, BUT WITH A TOTAL DOSE OF 0, -C AND THIS MAKES NO SENSE. IF, SOMEHOW, THIS HAS OCCURRED, REPORT IT -C TO THE USER AS AN ERROR, AND STOP. - - IF(RS(ID,2*IDRUG) .LE. 0.D0 .AND. RS(ID,2*IDRUG-1) .GT. 0) THEN - - WRITE(*,101) ID,SIG(ID),IDRUG,RS(ID,2*IDRUG-1),RS(ID,2*IDRUG) - 101 FORMAT(//' THERE IS AN ERROR IN YOUR INSTRUCTION FILE, AS'/ - 1' DETERMINED BY SUBROUTINE NEWWORK1.'// - 2' ONE OF THE SUBJECTS HAS A STEADY STATE DOSE SET WITH A '/ - 3' POSITIVE IV RATE, BUT WITH A TOTAL DOSE AMOUNT .LE. 0.'// - 4' IN PARTICULAR, FOR DOSE EVENT ',I4,' AND TIME ',G19.9,/ - 5' FOR DRUG ',I2,', THE IV VALUE IS ',G19.9,' WHILE THE TOTAL'/ - 6' DOSE AMOUNT IS ',G19.9// - 7' THE PROGRAM STOPS. PLEASE CORRECT THE ERROR BEFORE RERUNNING.'/) - - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - WRITE(47,101) ID,SIG(ID),IDRUG,RS(ID,2*IDRUG-1),RS(ID,2*IDRUG) - CLOSE(47) - - CALL PAUSE - STOP - ENDIF - - - END DO - - -C CALL SUBROUTINE ORDERDELTA TO OBTAIN NDELTA, THE NO. OF UNIQUE -C NON-0 VALUES IN THE DELTAIV(.) ARRAY JUST ESTABLISHED ABOVE, AND TO -C PUT THE ORDERED SET OF THESE NDELTA VALUES INTO ORDELT(.). - -C NOTE THAT IF DELTAIV(IDRUG) = 0, IT MEANS THAT DRUG, IDRUG, DOES NOT -C PARTICIPATE IN THE STEADY STATE DOSE SET, OR IF IT DOES, IT IS GIVEN -C AS A BOLUS RATHER THAN AN IV. - - CALL ORDERDELTA(NDRUG,DELTAIV,NDELTA,ORDELT) - -C NOW ESTABLISH THE LINES WITH SIGG(.) AND RSS(.,.) AS FOLLOWS: - -C 1. THE NEXT 100*(NDELTA + 1) ROWS WILL BE FOR THE STEADY STATE -C DOSE SET (I.E., EACH OF THE 100 REPEATED DOSES HAS A START TIME, -C AND THEN NDELTA ENDING TIMES AMONG ALL NDRUG DRUGS). NOTE THAT -C NDELTA WILL BE 0 IF ALL THE PARTICIPATING DRUGS ARE BOLUSES SINCE -C THEY WOULDN'T NEED AN ENDING TIME THEN. - -C 2. EVERY ROW OF THE ORIGINAL DOSAGE REGIMEN AFTER LINE ID -C WILL HAVE THE SAME VALUES IN RSS(.,.) AS IN RS(.,.), BUT THE -C TIMES IN SIGG(.) WILL ALL BE INCREASED BY 100*DELDOSE OVER THOSE -C IN SIG(.) ... UP TO BUT NOT INCLUDING THE NEXT TIME RESET EVENT -C OR NEXT STEADY STATE DOSE INDICATOR LINE, WHERE DELDOSE IS THE TIME -C INCREMENT BETWEEN CONSECUTIVE DOSES IN THE 100 STEADY STATE DOSE SET. -C NOTE THAT DELDOSE IS THE NEGATIVE OF SIG(ID). - - DELDOSE = -SIG(ID) - NSECTION = NSECTION + 1 - TIMDELAY(NSECTION) = 100.D0*DELDOSE - -C NOTE THAT THE TIME DELAY ASSOCIATED WITH THIS STEADY STATE SET IS -C STORED INTO TIMDELAY ABOVE SO THAT IT CAN BE APPLIED TO THE -C CORRESPONDING SET OF OBSERVED VALUES BELOW. - - - DO ISET = 1,100 - - -C FOR EACH SET, ESTABLISH NDELTA + 1 ROWS (DOSE EVENT LINES). - - -C THE FIRST ROW IN THIS SET HAS EACH DRUG IV SET = RS(ID,2*IDRUG-1), -C AND, FOR EACH DRUG IV WHICH IS 0, THE BOLUS VALUE WILL BE SET = -C RS(ID,2*IDRUG). NOTE THAT IF A DRUG IV > 0, THE BOLUS VALUE WILL BE -C SET = 0 SINCE IN THIS CASE, THE VALUE IN THE BOLUS COLUMN IS THE -C TOTAL AMOUNT OF IV (NOT A BOLUS AMOUNT). - - ILINE = ILINE + 1 - - DO IDRUG = 1,NDRUG - RSS(ILINE,2*IDRUG-1) = RS(ID,2*IDRUG-1) - RSS(ILINE,2*IDRUG) = RS(ID,2*IDRUG) - IF(RS(ID,2*IDRUG-1) .GT. 0.D0) RSS(ILINE,2*IDRUG) = 0.D0 - END DO - -C SET ALL THE COVARIATE VALUES = TO THOSE IN LINE ID OF RS OF COURSE. - - DO IADD = 1,NADD - RSS(ILINE,2*NDRUG+IADD) = RS(ID,2*NDRUG+IADD) - END DO - -C THE TIME FOR THIS ROW IS (ISET-1)*DELDOSE, EXCEPT FOR THE FIRST -C LINE, WHICH MUST HAVE THE SAME NEGATIVE VALUE AS IN SIG, SINCE -C THE ID ROUTINES MUST READ THE NEGATIVE SIG VALUE TO KNOW THAT A -C STEADY STATE DOSE SET IS STARTING. - - IF(ISET .EQ. 1) THEN - SIGG(ILINE) = SIG(ID) - DOSESTART = 0.D0 - ENDIF - - IF(ISET .GT. 1) THEN - SIGG(ILINE) = (ISET-1)*DELDOSE - DOSESTART = SIGG(ILINE) - - ENDIF - -C THE NEXT NDELTA ROWS ARE THE IV TURN OFF ROWS FOR THE VARIOUS DRUGS, -C IF NDELTA > 0. NOTE THAT NDELTA COULD = 0 IF ALL PARTICIPATING DRUGS -C ARE GIVEN VIA A BOLUS, SINCE THEN NONE WOULD NEED A TURN OFF ROW. - - IF(NDELTA .GT. 0) THEN - - DO INDEL = 1,NDELTA - - ILINE = ILINE + 1 - -C THE NEXT TURN OFF TIME IS DOSESTART + ORDELT(INDEL). EACH IV WILL BE -C OFF UNLESS ITS DELTAIV(.) IS .GT ORDELT(INDEL). AND EACH BOLUS VALUE -C WILL BE 0 OF COURSE (I.E., EACH BOLUS IS GIVEN JUST ONE TIME AT THE -C START OF EACH SET). - - DO IDRUG = 1,NDRUG - RSS(ILINE,2*IDRUG-1) = 0.D0 - IF(DELTAIV(IDRUG) .GT. ORDELT(INDEL)) - 1 RSS(ILINE,2*IDRUG-1) = RS(ID,2*IDRUG-1) - RSS(ILINE,2*IDRUG) = 0.D0 - END DO - -C SET ALL THE COVARIATE VALUES = TO THOSE IN LINE ID OF RS AGAIN. - - DO IADD = 1,NADD - RSS(ILINE,2*NDRUG+IADD) = RS(ID,2*NDRUG+IADD) - END DO - - -C THE TIME FOR THIS ROW IS DOSESTART + ORDELT(INDEL) - - SIGG(ILINE) = DOSESTART + ORDELT(INDEL) - - END DO - -C THE ABOVE END DO IS FOR THE DO INDEL = 1,NDELTA LOOP. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NDELTA .GT. 0) CONDITION. - - - - END DO - -C THE ABOVE END DO IS FOR DO ISET = 1,100 LOOP. - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(SIG(ID) .LT. 0.D0) CONDITION. - - - - END DO - -C THE ABOVE END DO IS FOR THE DO ID = 1,ND LOOP. - - -C THIS COMPLETES THE ESTABLISHMENT OF RSS(.,.) AND SIGG(.) ABOVE. - - -C NOW ALTER THE OBSERVED VALUE TIMES BY ADDING THE APPROPRIATE VALUE -C IN TIMDELAY(.) TO EACH OBSERVED VALUE TIME BELOW. NOTE THAT -C TIMDELAY(1) APPLIES TO ALL TIMES BEFORE THE FIRST TIME RESET, -C TIMDELAY(2) APPLIES TO THE NEXT SET OF TIMES AFTER THE FIRST -C TIME RESET BUT BEFORE THE 2ND, ETC. IF THERE ARE NO TIME RESETS, -C ALL TIMES WILL HAVE TIMDELAY(1) ADDED TO THEM, AND THIS VALUE WILL -C BE 0.0 (SEE DOSAGE BLOCK CODE ABOVE - IF THERE ARE NO TIME RESETS -C OR STEADY STATE DOSE SETS, TIMDELAY(1) IS SET = 0). - -C SINCE THE OBSERVATION BLOCK WAS READ THROUGH ABOVE, BACKSPACE TO -C THE BEGINNING OF THE OBS. BLOCK, SO THIS PART OF THE PATIENT'S -C DATA CAN BE ACCESSED AGAIN. - -1920 BACKSPACE(27) - BACKSPACE(27) - READ(27,1717,IOSTAT=IEND) READLINE - - IF(IEND .LT. 0) THEN - -C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED, BUT IF IT'S REACHED -C AT THIS POINT, NOT ALL "ACTIVE" NSUB SUBJECT DATA SETS WERE READ -C AND WRITTEN CORRECTLY TO FILE 37. IN THIS CASE, WRITE A MESSAGE TO -C THE USER AND STOP. - - WRITE(*,1721) - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - WRITE(47,1721) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - IF(READLINE(12:23) .NE. 'NO. OF TOTAL') GO TO 1920 - - BACKSPACE(27) - -C SINCE NUMEQT IS PROVIDED TO THIS ROUTINE IN THE ARGUMENT LIST, -C JUST READ(27,*) ON NEXT LINE. - - READ(27,*) - - READ(27,3) M - - NSECTION = 1 - - - - DO I = 1,M - READ(27,*) TIM(I),(YO(I,J),J=1,NUMEQT) -C TIMOBREL(JSUB,I) = TIM(I) - CALL THESAME(TIM(I),0.D0,ISAME) - IF(ISAME .EQ. 1 .AND. I .GT. 1) NSECTION = NSECTION + 1 - IF(ISAME .EQ. 1) TIMM(I) = 0.D0 - IF(ISAME .EQ. 0) TIMM(I) = TIM(I) + TIMDELAY(NSECTION) - END DO - - - -C NOW COPY THIS PART OF FILE 27 TO FILE 37 WITH THE FOLLOWING -C EXCEPTIONS: -C 1. ND WILL BE REPLACED BY ILINE (THE TOTAL NO. OF DOSAGE LINES IN -C THE ALTERED DOSAGE REGIMEN). -C 2. SIG(.) WILL BE REPLACED BY SIGG(.). -C 3. RS(.,.) WILL BE REPLACED BY RSS(.,.) -C 4. TIM(.) WILL BE REPLACED BY TIMM(.) -C NOTE THAT YO(.,.) WILL BE UNCHANGED. - -C BACKSPACE FILE 27 TO THE FIRST LINE FOR THIS PATIENT. - - 1820 BACKSPACE(27) - - BACKSPACE(27) - READ(27,1717,IOSTAT=IEND) READLINE - - IF(IEND .LT. 0) THEN - -C NOTE THAT IEND .LT. 0 --> END OF FILE REACHED, BUT IF IT'S REACHED -C AT THIS POINT, NOT ALL "ACTIVE" NSUB SUBJECT DATA SETS WERE READ -C AND WRITTEN CORRECTLY TO FILE 37. IN THIS CASE, WRITE A MESSAGE TO -C THE USER AND STOP. - - WRITE(*,1721) - - -C SINCE THE PROGRAM IS TERMINATING ABNORMALLY, WRITE THE ERROR MESSAGE -C TO ERRFIL ALSO. - - OPEN(47,FILE=ERRFIL) - WRITE(47,1721) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - IF(READLINE(3:16) .NE. 'LAST AND FIRST') GO TO 1820 - - WRITE(37,1717) READLINE - - 60 READ(27,1717) READLINE - WRITE(37,1717) READLINE - - IF(READLINE(12:23) .NE. 'NO. OF ADDIT') GO TO 60 - -C THE LINE JUST WRITTEN TO FILE 37 IS THE NO. OF ADDITIONAL COVARIATES -C LINE. WRITE THE NEXT LINE BUT CHANGE FROM ND TO ILINE AS THE NO. -C OF DOSE EVENTS. - - READ(27,1717) READLINE - WRITE(37,133) ILINE - 133 FORMAT(I6,' ... NO. OF DOSE EVENTS') - -C WRITE THE NEXT TWO LINES TO FILE 37 (INCLUDING THE HEADER LINE FOR -C THE DOSAGE BLOCK). - - DO I = 1,2 - READ(27,1717) READLINE - WRITE(37,1717) READLINE - END DO - -C WRITE THE NEW DOSAGE BLOCK. - - - DO I = 1,ILINE - WRITE(37,*) SIGG(I),(RSS(I,J),J=1,NI) - - END DO - - -C READ THROUGH FILE 27 DOWN TO THE END OF THE DOSAGE BLOCK - - - DO I = 1,ND - - READ(27,*) SIG(I),(RS(I,J),J=1,NI) - END DO - -C PUT THE BLANK LINE BETWEEN THE DOSAGE BLOCK AND THE OBSERVATION -C BLOCK TO FILE 37, ALONG WITH THE TWO LINES WHICH GIVE THE NO. OF -C OUTPUT EQS. AND THE NO. OF OBSERVED VALUE TIMES. - - DO I = 1,3 - READ(27,1717) READLINE - WRITE(37,1717) READLINE - END DO - -C WRITE THE OBSERVED BLOCK TO FILE 37, AND READ THROUGH IT IN FILE 27. - - DO I = 1,M - WRITE(37,*) TIMM(I),(YO(I,J),J=1,NUMEQT) - READ(27,*) TIM(I),(YO(I,J),J=1,NUMEQT) - END DO - -C NOW COPY LINE FOR LINE THE REST OF THIS SUBJECT'S INFO TO FILE 37. -C THIS PATIENT'S INFO WILL END WHEN THE END OF THE FILE IS REACHED -C (IF THIS IS THE LAST PATIENT), OR WHEN THE START OF THE NEXT -C PATIENT OCCURS. - - 70 READ(27,1717,IOSTAT=IEND) READLINE - IF(IEND .LT. 0) GO TO 200 - IF(READLINE(3:16) .EQ. 'LAST AND FIRST') GO TO 200 - WRITE(37,1717) READLINE - GO TO 70 - 200 BACKSPACE(27) - -C FILE 27 WAS BACKSPACED ONE LINE SO THE NEXT LINE TO BE READ IN IN -C MAIN WILL BE THE FIRST LINE OF THE NEXT SUBJECT (UNLESS THIS SUBJECT -C IS THE SUBJECT, IN WHICH CASE THE BACKSPACE WON'T MATTER). - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(ICOPY .EQ. 0) CONDITION. - - - RETURN - END - -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C - SUBROUTINE ORDERDELTA(NDRUG,DELTAIV,NDELTA,ORDELT) - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION DELTAIV(7),ORDELT(7),X(7) - -C SUBROUTINE ORDERDELTA IS CALLED BY NEWWORK1 TO OBTAIN NDELTA, THE NO. -C OF UNIQUE NON-0 VALUES IN THE DELTAIV(.) ARRAY. THEN THE ORDERED SET -C OF THESE NDELTA VALUES IS PUT INTO ORDELT(.). NOTE THAT -C NDELTA WILL BE 0 IF ALL THE PARTICIPATING DRUGS ARE BOLUSES SINCE -C THEY WOULDN'T NEED AN ENDING TIME THEN. - - -C FIRST STORE ALL THE VALUES IN DELTAIV INTO X SO THAT DELTAIV WILL -C NOT BE CHANGED. - - DO IDRUG = 1,NDRUG - X(IDRUG) = DELTAIV(IDRUG) - END DO - - -C THE LOGIC OF THIS ROUTINE IS BASED ON \PERSONAL\FINANCE\ORDER.FOR. -C TO DO THIS, EACH VALUE IN X(.) WILL BE COMPARED TO THE -C PREVIOUS ONE. IF IT IS < THE PREVIOUS ONE, THE VALUE WILL EXCHANGE -C PLACES WITH THE PREVIOUS ONE, AND THE TESTING WILL CONTINUE. THE -C TESTING WILL STOP FOR A VALUE WHEN IT IS COMPARED TO A PREVIOUS -C VALUE WHICH IS .LE. ITS VALUE. - - DO IDRUG = 2, NDRUG - - -C COMPARE VALUE FOR IDRUG WITH EACH PREVIOUS VALUE, AND HAVE IT -C EXCHANGE PLACES WITH THAT VALUE, UNTIL IT REACHES ONE WHICH HAS A -C SMALLER VALUE. FIRST SET IDRUGNEW = IDRUG; AFTER THE FOLLOWING -C CODE, IDRUGNEW WILL BE THE INDEX NO. FOR VALUE AT THE OLD IDRUG -C POSITION. - - IDRUGNEW = IDRUG - - ICOMP = IDRUG - - 110 ICOMP = ICOMP - 1 - -C NOW COMPARE VALUE IN LOCATION ICOMP WITH THE VALUE IN LOCATION -C IDRUGNEW. IF THE LATTER IS .LT. THE FORMER, INTERCHANGE THE RECORDS. - - IF(X(IDRUGNEW) .LT. X(ICOMP)) THEN - - VALUE = X(IDRUGNEW) - X(IDRUGNEW) = X(ICOMP) - X(ICOMP) = VALUE - IDRUGNEW = ICOMP - - -C IF IDRUGNEW = 1, IT HAS BEEN CHECKED AGAINST ALL RECORDS (AND IS -C THE SMALLEST VALUE); IF IS IS > 1, CONTINUE THE PROCESS. - - IF(IDRUGNEW .EQ. 1) GO TO 150 - IF(IDRUGNEW .GT. 1) GO TO 110 - - - - ENDIF - -C THE ABOVE ENDIF IS FOR THE -C IF(X(IDRUGNEW) .LT. X(ICOMP)) CONDITION. - - - 150 END DO - -C THE ABOVE END DO IS FOR THE DO IDRUG = 2, NDRUG LOOP. - - -C NOW THE NDRUG VALUES ARE ORDERED, FROM SMALL TO LARGE IN X. -C REWRITE THEM INTO ORDELT, BUT PUT ONLY THE NON-0 AND -C UNIQUE VALUES INTO ORDELT, AND KEEP TRACK OF NOW MANY OF THESE -C UNIQUE NON O VALUES THERE ARE - IT WILL BE NDELTA AT THE END OF -C THE FOLLOWING LOOP. - - NDELTA = 0 - - DO IDRUG = 1,NDRUG - -C FOR THIS VALUE TO BE COUNTED, IT CANNOT = THE PREVIOUS VALUE, AND -C IT CANNOT = 0. - - - - IF(IDRUG .EQ. 1 .AND. X(IDRUG) .GT. 0) THEN - NDELTA = NDELTA + 1 - ORDELT(NDELTA) = X(IDRUG) - ENDIF - - - - IF(IDRUG .GE. 2) THEN - - CALL THESAME(X(IDRUG),X(IDRUG-1),ISAME) - - IF(ISAME .EQ. 0) THEN - NDELTA = NDELTA + 1 - ORDELT(NDELTA) = X(IDRUG) - ENDIF - - ENDIF - - END DO - -C THE ABOVE END DO IS FOR THE DO IDRUG = 1,NDRUG LOOP. - - - RETURN - END -C -CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -C TOOK OUT SUBROUTINE THESAME - - - -C NPAGFULLA11.FOR 6/30/14 - -C NPAGFULLA11 HAS THE FOLLOWING CHANGES TO NPAGFULL11: - -C 1. JUST AFTER THE REWIND(27) STATEMENT, SUBROUTINE NEWWORK1 IS -C CALLED TO READ THE PATIENT DATA FROM FILE 27, AND CONVERT IT TO -C PATIENT DATA ON FILE 37, WITH EACH STEADY STATE DOSE INDICATOR -C RESULTING IN AN EXTRA 100 DOSE SETS (WITH THE NEGATIVE DOSE TIME -C LEFT IN - SEE COMMENTS BELOW). NOTE THAT THIS SUBROUTINE NEWWORK1 -C IS THE SAME AS IN THE CURRENT NPAG "ENGINE" MODULE, npageng25.f, -C EXCEPT IT READS FILE 27 AND WRITES TO FILE 37, RATHER THAN READING -C FROM FILE 23 AND WRITING TO FILE 27; ARRAY TIMOBREL IS NOT -C ESTABLISHED IN NEWWORK1, AND NOT PASSED AS AN ARGUMENT (IT IS NOT -C NEEDED IN THIS PROGRAM); MAXSUB IS ALSO NOT PASSED AS AN -C ARGUMENT (IT IS NOT NEEDED); NSUB IS NOT PASSED AS AN ARGUMENT (IT -C IS NOT NEEDED); AND COMMON/DOSEOBS AND THE ARRAYS IN IT ARE DELETED -C (THEY ARE NOT NEEDED). - -C NOTE THAT SUBROUTINE NEWWORK1 IS INCLUDED IN THE NPAGFULLA MODULE. - -C 2. IF THE PROGRAM BOMBS, THE MESSAGE THAT IS WRITTEN TO THE SCREEN -C WILL NOW ALSO BE WRITTEN TO THE FILE ERRFIL = ERRORxxxx, WHERE xxxx -C IS THE 4-DIGIT RUN NO. IN THIS WAY, IF THE PROGRAM IS BEING RUN USING -C Pmetrics, THE Pmetrics PROGRAM CAN RESPOND APPROPRIATELY. NOTE THAT -C ERRFIL IS PASSED TO ALL THE ROUTINES WHICH COULD WRITE TO IT -C USING COMMON/ERR/ERRFIL. - -C 3. THE MAXIMUM NO. OF OUTPUT EQUATIONS WILL BE CHANGED FROM 6 TO 7, -C AND TO FACILITATE ANY FUTURE SUCH CHANGES, THIS NUMBER WILL BE SET -C = MAXNUMEQ (SO ONLY THE PARAMETER STATEMENT WILL HAVE TO BE CHANGED -C IN THE FUTURE). RATHER THAN PASS MAXNUMEQ TO ALL THE RELEVANT -C SUBROUTINES (AS IS DONE IN NPAG113.FOR AND IT2B110.FOR), THIS -C PROGRAM WILL JUST HAVE MAXNUMEQ SET IN A PARAMETER STATEMENT IN ALL -C THESE ROUTINES. AND NOTE THAT IN THOSE SUBROUTINES, ANY 6 -C REFERRING TO THE MAX. NO. OF OUTPUT EQUATIONS WILL BE CHANGED TO -C MAXNUMEQ. - -C 4. COMMON/OBSER IN MAIN IS REMOVED. IT WASN'T NEEDED. SIMILARLY -C ALL THE ARRAYS IN THIS COMMON ARE NO LONGER DIMENSIONED. - -C 5. FORMATS 2345 AND 2346 NOW CORRECTLY REFER TO SUBROUTINE -C NPAGFULL1, RATHER THAN NPAGFULL. - -C----------------------------------------------------------------------- - -C NPAGFULL11.FOR 8/06/13 - -C NPAGFULL11 HAS THE FOLLOWING CHANGE2 FROM NPAGFULL1: -C 1. INSTEAD OF SELELCTING ALL GRID PTS. WHOSE PROBALITIES ARE WITHIN -C 1.D-10 OF THE HIGHEST, THIS PROGRAM TAKES ALL POINTS WHOSE PROBS ARE -C WITHIN 1.D-100 OF THE HIGHEST. - -C SEE THE "IF(MAXCYC .EQ. 0) THEN" CODE NEAR THE END OF MAIN. - -C 2. THE MAIN SUBROUTINE IS RENAMED NPAGFULL11 (INSTEAD OF NPAGFULL). - -C 3. ALL SUBROUTINES OTHER THAN THE MAIN ONE ARE REMOVED SINCE THEY -C ARE ALREADY IN NPAGFULL.FOR, WHICH WILL ALSO BE LINKED TO -C BESTDOSTEMP.FOR (TO BE RENAMED BESTDOS112.FOR) - -C 4. MAXCYC IS REMOVED FROM THE ARGUMENT LIST SINCE IT IS HARDCODED -C TO BE 0 BELOW. - -C----------------------------------------------------------------------- - -C NPAGFULL1.FOR 6/30/13 - -C NPAGFULL1 HAS THE FOLLOWING CHANGES TO NPAGFULL: - -C - MAXCYC IS MANUALLY SET = 0, SO THE VALUE INPUT IN THE ARGUMENT -C STATEMENT IS UNIMPORTANT. -C - AFTER LOOP 800, CONTROL GOES TO LABEL 900 IF MAXCYC = 0. SO THIS -C IS SIMILAR CODE TO npageng24.f, IN THAT IF MAXCYC = 0, NO CYCLE -C CALCS. ARE DONE --> SUBROUTINE emint IS NEVER CALLED. -C - AT LABEL 900, IF MAXCYC = 0 (WHICH OF COURSE IT IS), THEN THE -C REMAINING CODE (FROM SUBROUTINE SUBRES OF npageng24.f) IS USED -C TO FINISH CALCULATING THE BAYESIAN POSTERIOR OF THE SUBJECT. -C AND THIS NEW CORDEN IS RETURNED TO THE MAIN BESTDOS MODULE. - -C------------------------------------------------------------------ - -C NPAGFULL.FOR 3/26/13 - -C NPAGFULL IS BASED ON THE npageng22.f PROGRAM. IT RUNS AN NPAG -C ANALYSIS IN ORDER TO OBTAIN THE FULL POSTERIOR DENSITY OF A SUBJECT -C GIVEN AN APRIORI DENSITY. ALL OTHER CODE IN npageng22.f IS -C REMOVED (E.G., ALL EXTRA CALCULATIONS, ALL WRITING TO FILES, ETC.). - -C NOTE THAT ALL INFO NEEDED BY THIS ROUTINE IS INCLUDED IN THE -C CALLING ARGUMENTS; IN PARTICULAR, npag102.inp IS NOT READ. - -C THIS COMPARES TO NPAGBAY, WHICH CALCULATED THE 0-CYCLE BAYESIAN -C POSTERIOR OF THE SUBJECT. - -C NOTE ALSO THAT ALL DIMENSIONS OF 500 RELATED TO DOSE EVENTS HAVE BEEN -C CHANGE TO 5000. - -C----------------------------------------------------------------------- - -c npageng22.f 11/8/12 - -c npageng22 has the following change from npageng21: - -c 1. It comments out the PAUSE statement following Format 164 in -c Subroutine emint. Reason: the program will not complete properly if -c it is run under Pmetrics (which cannot supply a keyboard response -c during a run). - -c 2. Formats 1657 and 7124 are changed to show that the output file -c is made by npageng22 rather than npageng21. - -c----------------------------------------------------------------------- - -c See npageng22.f code for all the comments from npageng21.f back -c to m2_5calf.f. - - -C----------------------------------------------------------------------- - -C*********************************************************************** - - SUBROUTINE NPAGFULL11(MAXSUB,MAXGRD,MAXDIM,NVAR,NUMEQT,WORK,WORKK, - 1 CORDEN,NDIM,MF,RTOL,ATOL,NOFIX,IRAN,VALFIX,AB,ierrmod,GAMLAM0, - 2 NGRID,NACTVE,PYJGX,DENSTOR,CORDLAST) - -C NOTE FOR NPAGFULL11, MAXCYC IS NOT SUPPLIED FROM BESTDOS... SINCE -C IT WILL BE HARDCODED TO BE 0 BELOW. - - - IMPLICIT REAL*8(A-H,O-Z) - - PARAMETER(MAXNUMEQ=7) - - - DIMENSION WORK(MAXGRD),WORKK(MAXGRD),PYJGX(MAXSUB,MAXGRD), - 1 DENSTOR(MAXGRD,4),CORDEN(MAXGRD,MAXDIM+1), - 2 CORDLAST(MAXGRD,MAXDIM+1), YO(594,MAXNUMEQ),SIG(594,MAXNUMEQ), - 3 AB(30,2),X(30),VALFIX(20),IRAN(32),PX(32),ATOL(20), - 4 C0(MAXNUMEQ),C1(MAXNUMEQ),C2(MAXNUMEQ),C3(MAXNUMEQ),ATOLL(20) - -C NOTE THAT ALL DIMENSIONS = 150 HAVE BEEN CHANGED TO 594, SINCE THIS -C NO. REPRESENTS THE TOTAL NO. OF OBSERVATIONS (AND THE MAX. NO IS -C 6 OUTPUT EQUATIONS x 99 OBSERVATIONS/EQ). THIS COULD BE CHANGED -C TO NUMEQT*MAXOBS, BUT IT WOULD BE MORE TROUBLE THAN IT'S WORTH TO -C MAKE THESE DIMENSIONS VARIABLE. - - CHARACTER ERRFIL*20 - - COMMON/ERROR/ERRFIL -C COMMON/ERROR/ IS SUPPLIED TO ALL THE ROUTINES WHICH COULD WRITE TO -C ERRFIL. AND ERRFIL IS MADE CHARACTER *20 ABOVE. - - - COMMON SIG - COMMON/TOUSER/NDIMM,MFF,RTOLL,ATOLL - COMMON/NXER/NXE -C NXE FROM ABOVE COMMON IS NO. OF TIMES XERRWD IS CALLED. - -C THE BLANK COMMON ABOVE IS SUPPLIED TO SUBROUTINE IDPC. - - -C COMMON/TOUSER IS SUPPLIED TO SUBROUTINE USERANAL IN idfixed.f. -C COMMON/OBSER/ IS SUPPLIED FROM SUBROUTINE FILREAD. -C NO! AS OF NPAGFULLA.FOR, COMMON/OBSER IS REMOVED FROM MAIN. IT IS -C UNNEEDED. SIMILARLY, TIMOB, DOSTIM, RS, Y00, AND BS ARE NO LONGER -C DIMENSIONED IN MAIN. - - -C*********************************************************************** - -C----------------------------------------------------------------------- - - 2 FORMAT(A20) - 222 FORMAT(A3) - 2222 FORMAT(A5) - -C----------------------------------------------------------------------- - -C SET MAXCYC = 0 - MAXCYC = 0 - - NSUB = 1 - - NDIMM = NDIM - MFF = MF - RTOLL = RTOL - DO I = 1,NDIM - ATOLL(I) = ATOL(I) - END DO - -C THE ABOVE VALUES HAD TO BE ESTABLISHED SINCE THE SAME VARIABLES -C CANNOT BE IN COMMON STATEMENTS IF THEY ARE DUMMY CALLING ARGUMENTS. - - - - -C NOTE THAT THIS SUBROUTINE WAS CALLED BY BESTDOSxxx.FOR/MAIN, WHICH -C HAS ALREADY WRITTEN TO SCRATCH FILE 27 THE DATA FROM THE SINGLE -C SUBJECT WHOSE POSTERIOR DENSTIY IS TO BE CALCULATED, BASED ON THE -C PRIOR DENSITY INPUT PASSED TO THIS ROUTINE IN CORDEN. - - -c As of npageng14.f, tol is hardcoded to be 1.D-4. Previously, it -c was allowed to be any positive number .GE. 1.D-4. - - tol = 1.D-4 - - -C ESTABLISH ASSAY VALUES FROM ierrmod AND gamlam0. - - - gamma = 1.d0 - flat = 1.d0 - if(ierrmod .eq. 2) gamma = gamlam0 - if(ierrmod .eq. 3) gamma = gamlam0 - if(ierrmod .eq. 4) flat = gamlam0 - - igamma = 0 - gamdel=0.1 - if(ierrmod.eq.1) gamdel=0.d0 - - -C CHANGE NGRID TO BE MAXGRD, IF IT IS > MAXGRD. - -C???DEBUG 3/23. NGRID IS NOT A DIMENSION --> IT IS NEEDED TO BE -C WHATEVER IT IS FROM THE NPAGDENFILE INPUT INTO THE BESTDOS MAIN -C MODULE. SO DON'T LIMIT IT TO BE .LE. MAXGRD. - -C if(ngrid .gt. MAXGRD) then - -C write(6,*) - -C write(6,*) 'requested NGRID = ',NGRID -C write(6,*) 'maximum allowable is MAXGRD = ',MAXGRD -C write(6,*) 'resetting NGRID = ',MAXGRD -C write(6,*) 'to fit in available storage' -C write(6,*) - -C ngrid = MAXGRD - -C endif - - - -C CALCULATE VOLSPA, THE 'VOLUME' OF THE INTEGRATION SPACE (NEEDED IN -C CALLS TO NOTINT). - - VOLSPA=1.D0 - DO 170 I=1,NVAR - 170 VOLSPA = VOLSPA*(AB(I,2)-AB(I,1)) - - -C NOTE IN THIS PROGRAM, THE USER WILL ALWAYS INPUT A PRIOR DENSITY -C WITH VALUES IN CORDEN, SO THE ICYCLE = 0 CODE HAS BEEN REMOVED. - - -C AS OF npageng19.f, PRESET NACTLAST TO BE NACTVE. THIS WAY, IN THE -C UNLIKELY EVENT THAT THE FIRST CYCLE OF A RUN HAS A HESSIAN ERROR -C (WHICH MEANS THAT WHEN CONTROL COMES BACK TO MAIN FROM SUBROUTINE -C emint, IT IS TRANSFERRED TO LABEL 900 AND THEREFORE SKIPS THE -C cbegin statistics SECTION WHERE NACTLAST = NACTVE IS SET), THERE -C WON'T BE A PROBLEM WHEN NACTVE IS SET = NACTLAST JUST BELOW LABEL -C 900. IN PREVIOUS PROGRAMS, IN THE ABOVE SITUATION, BELOW LABEL 900, -C NACTVE = NACTLAST WOULD RESULT IN NACTVE BEING SET = 0 SINCE -C NACTLAST WAS UNITIALIZED. - - NACTLAST = NACTVE - - - prefobj=-1.d30 - prebig=-1.d30 - - -C SET ICYCLE = 0. THE PROGRAM WILL RUN UP TO MAXCYC CYCLES. - - ICYCLE = 0 - -C CORDEN HOLDS, IN ITS FIRST NACTVE ROWS, THE STARTING JOINT DENSITY -C AND COORDINATE VALUES. FOR K=1,NACTVE, CORDEN(K,J) = JTH COORDINATE -C OF THE KTH ACTIVE POINT, J=1,NVAR; AND CORDEN(K,NVAR+1) IS THE -C ASSOCIATED DENSITY FOR THE KTH ACTIVE POINT. - -C IF ICYCLE .GT. 0, CORDEN WAS READ IN. -C IF ICYCLE = 0, NACTVE=NGRID, AND CORDEN WAS FILLED AT LABEL 30 ABOVE. -C IN THIS CASE, THE DENSITY IS UNIFORM, SO ALL -C CORDEN(K,NVAR+1) VALUES = 1/VOLSPA, K=1,NACTVE. - - -C IPRED=11 + ICYCLE -C JCOL=0 - ITEST=0 - -C IPRED IS THE CYCLE NO. WHERE THE NEXT 2-CYCLE PREDICTION -C ALGORITHM STARTS (IT IS NO LONGER USED). JCOL = COLUMN NO. OF DENSTOR -C IN WHICH IS STORED THE DENSITY OF ONE OF THE 2-CYCLES USED IN THE -C PREDICTION (IT IS NO LONGER USED). IT IS SET = 0 ABOVE, SINCE NO -C STORAGE IS REQUIRED UNTIL CYCLE NO. 11 - - -C (SEE BELOW). ITEST=0 --> THE NEXT CYCLE IS NOT (INITIALIZED) TO BE -C A TEST CYCLE (SEE CODE BELOW WHEN ITEST=1,2, OR 3). - -C NEW FOR m2_13cal.f: NSTORE SET = 0. NSTORE IS THE NO. OF GRID -C POINTS, WHOSE P(YJ|X) VALUES HAVE BEEN STORED IN PYJGX IN LOOP 800. -C THIS NO. CAN BE CHANGED BY THE 'CONDENSING' CODE BELOW, SINCE -C INACTIVE POINTS ARE THROWN OUT. - - NSTORE=0 -cadapt initialize grid resoution to 20% - resolve=0.20 - - - - - 1001 ICYCLE=ICYCLE+1 - - -cgam3 -10001 continue -c above is new entry point for gammaplus/minus eps tries - itest = 0 - - -cadapt reset number of stored points to that before expansion -c nstore=nstoresv - - -C 1239 FORMAT(///' CYCLE NO.',I5,/) - -C ICYCLE IS THE NUMBER OF THE NEXT CYCLE TO BE RUN. -C -C THIS IS WHERE EACH NEW CYCLE STARTS (FOR EACH CYCLE, THE DENSITY OF -C X IS UPDATED FROM THE PREVIOUS DENSITY ESTIMATE, USING THE -C OBSERVED SUBJECT DATA FROM THE INPUT DATA FILES WHICH ARE PASSED TO -C SUBROUTINE IDPC BELOW. -C - - -C START THE SUBJECT LOOP. - - -C REWIND SCRATCH FILE 27 WHICH HAS ALL THE SUBJECT DATA FILES -C CONCATENATED ON IT, IN ORDER. ACTUALLY THERE IS ONLY NSUB = 1 -C SUBJECT IN THIS RUN. - - REWIND(27) - -C PUT THE SUBJECT'S DATA ONTO FILE 37 BY CALLING SUBROUTINE NEWWORK1 -C (SIMILAR ROUTINE TO THE ONE IN npageng25.f, EXCEPT IT READS FILE 27 -C AND WRITES TO FILE 37, RATHER THAN READING FROM FILE 23 AND WRITING -C TO FILE 27). NOTE THAT IT HAS NO ARGUMENTS; NONE ARE NEEDED IN THIS -C PROGRAM. - -C NOTE THAT IF THE SUBJECT FILE HAS NO STEADY STATE DOSE INDICATORS, IT -C WILL NOT BE CHANGED; IF IT DOES, IT WILL BE ALTERED TO INCLUDE AN -C EXTRA 100 DOSES SETS FOR EACH STEADY STATE DOSE INDICATOR. NOTE THAT -C SUBROUTINE NEWWORK1 WILL LEAVE IN THE NEGATIVE DOSE TIME (WHICH IS -C THE STEADY STATE DOSE INDICATOR) BECAUSE THE ID ROUTINES NEED TO SEE -C THIS INDICATOR TO KNOW THAT A STEADY STATE DOSE SET IS COMING. - - OPEN(37) - - - CALL NEWWORK1 - REWIND(37) - - - - -C NOBTOT WILL BE THE RUNNING TOTAL OF ALL NON-MISSING OBSERVED VALUES -C OVER ALL THE NSUB SUBJECTS. THIS IS NEEDED TO CALCULATE BIC BELOW. - - NOBTOT = 0 - - - DO 1000 JSUB=1,NSUB - - -C CALL SUBROUTINE FILREAD TO READ, FOR THIS SUBJECT, FROM SCRATCH FILE -C 37, THE NO. OF OBSERVATION TIMES (NOBSER) AS WELL AS THE -C OBSERVED VALUES THEMSELVES: YO(I,J) = THE 'NOISY' OBSERVED VALUES -C FOR THIS SUBJECT; I=1,NOBSER, J=1,NUMEQT. THESE OBSERVED VALUES ARE -C USED ONLY TO CALCULATE THE ASSAY STANDARD DEVIATIONS (USING THE -C VECTORS, C0,C1,C2,C3, WHICH ARE ALSO READ IN). THE REST OF THE INFO -C IN THE SUBJECT DATA FILE IS PASSED IN COMMONS TO THE IDPC MODULE -C SUBROUTINES. - - CALL FILREAD(NOBSER,YO,C0,C1,C2,C3) - -C FIND THE ASSAY STANDARD DEVIATIONS FOR THIS SUBJECT. FOR EACH -C OF THE NOBSER*NUMEQT OBSERVED VALUES (EXCEPT THAT YO(I,J) = -99 --> -C OUTPUT EQ. J HAS NO OBSERVED LEVEL FOR OBSERVATION TIME I), -C Y, SIG = C0 + C1*Y + C2*Y**2 + C3*Y**3. -C NOTE THAT, THEORETICALLY, SIG SHOULD BE A CUBIC FNT. OF -C THE 'TRUE' OBSERVED VALUES, NOT THE 'NOISY' OBSERVED VALUES (BUT THE -C 'TRUE' VALUES ARE UNKNOWN). - -C ALSO, CALCULATE SIGFAC, THE PRODUCT OF THE NON-MISSING STD. DEV.'S -C (A NON-MISSING S.D. IS ONE FOR WHICH THE CORRESPONDING YO(I,J) IS -C .NE. -99, THE MISSING VALUE CODE). -C INITIALIZE SIGFAC=1, AND THEN UPDATE IT FOR EACH NON-MISSING -C OBSERVATION. - -C MISVAL WILL BE THE RUNNING TOTAL OF MISSING VALUES AMONG ALL THE -C NUMEQT x NOBSER POTENTIAL OBSERVED LEVELS. - - MISVAL = 0 - - SIGFAC=1.D0 - - DO 140 I=1,NOBSER - DO 140 J=1,NUMEQT - - Y = YO(I,J) - -C IF Y = -99, IT MEANS THAT OUTPUT EQ. J HAD NO VALUE AT OBSERVATION -C TIME I. IN THIS CASE, IGNORE THIS Y AND INCREASE MISVAL BY 1. - - - IF(Y .EQ. -99) THEN - MISVAL = MISVAL+1 - GO TO 140 - ENDIF - -C NOTE: FOR EACH SUBJECT, MUST ENSURE THAT ALL THE STD DEV'S ARE NON- -C ZERO. OTHERWISE, THE PROGRAM WILL BLOW UP! THIS IS BECAUSE -C P(YJ|X) INVOLVES SQUARED DIFFERNCES BETWEEN OBSERVED Y'S AND -C EXPECTED Y'S (FOR EACH X GRID POINT)...EACH DIFFERENCE -C NORMALIZED (I.E., DIVIDED) BY THE VARIANCE OF THE RESPECTED -C OBSERSATION. - -C SEE M2_17CAL.F CODE FOR COMMENTS ON HOW A STD. DEV. COULD = 0. - -C ALSO TEST TO MAKE SURE NO STD. DEV. < 0, SINCE SIGFAC BEING NEGATIVE -C WOULD RESULT IN A NEGATIVE PROBABILITY (SEE PYJGX CALCULATION BELOW). - - SIG(I,J) = C0(J)+C1(J)*Y+C2(J)*Y*Y+C3(J)*Y**3 -cgam4 - if(ierrmod.eq.2) sig(i,j) = sig(i,j)*gamma - if(ierrmod.eq.3) sig(i,j)=dsqrt(sig(i,j)**2 + gamma**2) - if(ierrmod.eq.4) sig(i,j) = gamma*flat - - IF(SIG(I,J) .EQ. 0) THEN - - WRITE(*,2345) JSUB -2345 FORMAT(//' A S.D. IS 0 FOR JSUB = ',I5,'. RERUN THE '/ - 1' PROGRAM WITH C0 NOT = 0 FOR THIS SUBJECT, OR WITH THIS'/ - 2' SUBJECT ELIMINATED.'// - 3' THIS IS IN SUBROUTINE NPAGFULL11.'/) - CLOSE(37) - - OPEN(47,FILE=ERRFIL) - WRITE(47,2345) JSUB - CLOSE(47) - - - CALL PAUSE - STOP - - ENDIF - - IF(SIG(I,J) .LT. 0) THEN - - WRITE(*,2346) JSUB -2346 FORMAT(//' A S.D. < 0 FOR JSUB = ',I5,'. RERUN THE '/ - 1' PROGRAM WITH A BETTER CHOICE FOR THE ASSAY ERROR POLYNOMIAL'/ - 2' COEFFICIENTS.'// - 3' THIS IS IN SUBROUTINE NPAGFULL11.'/) - CLOSE(37) - - OPEN(47,FILE=ERRFIL) - WRITE(47,2346) JSUB - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - SIGFAC=SIGFAC*SIG(I,J) - - 140 CONTINUE - -C NOTE THAT SIGFAC WAS CALCULATED IN LOOP 140 ABOVE, AND THAT OFAC IS -C NOW THE RESULT OF (NOBSER*NUMEQT - MISVAL) VALUES. - - OFAC=2.506628274631**(NOBSER*NUMEQT - MISVAL) - NOBTOT = NOBTOT + NOBSER*NUMEQT - MISVAL - - -C NOTE THAT 2.5066... = SQRT(2*PI). - -C FOR EACH SUBJECT, AND EACH GRID POINT, CALL IDPC, A SUBROUTINIZED -C VERSION OF THE ADAPT PROGRAM ID3 TO CALCULATE THE SUM OF SQUARES OF -C DIFFERENCES BETWEEN THE OBSERVED VALUES AND PREDICTED (BY THE MODEL) -C VALUES (NORMALIZED BY THE ASSAY VARIANCE OF EACH OBSERVATION) ... - - 8888 FORMAT(' ',' CYCLE ',I5,', SUBJECT ',I5,' ... % COMPLETED = ', - 1F8.2) - XNEXT = 1.D0 - -C SEVERAL CHANGES FOR m2_13cal.f ARE IN LOOP 800. - - DO 800 IG=1,NACTVE - - -C PRINT TO THE SCREEN THE UPDATE ON WHAT % OF GRID POINTS HAVE BEEN -C CALCULATED IF NACTVE > NSTORE (I.E., IF NACTVE .LE. NSTORE --> -C ALL P(YJ|X)'s ARE ALREADY STORED INTO PYJGX AND SO THIS 8OO LOOP -C WILL GO VERY FAST. - - IF(NACTVE .GT. NSTORE) THEN - -C PRINT GRID PT. AND % COMPLETED TO SCREEN. - XPER=IG*100.D0/NACTVE - - IF(XPER .GE. XNEXT) THEN - - IF(ICYCLE.eq.1) THEN - WRITE(*,8888) ICYCLE,JSUB,XPER - IF(NXE .GT. 0) WRITE(*,1254) NXE - 1254 FORMAT(' TOTAL NO. OF NUM. INTEG. WARNINGS IS ',I20) - ENDIF - - XNEXT=XNEXT+1.D0 - - ENDIF - - ENDIF - - IF(IG .LE. NSTORE) GO TO 700 - - -C ESTABLISH THE IGTH GRID POINT. IT IS STORED IN ROW IG OF -C CORDEN. - - DO J=1,NVAR - X(J)=CORDEN(IG,J) - END DO - -C ESTABLISH THE COMBINED RANDOM AND FIXED PARAMETER VALUES INTO -C PX -- IN THE CORRECT ORDER AS INDICATED BY VECTOR IRAN. CALL -C MAKEVEC TO DO THIS. - - - CALL MAKEVEC(NVAR,NOFIX,IRAN,X,VALFIX,PX) - - CALL IDPC(PX,W) - -C W RETURNS AS THE SUM OF: -C ((YO(I,J)-H(I,J))/SIG(I,J))**2, WHERE H(I,J) = PREDICTED VALUE OF THE -C JTH OUTPUT EQ AT THE ITH OBSERVATION TIME, ASSUMING THE IGTH GRID -C POINT, X, ... OVER THE NOBSER x NUMEQT QUANTITIES ABOVE WHICH DON'T -C HAVE YO(I,J) = -99 (WHICH MEANS THAT OUTPUT EQ. J HAS NO OBSERVED -C LEVEL FOR TIME I). - -C CALCULATE P(YJ|X) FOR X-GRID POINT NO. IG. - -C THIS NEXT TEST IS FOR THE PC. AS AN EXAMPLE, THE COMPAC COMPUTER -C CANNOT HANDLE ARGUMENTS TO DEXP WHICH ARE SMALLER THAN -11354. SINCE -C THE ARGUMENT TO DEXP BELOW IS -.5*W, SET PYJGX = 0 IF W IS .GT. -C 22708. - -C SEE CODE AFTER CALCULATION OF P(YJ) TO SEE WHAT HAPPENS IF ALL THE -C P(YJ|X) ARE SET = 0. - -C NOTE THAT WORKK WILL ALWAYS BE SET = P(YJ|X=IG GRID PT), WHICH IS -C NEEDED IN THE CALCULATION OF DXI (NOTE DXI NOT USED AS OF -C bignpaglap1.f) SINCE PYJGX WILL NOT BE COMPLETE IF NACTVE > MAXGRD. - - IF(IG .LE. MAXGRD) PYJGX(JSUB,IG)=0.D0 - WORKK(IG) = 0.D0 - - IF(W .LE. 22708.D0) THEN - IF(IG .LE. MAXGRD) PYJGX(JSUB,IG) = DEXP(-.5D0*W)/SIGFAC/OFAC - WORKK(IG) = DEXP(-.5D0*W)/SIGFAC/OFAC - ENDIF - -C CALCULATE P(X,YJ) FOR X-GRID POINT NO. IG. PUT IT INTO WORK(IG). - - IF(IG .GT. MAXGRD) THEN - WORK(IG) = WORKK(IG)*CORDEN(IG,NVAR+1) - GO TO 800 - ENDIF - - 700 WORK(IG)=PYJGX(JSUB,IG)*CORDEN(IG,NVAR+1) - - WORKK(IG) = PYJGX(JSUB,IG) - -C???DEBUG -C WRITE(*,3631) ICYCLE,IG,PYJGX(JSUB,IG) -C 3631 FORMAT(' ICYCLE,IG,PYJGX(JSUB,IG): ',I3,2X,I2,2X,F20.15) - - 800 CONTINUE - -C???DEBUG -C CALL PAUSE - - -C CALCULATE P(YJ), A SCALAR WHICH IS THE INTEGRAL OF P(X,YJ) OVER - -C X-SPACE. - -C CALL NOTINT, AN INTEGRATION ROUTINE. THE -C FOLLOWING IS SUPPLIED TO THIS ROUTINE: -C VOLSPA = VOLUMNE OF THE INTEGRATION SPACE. -C NGRID = NO. OF ORIGINAL GRID POINTS. -C NACTVE = NO. OF ACTIVE GRID POINTS. -C WORK(I), I=1,NACTVE = VALUE OF THE FUNCTION TO BE INTEGRATED, AT -C THE ITH GRID POINT. -C MAXGRD = THE DIMENSION OF WORK. - - CALL NOTINT(VOLSPA,NGRID,NACTVE,WORK,MAXGRD,PYJ) - - -C IF PYJ RETURNS AS 0, IT IS BECAUSE P(X,YJ)=WORK IS 0 IN ALL ITS -C NACTVE ENTRIES. THIS OCCURS WHEN EACH OF NACTVE VALUES OF W (WHICH -C RETURNS FROM THE CALLS TO IDPC) IS LARGER THAN 1416 (SINCE P(YJ|X) -C INVOLVES e RAISED TO THE POWER -.5*W, AND e RAISED TO A POWER -C SMALLER THAN -708 IS SET TO 0 BY, FOR EXAMPLE, THE COMPAC COMPUTER). -C - -C IN CASE THIS HAPPENS, PRINT A MESSAGE TO THE USER AND STOP. -C - IF (PYJ .EQ. 0.D0) THEN - - WRITE(*,26) - 26 FORMAT(//' FOR THIS SUBJECT, THE PROB. OF THE OBSERVED'/ - 1' CONCENTRATIONS (FOR THE INDICATED DOSAGE REGIMEN), GIVEN EACH '/ - 2' AND EVERY GRID POINT IN THE ESTABLISHED GRID, IS 0. THE '/ - 3' PROGRAM STOPS. THE USER SHOULD CONSIDER INCREASING THE'/ - 4' NO. OF GRID POINTS ALLOWED (HARDCODED INTO MAIN), AND/OR '/ - 5' NARROWING THE GRID BOUNDARIES OF THE VARIABLES, AND/OR '/ - 6' INCREASING THE SIZES OF (C0,C1,C2,C3), THE ASSAY NOISE '/ - 7' COEFFICIENTS. ALL OF THESE CHANGES WILL HAVE THE EFFECT OF'/ - 8' MAKING SOME OF THE ABOVE CONDITIONAL PROBABILITES LARGER.'// - 9' THIS IS IN SUBROUTINE NPAGFUL.'/) - - OPEN(47,FILE=ERRFIL) - WRITE(47,26) - CLOSE(47) - - CALL PAUSE - STOP - - ENDIF - - -C??? FOR NPAGFULL1.FOR, IF MAXCYC = 0, GO TO LABEL 900, WHERE -C THE CODE WILL BE TO FINISH CALCULATING THE SIMPLE BAYESIAN -C POSTERIOR FOR THIS SUBJECT, BASED ON THE ABOVE NACTVE GRID PTS. - - IF(MAXCYC .EQ. 0) GO TO 900 - - - - 1000 CONTINUE - - -c begin optimization -cgam5 -cgam5 - from here (immediately after 1000 CONTINUE to -cgam5 - immediately before c end optimization was lifted -cgam5 - from gamadapt1.f, replacing old material beteen these limits - igamma = igamma + 1 - if(ierrmod.eq.1) igamma=1 -csdsc - added April 2, 2000 -c con first iteration, call hte interior point method - - if(mod(igamma,3).eq.1) then - - gammab = gamma - gammap = gamma * (1.d0+gamdel) - gammam = gamma / (1.d0+gamdel) - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,1, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - - nactve = keep - -C???DEBUG -C WRITE(*,*)' AFTER CALL EMINT, NO. 1, NACTVE = KEEP = ',NACTVE - - - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - -C???DEBUG -C WRITE(*,*)' AFTER CALL EMINT, NO. 2, NACTVE = ',NACTVE - - - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. - -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - - - fobjbase = fobj - - - nactve0 = nactve -c new on Jan 2, 2002 - save otpimal solution in denstor(1,4) -c so that stat program can work on best of base, up, and down -c solutions - do i=1,nactve - denstor(i,4)=corden(i,nvar+1) - enddo - nstore = 0 - fobjbest = fobjbase - - if(ierrmod.eq.1) go to 14001 - gamma = gammap - go to 10001 - - endif -cgamma above endif is for mod(igamma,3).eq.1 case - - if(mod(igamma,3).eq.2) then - - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - -C???DEBUG -C WRITE(*,*)' AFTER CALL EMINT, NO. 3, NACTVE = ',NACTVE - - - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - fobjplus = fobj - -c new Jan 2, 2002 - save solution if fobjplus is better than fobjbase - if(fobjplus.gt.fobjbest) then - fobjbest = fobjplus - do i=1,nactve - - denstor(i,4) = corden(i,nvar+1) - enddo - endif - gamma = gammam - - go to 10001 - - endif - - if(mod(igamma,3).eq.0) then - - call emint(pyjgx,maxsub,corden,maxgrd,nactve,nsub,0, - &corden(1,nvar+1),denstor(1,1),denstor(1,2),denstor(1,3), - &fobj,gap,nvar,keep,IHESS) - -C???DEBUG -C WRITE(*,*)' AFTER CALL EMINT, NO. 4, NACTVE = ',NACTVE - - - - -C AS OF npageng18.f, IHESS IS ADDED TO ARGUMENT LIST OF emint. - -C IF IHESS RETURNS AS -1, IT MEANS THE HESSIAN MATRIX IN THE INTERIOR -C POINTS ALGORITHM WAS SINGULAR. IN THIS CASE, GO TO LABEL 900 TO -C CREATE THE OUTPUT FILES BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C NOTE THAT BY GOING TO LABEL 900, NOTHING FROM THIS CYCLE WILL BE -C WRITTEN TO FILE 25, AND THE CORDEN(.,.) MATRIX WILL REMAIN WHAT IT -C WAS FROM THE PREVIOUS CYCLE. - - IF(IHESS .EQ. -1) GO TO 900 - - fobjminu = fobj - - if(fobjminu.gt.fobjbest) then - fobjbest = fobjminu - do i=1,nactve - denstor(i,4) = corden(i,nvar+1) - enddo - endif - - endif - -cgamma - above statement changed from "nstore = nactve" to force -c reevaluation of all points. - -c now temporairily reset to gamma - gamma = gammab - fobj = fobjbase - if(fobjplus.gt.fobjbase) then - gamma = gammap - - fobj = fobjplus - gamdel = 4.*gamdel - endif - - if(fobjminu.gt.fobjbase) then - gamma = gammam - fobj = fobjminu - gamdel = 4.*gamdel - endif - gamdel = gamdel*0.5 - if(gamdel.lt.0.01) gamdel=0.01 -14001 continue -cgam5 above label is entry point for ierrmod = 1 (no gamma) case - -c corden(*,nvar+1) sums to 1 when it comes out of emint -c Now reset forden(i,nvar+1) to best of three solutions -c and normalize to funny BIGNPEM factor - fact=ngrid/volspa - do i=1,nactve - corden(i,nvar+1)=fact*denstor(i,4) - enddo - -C???DEBUG -C WRITE(*,*)' AT END OF OPTIMIZATION, NACTVE = ',NACTVE -C CALL PAUSE - - -cend optimization - - -cbegin statistics - - -c now we compute all hte statistical stuff using this distribution -c and the full nactve (before condensation) points. -c Later, in the condensation performed just before the grid refienment -c and subsequent expansion, we will condense by just using the -c 'keep' flags in DENSTOR(i,1) that emint left there. The density will -c not be updated to refelct this cahnge (there is no need) -c until the next call to emint - - -c As of npageng18.f, save CORDEN to CORDLAST AND NACTVE TO NACTLAST. -c The reason is that if, somewhere during the next cycle's calculations -c (during one of the calls to Subroutine emint), a Hessian Matrix is -c singular, then IHESS will be set = -1, and the program will stop. -c And in this case, the program must be able to write out all of the - -c information from this cycle (the last completed cycle). And that -c means that the CORDEN from this cycle (which will be stored into -c CORDLAST), and NACTVE (store into NACTLAST) should be used in the -c call to Subroutine SUBRES in loop 7000. Otherwise, the CORDEN and -c NACTVE used in that call would have already partly updated in the -c next cycle before the Hessian error occurred. - - DO I = 1,NACTVE - DO J = 1,NVAR+1 - CORDLAST(I,J) = CORDEN(I,J) - END DO - END DO - -C???DEBUG -C WRITE(*,*)' CORDEN IS NOW ' -C DO I = 1,NACTVE -C WRITE(*,5497) (CORDEN(I,J),J=1,3) -C 5497 FORMAT(3(F12.8,2X)) -C END DO -C CALL PAUSE - - NACTLAST = NACTVE - - - IF(MAXCYC .EQ. 0) GO TO 900 - -C Starting with bigmlt1.f, this is a jump point. - - -cend statistics -cbegin control -c we are now done wtih statistics - this is the best place to -c check for whether we can exit - if so , last printed statistic -c will agree with current density corden, and corden is still -c correct (e.g. after condensation-expansion, it is no longer -c correct until we call emint again) -cint.9 control section to check for exit criteria, resolution -c refinement, and end of major cycles - -cint9.a first, we exit if we have reached maxcyc on cycle counter - -C SET IMAXCYC = 0; IF IT CHANGES TO 1, IT MEANS THAT MAXCYC CYCLES -C HAVE BEEN RUN, AND THE PROGRAM WILL STOP. - - IMAXCYC = 0 - - if(icycle .ge. maxcyc) then - - - -C SET IMAXCYC = 1 --> MAXCYC WAS REACHED. - - IMAXCYC = 1 - -C COMMENT OUT THE GO TO 900 STATEMENT BELOW SINCE EVEN IF ICYCLE -C = MAXCYC, THE PROGRAM STILL NEEDS TO TEST TO SEE IF CONVERGENCE -C WAS ACHIEVED IN THE FINAL CYCLE. -C go to 900 - - endif - -c The above endif is for the if(icycle .ge. maxcyc) condition. - - -cint9.b second, we check improvement from last cycle - - ximprove=fobj-prefobj - prefobj = fobj - -cint9.c if ximprove is too low, refine the resolve criterion - - if(dabs(ximprove) .le. tol .and. resolve .gt. 0.0001) then - resolve=resolve*0.5 - endif - -cint9.d check to see if resolve bottoms out - if so, start a new -c major cycle by resetting it to its highest allowable value, or -c exit if the improvment from the last major cycle is too small ... - -C AND EXIT IF IMAXCYC = 1 (SEE ABOVE; THIS MEANS THAT THE MAX. NO. -C OF CYCLES HAS ALREADY BEEN RUN AND THE ONLY REASON THIS PART OF THE -C CODE IS BEING RUN IS TO SEE IF CONVERGENCE WAS ACHIEVED IN THE FINAL -C CYCLE. - - if(resolve.le.0.0001) then - - -c saveres = resolve - resolve=0.2 - checkbig = fobj - prebig - prebig =fobj - -C NOTE THAT THE -C CONVERGENCE CRITERION IS THAT DABS(CHECKBIG) .LE. .01. - - -C WRITE(*,1023) ICYCLE -C1023 FORMAT(/' FOR CYCLE NO, ',I6,' THE CONVERGENCE CRITERION AND ME -C 1DIANS ARE: ') - -C WRITE(*,1024) DABS(checkbig) - -C1024 FORMAT(1X,G14.4,' <-- CONVERGENCE OCCURS WHEN THIS NO. < .01') - - - if(dabs(checkbig) .le. 0.01) then - -C CONVERGENCE HAS BEEN ACHIEVED. - - - go to 900 - - endif - - endif - -c above endif is for the if(resolve .le. .0001) condition. - - -C IF IMAXCYC = 1, THE MAX. NO. OF CYCLES HAVE ALREADY BEEN RUN --> -C GO TO 900. THE ONLY REASON THIS PART OF THE CODE WAS BEING RUN IS TO -C SEE IF CONVERGENCE WAS ACHIEVED IN THIS FINAL CYCLE, AND THAT WAS -C JUST TESTED ABOVE. - - IF(IMAXCYC .EQ. 1) GO TO 900 - - -cend control -cbegin expansion - - nactveold=nactve - - do ipoint=1,nactveold -c first, divide current probability into 2*nvar+1 pieces - pcur=corden(ipoint,nvar+1)/(2*nvar+1) -c update original point - corden(ipoint,nvar+1)=pcur - do ivar=1,nvar - del=(ab(ivar,2)-ab(ivar,1))*resolve -c create first new trial point at -eps in coordinate ivar - do i=1,nvar - corden(nactve+1,i)=corden(ipoint,i) - enddo - corden(nactve+1,ivar)=corden(nactve+1,ivar)-del - corden(nactve+1,nvar+1)=pcur - ntry=nactve+1 -c icheck that new point is at least minimally distant from old points - - call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) -c only keep trial lower point if it lies above lower bound and satisfies -c minimal distance requirement - if(corden(nactve+1,ivar).ge.ab(ivar,1)) then - if(iclose.eq.0) nactve=nactve+1 - endif -c now create second trail point at +eps in coordinate ivar - do i=1,nvar - corden(nactve+1,i)=corden(ipoint,i) - enddo - corden(nactve+1,ivar)=corden(nactve+1,ivar)+del - corden(nactve+1,nvar+1)=pcur -c only keep upper point if it lies below upper bound and -c satisfies distance requirement - ntry=nactve+1 - call checkd(corden,ntry,nactve,ab,maxgrd,nvar,iclose) - if(corden(nactve+1,ivar).le.ab(ivar,2)) then - if(iclose.eq.0) nactve=nactve+1 - endif - enddo -c above enddo for loop over ivar=1,nvar - - enddo -c above enddo for loop over ipoint=1,nactveold - - -cend expansion -c go to begin new cycle - - prefobj=fobj - - - - GO TO 1001 - - 900 continue - - -C??? NEW CODE BELOW FOR NPAGFULL1.FOR. - IF(MAXCYC .EQ. 0) THEN - -C NOTE THAT IF MAXCYC = 0, CONTROL HAS BEEN TRANSFERRED HERE AFTER -C LOOP 800 ABOVE. SO FINISH CALCULATING THE BAYESIAN POSTERIOR. - -C THE BAYESIAN POSTERIOR DENSITY OF THIS SUBJECT IS, FOR GRID PT. IG, - -C P(XIG|YJ) = P(YJ,XIG)/P(YJ). PUT THESE VALUES INTO CORDEN(IG,NVAR+1). - - DO IG=1,NACTVE - CORDEN(IG,NVAR+1) = WORK(IG)/PYJ - END DO - -C FOR NPAGFULL11.FOR, THE 1.D-10 BELOW IS CHANGED TO 1.D-100. - -C CALCULATE HOW MANY OF THE NACTVE GRID POINTS FROM THE FINAL CYCLE -C ARE "ACTIVE" (WITHIN 1.D-10 OF THE MAXIMUM DENSITY FOR THIS SUBJECT). -C ... AND, AS OF npageng23.f, ELIMINATE NON-SIGNIFICANT GRID PTS. IN -C CORDEN (PREVIOUSLY ALL THE POINT FROM THE FINAL CYCLE DENSITY -C SHOWED UP IN CORDEN, EVEN THOSE WITH INSIGNIFICANT PROBABILITIES). -C AND NOTE THAT THE BAYESIAN POSTERIOR DENSITY FOR THIS SUBJECT -C WILL BE STORED INTO BAYPOS(JSUB,.,.), AND PASSED IN COMMON/BAY -C TO SUBROUTINE READOUT. AND NACTSUB(JSUB) WILL CONTAIN THE NO. OF -C ACTIVE GRID POINTS FOR THIS SUBJECT'S BAYESIAN POSTERIOR DENSITY. - -C AND NOTE THAT THE NOMINAL DIMENSIONS OF BAYPOS, (800,1500,31), -C CANNOT BE EXCEEDED BECAUSE THESE ARE THE VALUES FOR MAXSUB, MAXGRD, -C AND MAXDIM+1, AS SPECIFIED IN THE PARAMETER STATEMENT IN THE PC PREP -C MAIN MODULE (CURRENTLY NPAG111.FOR). BUT NOTE THAT npageng23.f WILL -C NOT EXECTUTE WITH THESE DIMENSIONS BECAUSE IT IS TOO BIG FOR A -C WIN32 APPLICATION (SEE NPAG111.EXP). SO, IN THIS ROUTINE, AND IN -C SUBROUTINE READOUT (IN read19.f), THE FIRST DIMENSION HAS BEEN -C REDUCED TO 100 (AND SIMILARLY FOR THE DIMENSION OF NACTSUB). IF -C JSUB > 100, THE BAYESIAN POSTERIOR VALUES BELOW WILL NOT BE STORED. - - DENMAX=CORDEN(1,NVAR+1) - - DO I=1,NACTVE - D=CORDEN(I,NVAR+1) - IF(D .GT. DENMAX) DENMAX=D - END DO - - SUMD = 0.D0 - NEWIND = 0 - - DO I=1,NACTVE - D=CORDEN(I,NVAR+1) - IF(D .GT. 1.D-100*DENMAX) THEN - SUMD=SUMD+D - NEWIND=NEWIND+1 - DO J=1,NVAR - CORDEN(NEWIND,J) = CORDEN(I,J) - END DO - CORDEN(NEWIND,NVAR+1)=D - ENDIF - END DO - - NACTVE = NEWIND - - FACT = NGRID/VOLSPA/SUMD - - DO I=1,NACTVE - CORDEN(I,NVAR+1) = CORDEN(I,NVAR+1)*FACT - END DO - - - ENDIF -C THE ABOVE ENDIF IS FOR THE IF(MAXCYC .EQ. 0) CONDITION. - - - -C AS OF npageng18.f, CONTROL CAN BE TRANSFERRED TO LABEL 900 DIRECTLY -C AFTER RETURNING FROM A CALL TO SUBROUTINE emint. THIS HAPPENS WHEN -C IHESS = -1, WHICH MEANS THAT THE HESSIAN MATRIX IN THE INTERIOR -C POINT EM ALGORITHM WAS SINGULAR. RATHER THAN SIMPLY STOPPING AS IT -C DID PREVIOUSLY, NOW THE PROGRAM WILL CREATE THE OUTPUT FILES BEFORE -C STOPPING ... BASED ON THE VALUES FROM THE PREVIOUS CYCLE. -C FIRST, WRITE THE REASON FOR STOPPING AS ICONVERGE = 3 BELOW. THEN -C RESET CORDEN BACK TO CORDLAST (SEE ABOVE), WHICH WAS THE CORDEN -C AT THE END OF THE PREVIOUS CYCLE. -C FOR NPAGFULL, OF COURSE, NO WRITING OCCURS TO OUTPUT FILES. - - -C WRITE WHY THE PROGRAM STOPPED. - - IF(IHESS .EQ. -1) THEN - - NACTVE = NACTLAST - - DO I = 1,NACTVE - DO J = 1,NVAR+1 - CORDEN(I,J) = CORDLAST(I,J) - END DO - END DO - - GO TO 910 - - ENDIF - - -C Starting with bigmlt1.f, this is an entry point to continue -c calculations - - - 910 CONTINUE - -cbegin endgame -c we can only arrive here from the control section, which menas -c that we ahve completed optimizaiton but not done the subsequent -c expansion. This means that the density is correct, and we can safely -c just write it out and exit. - - WRITE(*,1294) ICYCLE,MAXCYC - 1294 FORMAT(/' NPAG RAN ',I6,' OUT OF A MAXIMUM POSSIBLE ',I6/ - 1' CYCLES TO OBTAIN THE POSTERIOR DENSITY.') - -C FOR NPAGFULL, THE DENSITY IS CORRECT AT THIS POINT. SO RETURN TO -C THE BESTDOSxxx PROGRAM. - -C AS OF NPAGFULLA11.FOR, CLOSE FILE 37. - - CLOSE(37) - - - - - RETURN - END - - -c shift9.f 9/28/12 - -c shift9 has the following subtle change from shift8: - -c In step 4, the logic to assign the bolus time, BOL(I,IND,1) is -c simplified in the case where a steady state dose set begins as a -c time reset event. In this case, the bolus time will be TAU(I) only -c if both TAU(I) and the bolus value (RR) are not 0. See the reason -c in the code. - -c----------------------------------------------------------------------- - -c shift8.f 9/20/12 - -c shift8 has changes from shift7 in Step 4 to correct the code in the -c case where bolus inputs are used in steady state dose sets. In -c shift7.f, a timelag for a bolus which was part of a steady state -c dose set would not be applied properly. Now it will. - -c----------------------------------------------------------------------- - -c shift7.f 11/6/11 - -c shift7 differs from shift6 as follows: - -c 1. The dimensions related to the no. of dose events are changed from -c 500 to 5000. This is needed as shift7 is compiled with idm1x7.f, -c idm2x7.f, and idm3x7.f (part of the npageng16.f "engine"), which -c accommodates steady state dose sets. - -c 2. 3 lines testing for IF(SIG(IDOSE) .EQ. 0 .AND. IDOSE .GT. 1) -c are replaced by IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) -c since now a dose reset occurs when a dose time is 0 (a regular -c time reset) or < 0 (a time reset occurring with a steady state -c dose set indicator). - -c----------------------------------------------------------------------- - -C SHIFT6.F 4/26/11 - -C SHIFT5 HAS THE FOLLOWING CHANGES TO SHIFT5: - -C WT AND CCR ARE NO LONGER ASSUMED TO BE SPECIAL COVARIATES IN EACH -C PATIENT'S WORKING COPY PATIENT DATA FILE. SO ALL DO LOOPS THAT -C START WITH DO I = 1, 2+NADD ARE CHANGED TO START WITH DO I = 1,NADD, -C BUT ONLY IF NADD .GT. 0. - -C----------------------------------------------------------------------- - -C SHIFT5.F 9/11/09 - -C SHIFT5 HAS THE FOLLOWING CHANGES TO SHIFT4.F. - - -C THE ARGUMENT LIST CONTAINS TAU(.) RATHER THAN NTLAG(.). THIS -C MEANS THAT TAU(I) IS INPUT DIRECTLY AS THE TIMELAG FOR DRUG I. -C I.E., IT NO LONGER HAS TO BE CALCULATED AS A FUNCTION OF THE -C PARAMETER ARRAY, P. BECAUSE OF THIS, P IS REMOVED FROM THE ARGUMENT -C LIST AND THE DIMENSION STATEMENT. ALSO, NTLAG IS REMOVED FROM -C THT DIMENSION STATEMENT. - -C THE FIRST SET OF ID MODULES TO CALL SHIFT5.F ARE idm1x3.f, -C idm2x3.f, AND idm3x3.f - -C----------------------------------------------------------------------- - -C SHIFT4.FOR 9/1/09 - -C SHIFT4 HAS THE FOLLOWING CHANGES FROM SHIFT3: - -C 1. NTLAG(I) CAN NOW BE NEGATIVE. IF THIS OCCURS, IT MEANS THAT THE -C TIMELAG PARAMETER FOR DRUG I WILL BE EXP(P(-NTLAG(I)). - -C 2. A BUG IS CORRECTED RELATED TO TIME "RESETS". PREVIOUSLY, IF THE -C USER HAD A TIME "RESET" IN HIS DOSAGE REGIMEN, THIS ROUTINE WOULD -C NOT WORK. THE REASON IS THAT IN THE CODE BELOW, EACH NEXT TIME -C FOR AN IV, COVARIATE, OR BOLUS IS COMPARED TO THE PREVIOUSLY -C ESTABLISHED TIME IN THE DOSAGE ARRAY (TIMNXT) AND IS A CANDIDATE -C TO BE THE NEXT TIMNXT IF IT IS .GE. TIMNXT. SO IF A TIME RESET -C VALUE OF 0 OCCURS, IT WILL NEVER BE A CANDIATE SINCE IT IS NOT -C .GE. THE LAST TIMNXT. TO FIX THIS, AND MAKE SURE THAT A TIME -C RESET VALUE OF 0 IS INCLUDED IN THE ADJUSTED DOSAGE BLOCK, THE -C CODE WILL ADD TO EACH IV, BOLUS, AND COVARIATE ARRAY AN EXTRA -C LINE WHEN A TIME RESET OCCURS. THIS LINE WILL HAVE A TIME OF -C 1.D19 (I.E., A LARGE VALUE WHICH REPRSENTS INFINITY); AND IT -C WILL BE FOLLOWED BY A LINE WITH THE ADJUSTED RESET TIME (0 FOR -C IVs AND COVARIATES, AND 0 + TAU(I) FOR BOLI. - -C----------------------------------------------------------------------- - -C SHIFT3.FOR 5-23-02 - -C SHIFT3 HAS MAJOR CHANGES FROM SHIFT2 TO ALLOW FOR MULTIPLE TIMELAGS, -C ONE POTENTIALLY FOR EACH BOLUS INPUT OF UP TO 7 DRUGS. - - SUBROUTINE SHIFT(TAU,ND,SIG,NDRUG,NADD,RS) - IMPLICIT REAL*8(A-H,O-Z) - DIMENSION SIG(5000),RS(5000,34),TAU(7),XIV(7,5000,2), - 1 BOL(7,5000,2),COV(20,5000,2),INDIV(7),INDBOL(7),INDCOV(20), - 2 TIMCAN(34) - -C INPUT ARE: - -C TAU(I) = THE VALUE OF THE TIMELAG FOR DRUG I. -C ND = ORIGINAL NO. OF DOSE EVENTS. -C SIG(I) = TIME FOR ITH DOSE EVENT IN THE ORIGINAL DOSAGE REGIMEN, -C I=1,ND. -C NDRUG = NO. OF DRUGS (EACH HAS AN IV, FOLLOWED BY A BOLUS COLUMN). -C NADD = NO. OF ADDITIONAL COVARIATES (EACH IS IN ITS OWN COLUMN -C FOLLOWING THE IV/BOLUS COLUMNS. -C RS(I,J) = "RATE" J FOR THE ITH DOSE EVENT IN THE ORIGINAL DOSAGE -C REGIMEN; J=1,NI, I=1,ND, WHERE NI = 2*NDRUG + NADD -C BECAUSE THE "RATES" CONTAIN, IN ORDER, 2 ENTRIES FOR -C EACH DRUG (1 FOR THE IV AND 1 FOR THE BOLUS) AND 1 EACH -C FOR THE NADD ADDITIONAL COVARIATES. - - -C OUTPUT ARE: - -C ND, SIG, RS, AS ABOVE, EXCEPT FOR THE ALTERED DOSAGE REGIMEN. - -C----------------------------------------------------------------------- - -C SHIFT2.FOR 11-16-99 - -C SHIFT2 HAS THE FOLLOWING CHANGE FROM SHIFT. AT THE END OF THE -C FORMATION OF ARRAY XMAT, ALL ROWS WHICH HAVE 0 BOLUS INPUT AND THE -C SAME OTHER DATA VALUES (EXCEPT TIME) AS THE PREVIOUS ROW ARE NOT -C USED IN THE NEW ARRAY XMAT2 WHICH HAS ONLY NON-REDUNDANT ROWS. -C THIS, THEORETICALLY, SHOULDN'T HAVE ANY EFFECT ON CALCULATIONS, BUT -C NUMERICALLY IT DOES SINCE WHEN THE DVODE ROUTINE SOLVES D.E.'S, IT -C INTEGRATES OVER DIFFERENT INTERVALS IF EXTRA DOSAGE LINES ARE -C INCLUDED. - -C EX: TIME IV BOLUS TIME IV BOLUS -C 0 100 0 0 100 0 -C 5 100 1000 2 100 1000 - -C NOTE THAT BOTH ABOVE CASES SHOULD GIVE THE SAME RESULTS IF THERE IS -C A TIME-LAG = 3 IN THE 2ND CASE. BUT, AS THE CODE IS WRITTEN IN -C SHIFT.FOR, THE 2ND CASE WOULD TRANSLATE TO THE FOLLOWING: - -C TIME IV BOLUS -C 0 100 0 -C 2 100 0 -C 5 100 1000 - -C ... AND THIS WOULD MEAN THAT THE 1ST INTEGRATION BY DVODE WOULD END -C AT T = 2, RATHER THAN 5 (OR, E.G., 3 IF 3 WAS THE -C FIRST OBSERVATION TIME). THIS CREATES NUMERICAL DIFFERENCES DUE -C TO SMALL ROUNDOFF ERRORS WHICH CAN GROW SIGNIFICANTLY. - -C----------------------------------------------------------------------- - -C SHIFT.FOR 7-27-99 - -C SHIFT.FOR IS A MODULE WHICH INCLUDES SUBROUTINE SHIFT. SHIFT WILL BE -C CALLED BY ROUTINES OF THE "BIG" NPEM AND IT2B PROGRAMS WHICH HAVE -C SUBROUTINES FUNC, FUNC1, FUNC2, OR FUNC3 IN THEM. - -C SHIFT INPUTS THE DOSAGE REGIMEN VIA THE INPUT ARGUMENTS (SEE BELOW), -C AND RETURNS AN ALTERED DOSAGE REGIMEN, WHICH HAS EACH BOLUS INPUT -C TIME INCREASED BY THE INPUT VALUE OF TAU (THE TIME LAG). NOTE THAT -C EACH ROW WITH A NON-0 BOLUS INPUT VALUE WILL RESULT IN A NEW ROW IN -C THE DOSAGE REGIMEN. - -C----------------------------------------------------------------------- - -C PROCEDURE FOR THE DOSAGE REGIMEN MODIFICATION: - -C 1. ESTABLISH TAU(I) AS THE TIMELAG FOR DRUG I'S BOLUS COLUMN. -C NO. AS OF SHIFT5.F, THIS VALUE IS INPUT AS AN ARGUMENT. - -C 2. ESTABLISH THE IV VALUES AND TIMES INTO XIV(I,J,K). IN PARTICULAR, -C XIV(I,J,2) IS THE JTH IV VALUE FOR DRUG I, AND XIV(I,J,1) IS THE -C TIME THIS IV VALUE FIRST OCCURRED. SET THE LAST TIME TO 1.D29 AS -C AN INDICATOR THAT THERE ARE NO MORE ENTRIES IN THE ARRAY. - -C 3. ESTABLISH THE COVARIATE VALUES AND TIMES INTO COV(I,J,K). IN -C PARTICULAR, COV(I,J,2) IS THE JTH VALUE FOR COVARIATE I, AND -C COV(I,J,1) IS THE TIME THIS COV VALUE FIRST OCCURRED. SET THE -C LAST TIME TO 1.D29 AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES -C IN THE ARRAY. - -C 4. ESTABLISH THE BOLUS VALUES AND TIMES INTO BOL(I,J,K). -C IN PARTICULAR, BOL(I,J,2) IS THE JTH BOLUS VALUE FOR DRUG I, AND -C BOL(I,J,1) IS THE TIME THIS BOLUS OCCURRED. THE TIMES FOR EACH -C BOLUS VALUE ARE THOSE ADJUSTED TIMES FROM THE ASSOCIATED TIMELAGS -C TAU(I),I=1,NDRUG, FROM STEP 1. SET THE LAST TIME TO 1.D29 AS AN -C INDICATOR THAT THERE ARE NO MORE ENTRIES IN THE ARRAY. - -C 5. REASSIGN THE VALUES IN IV, BOL, AND COV TO THE APPROPRIATE ENTRIES -C OF RS, KEEPING TRACK OF THE RUNNING INDEX, ND, OF DOSE EVENTS. IF -C ND EXCEEDS 5000, STOP THE PROGRAM WITH A MESSAGE TO THE USER. ALSO -C REASSIGN THE CORRESPONDING TIME VALUES TO ARRAY SIG. - - -C STEP 1. - -C NOTHING TO DO. AS OF SHIFT5.F, TAU(I), I=1,NDRUG, IS INPUT AS -C AN ARGUMENT TO THIS ROUTINE. - - -C STEP 2: - -C ESTABLISH THE IV VALUES AND TIMES INTO XIV(I,J,K). IN PARTICULAR, -C XIV(I,J,2) IS THE JTH IV VALUE FOR DRUG I, AND XIV(I,J,1) IS THE -C TIME THIS IV VALUE FIRST OCCURRED. - - DO I = 1,NDRUG - -C ESTABLISH XIV(I,J,K) FOR DRUG I'S IV. PRESET THE LAST VALUE TO -C -99 SO THAT THE FIRST VALUE WILL BE DIFFERENT AND THEREFORE ENGAGE -C THE LOGIC (WHICH ONLY WRITES A ROW INTO THE ARRAY IF THE VALUE IS -C DIFFERENT THAN THE PREVIOUS VALUE). - -C*** MODIFICATION IN SHIFT4.F: IF A TIME RESET OCCURS (I.E., A -C SIG(IDOSE) = 0, WHERE IDOSE > 1), IT WILL BE HANDLED BY ASSIGNING -C AN EXTRA TIME VALUE OF 1.D19 (I.E., A LARGE VALUE REPRESENTING -C TIME = INFINITY) TO THE IV TIME ARRAY. THEN THE REST OF THE -C THE IV TIME ARRAY WILL BE ESTABLISHED WITH THE REST OF THE VALUES -C IN SIG, STARTING, OF COURSE, WITH THE TIME RESET VALUE OF 0. - -C THE SAME LOGIC WILL APPLY TO THE COVARIATES AND THE BOLI. - -C NOTE THAT IND WILL BE THE RUNNING INDEX OF THE LATEST ENTRY INTO -C THE ARRAY. PLACE 1.D29 INTO THE LAST TIME ENTRY OF EACH SUB-ARRAY -C AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES. - - XIV(I,1,1) = 1.D29 - IND = 0 - VALAST = -99.D0 - -C FOR DRUG I, THE IV VALUE IS IN COLUMN 2*I-1 OF ARRAY RS. - - DO IDOSE = 1,ND - - RR = RS(IDOSE,2*I-1) - -C*** MODIFICATION IN SHIFT7.F: A TIME RESET IS NOW DESIGNATED BY A -C SIG(IDOSE) .LE. 0, RATHER THAN JUST .EQ. 0 (SINCE A STEADY STATE -C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). - - IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) THEN - -C THIS REPRESENTS A TIME "RESET". IN THIS CASE, AS INDICATED ABOVE, -C PUT IN AN EXTRA ROW FOR THE IV REPRESENTING A VERY LARGE TIME -C AND THE SAME IV VALUE AS THE PREVIOUS VALUE. THEN PUT IN THE -C LINE REPRESENTING THE RESET TIME OF 0. - - IND = IND + 1 - XIV(I,IND,1) = 1.D19 - XIV(I,IND,2) = XIV(I,IND-1,2) - - IND = IND + 1 - -C*** MODIFICATION IN SHIFT7.F. SET THE NEXT XIV(I,IND,1) TO BE -C SIG(IDOSE), NOT 0, SINCE SIG(IDOSE) MAY BE < 0 (SINCE A STEADY STATE -C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). - - XIV(I,IND,1) = SIG(IDOSE) - XIV(I,IND,2) = RR - XIV(I,IND+1,1) = 1.D29 - VALAST = RR - - GO TO 200 - - ENDIF - -C TO GET HERE, THIS DOSE LINE DOES NOT REPRESENT A TIME RESET. - - IF(RR .NE. VALAST) THEN - IND = IND + 1 - XIV(I,IND,1) = SIG(IDOSE) - XIV(I,IND,2) = RR - XIV(I,IND+1,1) = 1.D29 - VALAST = RR - ENDIF - - 200 CONTINUE - - END DO - -C THE ABOVE END DO IS FOR THE DO IDOSE = 1,ND LOOP. - - - END DO - -C THE ABOVE END DO IS FOR THE DO I = 1,NDRUG LOOP. - - -C STEP 3: - -C ESTABLISH THE COVARIATE VALUES AND TIMES INTO COV(I,J,K). IN -C PARTICULAR, COV(I,J,2) IS THE JTH VALUE FOR COVARIATE I, AND -C COV(I,J,1) IS THE TIME THIS COV VALUE FIRST OCCURRED. SET THE -C LAST TIME TO 1.D29 AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES -C IN THE ARRAY. - - IF(NADD .GT. 0) THEN - - DO I = 1, NADD - -C ESTABLISH COV(I,J,K) FOR COVARIATE NO. I. -C PRESET THE LAST VALUE TO -99 SO THAT THE FIRST VALUE WILL BE -C DIFFERENT AND THEREFORE ENGAGE THE LOGIC (WHICH ONLY WRITES A ROW -C INTO THE ARRAY IF THE VALUE IS DIFFERENT THAN THE PREVIOUS VALUE). -C NOTE THAT IND WILL BE THE RUNNING INDEX OF THE LATEST ENTRY INTO THE -C ARRAY. PLACE 1.D29 INTO THE LAST TIME ENTRY OF EACH SUB-ARRAY AS AN -C INDICATOR THAT THERE ARE NO MORE ENTRIES. - - COV(I,1,1) = 1.D29 - IND = 0 - VALAST = -99.D0 - -C FOR COVARIATE I, THE VALUE IS IN COLUMN 2*NDRUG+I OF ARRAY RS. - - DO IDOSE = 1,ND - - RR = RS(IDOSE,2*NDRUG+I) - -C*** MODIFICATION IN SHIFT7.F: A TIME RESET IS NOW DESIGNATED BY A -C SIG(IDOSE) .LE. 0, RATHER THAN JUST .EQ. 0 (SINCE A STEADY STATE -C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). - - IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) THEN - -C THIS REPRESENTS A TIME "RESET". IN THIS CASE, AS INDICATED ABOVE, -C PUT IN AN EXTRA ROW FOR THE COVARIATE REPRESENTING A VERY LARGE TIME -C AND THE SAME COV VALUE AS THE PREVIOUS VALUE. THEN PUT IN THE -C LINE REPRESENTING THE RESET TIME OF 0. - - IND = IND + 1 - COV(I,IND,1) = 1.D19 - COV(I,IND,2) = COV(I,IND-1,2) - - IND = IND + 1 - -C*** MODIFICATION IN SHIFT7.F. SET THE NEXT COV(I,IND,1) TO BE -C SIG(IDOSE), NOT 0, SINCE SIG(IDOSE) MAY BE < 0 (SINCE A STEADY STATE -C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). - - COV(I,IND,1) = SIG(IDOSE) - COV(I,IND,2) = RR - COV(I,IND+1,1) = 1.D29 - VALAST = RR - - GO TO 300 - - ENDIF - -C TO GET HERE, THIS DOSE LINE DOES NOT REPRESENT A TIME RESET. - - IF(RR .NE. VALAST) THEN - IND = IND + 1 - COV(I,IND,1) = SIG(IDOSE) - COV(I,IND,2) = RR - COV(I,IND+1,1) = 1.D29 - VALAST = RR - ENDIF - - 300 CONTINUE - - END DO - -C THE ABOVE END DO IS FOR THE DO IDOSE = 1,ND LOOP. - - END DO - -C THE ABOVE END DO IS FOR THE DO I = 1, NADD LOOP. - - ENDIF - -C THE ABOVE ENDIF IS FOR THE IF(NADD .GT. 0) CONDITION. - - - -C STEP 4: - -C ESTABLISH THE BOLUS VALUES AND TIMES INTO BOL(I,J,K). IN PARTICULAR, -C BOL(I,J,2) IS THE JTH BOLUS VALUE FOR DRUG I, AND BOL(I,J,1) IS THE -C ADJUSTED (USING THE ASSOCIATED TIMELAGS TAU(I),I=1,NDRUG) TIME THIS -C BOLUS OCCURRED. - - DO I = 1,NDRUG - -C ESTABLISH BOL(I,J,K) FOR DRUG I'S BOLUS. EACH ARRAY IS FILLED ONLY -C WITH NON-0 BOLUS VALUES. NOTE THAT IND WILL BE THE RUNNING INDEX OF -C THE LATEST ENTRY INTO THE ARRAY. PLACE 1.D29 INTO THE LAST TIME ENTRY -C OF EACH SUB-ARRAY AS AN INDICATOR THAT THERE ARE NO MORE ENTRIES. - - BOL(I,1,1) = 1.D29 - IND = 0 - -C FOR DRUG I, THE BOLUS VALUE IS IN COLUMN 2*I OF ARRAY RS. - - DO IDOSE = 1,ND - - RR = RS(IDOSE,2*I) - -C*** MODIFICATION IN SHIFT7.F: A TIME RESET IS NOW DESIGNATED BY A -C SIG(IDOSE) .LE. 0, RATHER THAN JUST .EQ. 0 (SINCE A STEADY STATE -C DOSE INDICATOR HAS A NEGATIVE DOSE TIME). - - IF(SIG(IDOSE) .LE. 0 .AND. IDOSE .GT. 1) THEN - -C THIS REPRESENTS A TIME "RESET". IN THIS CASE, AS INDICATED ABOVE, -C PUT IN AN EXTRA ROW FOR THE BOLUS REPRESENTING A VERY LARGE TIME -C AND AN ACCOMPANYING BOLUS VALUE OF 0. THEN PUT IN THE -C LINE REPRESENTING THE RESET TIME OF 0 + THE TIMELAG ... IF -C RR .NE. 0. - - IND = IND + 1 - BOL(I,IND,1) = 1.D19 - BOL(I,IND,2) = 0.D0 - - IND = IND + 1 - - -C*** THE FOLLOWING CODE IS CHANGED IN SHIFT8.F. NOW BOLUS VALUES -C WORK PROPERLY EVEN WITH TIMELAGS. AND AN ADDITIONAL SUBTLE CHANGE -C WAS ADDED IN shift9.f (SEE THE COMMENTS AT THE TOP OF shift9.f), -C AND THE EXTRA COMMENTS BELOW. - - -C LOGIC IS NOW AS FOLLOWS: - -C IF SIG(IDOSE) = 0, THIS IS A TIME RESET WHICH IS NOT THE START OF -C A STEADY STATE DOSE SET. IN THIS CASE, A BOLUS WITH A TIMELAG OF -C TAU(I) WILL OCCUR AT SIG(IDOSE) + TAU(I) = TAU(I). - -C IF SIG(IDOSE) < 0, THIS IS A TIME RESET WHICH IS THE START OF A -C STEADY STATE DOSE SET. IN THIS CASE: -C THE BOLUS TIME WILL BE TAU(I) ONLY IF BOTH TAU(I) AND RR -C ARE NOT 0. OTHERWISE, IT WILL BE SIG(IDOSE). -C REASON: IF RR = 0, THERE IS NO BOLUS TO BE GIVEN, SO IT WOULD -C BE SILLY TO INCLUDE AN EXTRA LINE IN THE DOSAGE REGIMEN WITH -C A 0 BOLUS (AND IT WOULD VERY SLIGHTLY CHANGE THE RESULTS SINCE -C THE NUMERICAL INTEGRATION THEN HAS TO INTEGRATE THROUGH AN EXTRA -C TIME). IN AN EXAMPLE (REMARK 4.b IN NPAG109.EXP, THIS CHANGED THE -C VALUES IN THE LOG-LIKELIHOODS OUT IN THE 13TH DIGIT, BUT SOME -C VALUES IN THE DENSITY FILE WERE CHANGED IN THE 4TH DIGIT). - -C ALSO, IF TAU(I) = 0, THE BOLUS HAS NO TIMELAG AND THEREFORE -C OCCURS AT SIG(IDOSE). - -C THE FOLLOWING EXAMPLE SHOWS WHY A NON-0 BOLUS IN A STEADY STATE DOSE -C SET, WITH TAU(I) .NE. 0, MUST BE GIVEN AT TAU(I) AND NOT -C SIG(IDOSE) + TAU(I). - -C EX: IF SIG(IDOSE) = -12, IT MEANS THAT A STEADY STATE DOSE SET IS -C STARTING WITH AN INTERDOSE INTERVAL OF 12 HOURS. SO, IF A -C BOLUS WITH A TLAG OF 1.5 HOURS IS GIVEN, ITS TIME MUST BE -C 1.5, NOT -12 + 1.5 = -10.5. REASON: AFTER THE SIG(IDOSE) OF -C -12 IS CONVERTED IN SUBROUTINE FUNC2 TO 0, THE 1.5 WILL CORRECTLY -C INDICATE THAT THE BOLUS IS GIVEN 1.5 HOURS AFTER THE START OF THE -C STEADY STATE DOSE SET. ALSO, A TIME OF -10.5 WOULD COMPLETELY -C SCREW UP THE FUNC2 LOGIC WHICH WOULD INTERPRET IT AS THE START -C OF ANOTHER STEADY STATE DOSE SEST. - -C ON THE OTHER HAND, IF A DRUG HAS A TAU(I) = 0, IT CANNOT SHOW -C UP AS OCCURRING AT TAU(I) = 0 SINCE THIS WILL COMPLETELY SCREW -C UP FUNC2'S LOGIC, WHICH WILL INTERPRET THE TIME OF 0 AS A -C TIME RESET EVENT. IN THIS CASE, THE BOLUS OCCURS AT THE START OF -C THE STEADY STATE DOSE SET, I.E., AT SIG(IDOSE) = -12, WHICH WILL -C BE CONVERTED TO 0 BY FUNC2). - - - CALL THESAME(SIG(IDOSE),0.D0,ISAME1) - CALL THESAME(TAU(I),0.D0,ISAME2) - CALL THESAME(RR,0.D0,ISAME3) - - IF(ISAME1 .EQ. 1) BOL(I,IND,1) = TAU(I) -C NOTE THAT, TECHNICALLY, WE SHOULD SET BOL(I,IND,1) = SIG(IDOSE) = 0 -C IF RR = 0, SINCE THERE IS NO REASON TO HAVE AN EXTRA LINE IN THE -C DOSAGE REGIMEN FOR A 0 BOLUS ... BUT CHANGING THIS WOULD CHANGE -C VERY SLIGHTLY THE RESULTS IN A 0 BOLUS CASE SINCE THERE WOULD BE ONE -C LESS DOSAGE LINE FOR THE NUMERICAL INTEGRATOR TO INTEGRATE THROUGH, -C SO THE CODE WILL BE LEFT AS IS, FOR CONSISTENCY SAKE. - - - IF(ISAME1 .EQ. 0) THEN - BOL(I,IND,1) = SIG(IDOSE) - IF(ISAME2 .EQ. 0 .AND. ISAME3 .EQ. 0) BOL(I,IND,1) = TAU(I) - ENDIF - - - - BOL(I,IND,2) = RR - BOL(I,IND+1,1) = 1.D29 - VALAST = RR - - GO TO 400 - - ENDIF - -C TO GET HERE, THIS DOSE LINE DOES NOT REPRESENT A TIME RESET. - - - IF(RR .NE. 0.D0) THEN - - IND = IND + 1 - -C *** CHANGE FOR SHIFT8.F. -C NOW BOLUS VALUES CAN OCCUR IN STEADY STATE DOSES. AND IF THEY DO, -C THE FIRST ONE MUST OCCUR AT TIME TAU(I), NOT SIG(IDOSE) + TAU(I) -C AS THE FOLLOWING EXAMPLE ILLUSTRATES: -C EX: SIG(1) = -12 INDICATING THAT THE STEADY STATE DOSE SET HAS -C AN INTERDOSE INTERVAL OF 12 HOURS. TAU(1) = 1.5 --> -C DRUG 1 HAS A TIMELAG OF 1.5 HOURS. SO, IF THE FIRST BOLUS TIME IS -C SET = SIG(1) + TAU(1) = -12 + 1.5 = -10.5, THIS WILL SCREW -C UP THE FUNC2 LOGIC SINCE IN THAT CODE, THE FIRST TIME OF -C -12 WILL BE RESET TO BE 0, AND THIS WILL BE FOLLOWED BY -10.5, -C WHICH WILL LOOK LIKE THE START OF ANOTHER STEADY STATE DOSE -C SET. INSTEAD, SET FIRST BOLUS TIME = TAU(1) = 1.5, WHICH IS -C CORRECT SINCE IT OCCURS 1.5 HOURS AFTER THE STEADY STATE DOSE -C STARTS. - - IF(SIG(IDOSE) .GE. 0.D0) BOL(I,IND,1) = SIG(IDOSE) + TAU(I) - IF(SIG(IDOSE) .LT. 0.D0) BOL(I,IND,1) = TAU(I) - - BOL(I,IND,2) = RR - BOL(I,IND+1,1) = 1.D29 - ENDIF - - 400 CONTINUE - - END DO - -C THE ABOVE END DO IS FOR THE DO IDOSE = 1,ND LOOP. - - - END DO - - -C THE ABOVE END DO IS FOR THE DO I = 1,NDRUG LOOP. - - - -C STEP 5: - -C REASSIGN THE VALUES IN IV, BOL, AND COV TO THE APPROPRIATE ENTRIES -C OF RS, KEEPING TRACK OF THE RUNNING INDEX, ND, OF DOSE EVENTS. IF -C ND EXCEEDS 5000, STOP THE PROGRAM WITH A MESSAGE TO THE USER. ALSO, -C REASSIGN THE CORRESPONDING TIME VALUES TO ARRAY SIG. - - NI = 2*NDRUG + NADD - ND = 0 - -C GO THROUGH THE ARRAYS IV, BOL, AND COV TO DETERMINE THE NEXT -C LOWEST DOSE TIME. PUT THIS VALUE INTO RS, ALONG WITH THE -C CORRESPONDING VALUES FOR THE IV'S, THE BOLI, AND THE COVARIATES. - -C IN THE LOOP BELOW, IT IS NECESSARY TO KNOW TO WHAT POINT IN THE -C IV, BOL, AND COV ARRAYS THE TIMES AND VALUES HAVE ALREADY BEEN -C STORED INTO RS. THESE INDICES ARE INDIV(I), I=1,NDRUG; INDBOL(I), -C I=1,NDRUG; AND INDCOV(I), I=1,NADD, RESPECTIVELY. E.G., -C INDIV(2) = 4 MEANS THAT ALL VALUES IN THE IV, BOL, AND COV ARRAYS, -C THROUGH THE 4TH TIME FOR IV DRUG 2 (I.E., THROUGH TIME = XIV(2,4,1)) -C HAVE BEEN OR ARE ABOUT TO BE STORED INTO THE RS ARRAY. - -C SO PRESET ALL THESE INDEX INDICATORS = 1, AND INITIALIZE THE -C CURRENT DOSE TIME TO A NEGATIVE NO. SO THAT THE FIRST TIME -C THROUGH THE FOLLOWING LOOP WILL ENGAGE THE LOGIC. - - DO I = 1,NDRUG - INDIV(I) = 1 - INDBOL(I) = 1 - END DO - - IF(NADD .GT. 0) THEN - DO I = 1,NADD - INDCOV(I) = 1 - END DO - ENDIF - - TIMNXT = -9999999.D0 - - - 100 CONTINUE - -C FIND THE NEXT LOWEST TIME AMONG THE IV, BOL, AND COV ARRAYS. - -C ESTABLISH INTO TIMCAN(J) THE CANDIDATES FOR THE NEXT DOSE TIME -C (AND CORRESPONDING VALUES FOR THE IV'S, BOLI, AND COVARIATES) TO -C BE PUT INTO RS. - - - DO I = 1,NDRUG - IF(XIV(I,INDIV(I),1) .GT. TIMNXT) TIMCAN(I)=XIV(I,INDIV(I),1) - IF(XIV(I,INDIV(I),1) .EQ. TIMNXT) TIMCAN(I)=XIV(I,INDIV(I)+1,1) - END DO - - DO I = 1,NDRUG - IF(BOL(I,INDBOL(I),1) .GT. TIMNXT) TIMCAN(NDRUG+I) = - 1 BOL(I,INDBOL(I),1) - IF(BOL(I,INDBOL(I),1) .EQ. TIMNXT) TIMCAN(NDRUG+I) = - 1 BOL(I,INDBOL(I)+1,1) - END DO - - - IF(NADD .GT. 0) THEN - DO I = 1,NADD - IF(COV(I,INDCOV(I),1) .GT. TIMNXT) TIMCAN(2*NDRUG+I) = - 1 COV(I,INDCOV(I),1) - IF(COV(I,INDCOV(I),1) .EQ. TIMNXT) TIMCAN(2*NDRUG+I) = - 1 COV(I,INDCOV(I)+1,1) - END DO - ENDIF - -C FIND THE NEXT TIMNXT, THE MINIMUM VALUE AMONG THE NI ENTRIES IN -C TIMCAN. TIMNXT WILL BE THE NEXT TIME TO BE PUT INTO ARRAY RS (ALONG -C WITH ALL THE CORRESPONDING IV'S, BOLI, AND COVARIATE VALUES). IF -C TIMNXT = 1.D29, IT IS BECAUSE THERE ARE NO FURTHER VALUES TO BE PUT -C INTO RS (I.E, THE PROCESS IS FINISHED). - - TIMNXT = TIMCAN(1) - DO I = 2,NI - IF(TIMCAN(I) .LT. TIMNXT) TIMNXT = TIMCAN(I) - END DO - - IF(TIMNXT .EQ. 1.D29) RETURN - -C SINCE TIMNXT < 1.D29, THERE ARE MORE VALUES TO BE PUT INTO RS. -C GO THROUGH ALL THE SUBARRAYS AND PUT IN VALUES AS FOLLOWS. IF THE -C CURRENT TIME FOR AN IV, BOLUS, OR COVARIATE IS THE SAME AS TIMNXT, -C PUT THE CORRESPONDING IV, BOLUS, OR COVARIATE VALUE INTO RS, AND -C INCREASE THE INDEX FOR THAT SUB-ARRAY TO THE NEXT VALUE. IF THE -C CURRENT TIME FOR AN IV OR A COVARIATE IS .GT. TIMNXT, PUT THE IV OR -C COVARIATE VALUE FROM THE PREVIOUS ROW INTO RS, AND LEAVE THE INDEX -C UNCHANGED. IF THE CURRENT TIME FOR A BOLUS IS .GT. TIMNXT, PUT 0.0 -C INTO RS (I.E., BOLUS VALUES ARE INSTANTANEOUS, WHEREAS IV AND -C COVARIATE VALUES CONTINUE UNTIL CHANGED), AND LEAVE THE INDEX -C UNCHANGED. - - -C TEST FOR TIMNXT = 1.D19, WHICH INDICATES A TIME RESET. - - IF(TIMNXT .EQ. 1.D19) THEN - -C TIMNXT = 1.D19 MEANS THAT THE NEXT TIME IN EACH ARRAY IS THE -C TIME AT OR AFTER THE RESET. SO INCRASE ALL THE ARRAY INDICES BY -C 1, RESET TIMNXT TO A NEGATIVE NO. AND RETURN TO LABEL 100. - - DO I = 1,NDRUG - INDIV(I) = INDIV(I) + 1 - INDBOL(I) = INDBOL(I) + 1 - END DO - - - IF(NADD .GT. 0) THEN - DO I = 1,NADD - INDCOV(I) = INDCOV(I) + 1 - END DO - ENDIF - - TIMNXT = -9999999.D0 - - GO TO 100 - - ENDIF - - - ND = ND+1 - - IF(ND .GT. 5000) THEN - -C IF ND > 5000, STOP WITH A MESSAGE TO THE USER THAT THE -C PROGRAM ONLY ALLOWS A TOTAL OF 5000 DOSE EVENTS. - - 10 WRITE(*,1) ND - 1 FORMAT(/' THE NUMBER OF DOSE EVENTS, AFTER TAKING INTO'/ - 1' ACCOUNT DIFFERING TIMES DUE TO TIMELAGS IS ',I6,', MORE THAN'/ - 2' THE ALLOWABLE MAXIMUM OF 5000. THE PROGRAM IS STOPPING. PLEASE'/ - 3' RERUN WITH PATIENTS HAVING FEWER DOSE EVENTS, OR WITH FEWER'/ - 4' TIMELAG VALUES SELECTED AS FIXED OR RANDOM PARAMETERS.'//) - STOP - - ENDIF - -C ND .LE. 5000, SO CONTINUE. FOR THIS DOSE EVENT, PUT IN THE CURRENT -C TIME, AND THE CORRESPONDING IV, BOLUS, AND COVARIATE VALUES. - - - SIG(ND) = TIMNXT - - DO I = 1,NDRUG - - IF(TIMNXT .LT. XIV(I,INDIV(I),1)) THEN - RS(ND,2*I-1) = RS(ND-1,2*I-1) - ENDIF - - IF(TIMNXT .EQ. XIV(I,INDIV(I),1)) THEN - RS(ND,2*I-1) = XIV(I,INDIV(I),2) - INDIV(I) = INDIV(I) + 1 - ENDIF - - IF(TIMNXT .LT. BOL(I,INDBOL(I),1)) THEN - RS(ND,2*I) = 0.D0 - ENDIF - - IF(TIMNXT .EQ. BOL(I,INDBOL(I),1)) THEN - RS(ND,2*I) = BOL(I,INDBOL(I),2) - INDBOL(I) = INDBOL(I) + 1 - ENDIF - - END DO - - - IF(NADD .GT. 0) THEN - DO I = 1,NADD - IF(TIMNXT .LT. COV(I,INDCOV(I),1)) - 1 RS(ND,2*NDRUG+I) = RS(ND-1,2*NDRUG+I) - IF(TIMNXT .EQ. COV(I,INDCOV(I),1)) THEN - RS(ND,2*NDRUG+I) = COV(I,INDCOV(I),2) - INDCOV(I) = INDCOV(I) + 1 - ENDIF - END DO - ENDIF - - - GO TO 100 - - - END - - From 96eb6c74ba75eec1b5ca7ca913db3c9c54a1a316 Mon Sep 17 00:00:00 2001 From: Romain Garreau Date: Wed, 20 May 2026 22:14:38 +0200 Subject: [PATCH 3/4] fix : implement direct bayes weight update - remove burke and implement direct bayes weight update - update bimodal_ke example --- examples/bestdose.rs | 35 ++++++++++++++++++- src/bestdose/cost.rs | 2 +- src/bestdose/posterior.rs | 72 +++++++++++++++++++++++++++++++++++---- 3 files changed, 101 insertions(+), 8 deletions(-) diff --git a/examples/bestdose.rs b/examples/bestdose.rs index 34ff95364..7d8ebf96c 100644 --- a/examples/bestdose.rs +++ b/examples/bestdose.rs @@ -73,7 +73,7 @@ fn main() -> Result<()> { .build(); let (theta, prior) = parse_prior( - &"examples/bimodal_ke/output/theta.csv".to_string(), + &"examples/bimodal_ke/prior.csv".to_string(), &settings, ) .unwrap(); @@ -131,5 +131,38 @@ fn main() -> Result<()> { ); } + // Print the posterior support points with their filtered population and posterior weights. + let posterior_theta = problem.posterior_theta(); + let posterior_weights = problem.posterior_weights(); + let population_weights = problem.population_weights(); + let param_names = posterior_theta.param_names(); + + println!("\n=== Support Points Summary ==="); + println!("Number of support points: {}", posterior_theta.nspp()); + + print!("\n{:<8} {:<15} {:<15}", "Point", "Prior Weight", "Posterior Weight"); + for name in ¶m_names { + print!(" {:<15}", name); + } + println!(); + println!("{}", "-".repeat(40 + 16 * param_names.len())); + + for point_idx in 0..posterior_theta.nspp() { + let row = posterior_theta.matrix().row(point_idx); + + print!( + "{:<8} {:<15.6e} {:<15.6e}", + point_idx, + population_weights[point_idx], + posterior_weights[point_idx] + ); + + for value in row.iter() { + print!(" {:<15.6}", value); + } + + println!(); + } + Ok(()) } diff --git a/src/bestdose/cost.rs b/src/bestdose/cost.rs index 1b0b0ea95..9c78cea08 100644 --- a/src/bestdose/cost.rs +++ b/src/bestdose/cost.rs @@ -233,7 +233,7 @@ pub fn calculate_cost(problem: &BestDoseProblem, candidate_doses: &[f64]) -> Res // Calculate variance (using posterior weights) and population mean (using prior weights) - for ((row, post_prob), prior_prob) in problem + for ((row, post_prob), _prior_prob) in problem .theta .matrix() .row_iter() diff --git a/src/bestdose/posterior.rs b/src/bestdose/posterior.rs index 9506d390e..cc9440bf8 100644 --- a/src/bestdose/posterior.rs +++ b/src/bestdose/posterior.rs @@ -53,7 +53,6 @@ use anyhow::Result; use faer::Mat; -use crate::algorithms::npag::burke; use crate::algorithms::npag::NPAG; use crate::algorithms::Algorithms; use crate::algorithms::Status; @@ -86,7 +85,8 @@ const KEEP_UNREFINED_POINTS: bool = true; /// 2. Apply Bayes' rule to get P(θᵢ|data) /// 3. Filter: Keep points where P(θᵢ|data) > 1e-100 × max_weight /// -/// Note: This uses only lambda filtering, NO QR decomposition or second burke call. +/// Note: This uses only direct Bayesian filtering, with no QR decomposition or +/// NPAG weight optimization. /// /// Returns: (filtered_theta, filtered_posterior_weights, filtered_population_weights) pub fn npagfull11_filter( @@ -101,21 +101,81 @@ pub fn npagfull11_filter( // Calculate psi matrix P(data|theta_i) for all support points let psi = calculate_psi(eq, past_data, population_theta, error_models, false)?; - // First burke call to get initial posterior probabilities - let (initial_weights, _) = burke(&psi)?; + // NPAGFULL11 does a direct Bayes update on the incoming prior density: + // posterior_j ∝ prior_j * product_i P(data_i | theta_j). + // It does not run the NPAG/emint optimization path because the Fortran + // routine hard-codes MAXCYC = 0. + let n_points = population_theta.matrix().nrows(); + let mut log_joint_weights = vec![f64::NEG_INFINITY; n_points]; + + for point_idx in 0..n_points { + let prior_weight = population_weights[point_idx]; + if prior_weight <= 0.0 { + continue; + } + + let mut log_weight = prior_weight.ln(); + let mut is_zero = false; + + for subject_idx in 0..psi.matrix().nrows() { + let likelihood = psi.matrix()[(subject_idx, point_idx)]; + if likelihood <= 0.0 { + is_zero = true; + break; + } + log_weight += likelihood.ln(); + } + + if !is_zero { + log_joint_weights[point_idx] = log_weight; + } + } + + let max_log_weight = log_joint_weights + .iter() + .copied() + .fold(f64::NEG_INFINITY, f64::max); + + if !max_log_weight.is_finite() { + return Err(anyhow::anyhow!( + "NPAGFULL11 filtering produced zero joint probability for every support point" + )); + } + + let mut initial_weights: Vec = log_joint_weights + .iter() + .map(|&log_weight| { + if log_weight.is_finite() { + (log_weight - max_log_weight).exp() + } else { + 0.0 + } + }) + .collect(); + + let total_weight: f64 = initial_weights.iter().sum(); + if total_weight <= 0.0 { + return Err(anyhow::anyhow!( + "NPAGFULL11 filtering produced non-positive posterior mass" + )); + } + + for weight in &mut initial_weights { + *weight /= total_weight; + } // NPAGFULL11 filtering: Keep all points within 1e-100 of the maximum weight // This is different from NPAG's condensation - NO QR decomposition here! let max_weight = initial_weights .iter() - .fold(f64::NEG_INFINITY, |a, b| a.max(b)); + .fold(f64::NEG_INFINITY, |a, b| a.max(*b)); let threshold = 1e-100; // NPAGFULL11-specific threshold let keep_lambda: Vec = initial_weights .iter() .enumerate() - .filter(|(_, lam)| *lam > threshold * max_weight) + .filter(|(_, lam)| **lam > threshold * max_weight) .map(|(i, _)| i) .collect(); From 4b134e66d62012e2a3e89c2efdedb484d850f952 Mon Sep 17 00:00:00 2001 From: Romain Garreau Date: Wed, 20 May 2026 22:24:24 +0200 Subject: [PATCH 4/4] feat : split dual optimization - split methods of dual optimization - User can now chose to run posterior only or dual (posterior and uniform) - add examples (`bestdose_posterior.rs`) to compare dual and posterior only Co-Authored-By: Julian Otalvaro <1023006+Siel@users.noreply.github.com> Co-Authored-By: Markus Hovd <66058642+mhovd@users.noreply.github.com> --- examples/bestdose_posterior.rs | 161 +++++++++++++++++++++++++++++++++ src/bestdose/mod.rs | 38 ++++++-- src/bestdose/optimization.rs | 118 +++++++++++++++--------- src/bestdose/types.rs | 28 ++++++ 4 files changed, 293 insertions(+), 52 deletions(-) create mode 100644 examples/bestdose_posterior.rs diff --git a/examples/bestdose_posterior.rs b/examples/bestdose_posterior.rs new file mode 100644 index 000000000..972e031a5 --- /dev/null +++ b/examples/bestdose_posterior.rs @@ -0,0 +1,161 @@ +use anyhow::Result; +use pmcore::bestdose; // bestdose new + // use pmcore::bestdose::bestdose_old as bestdose; // bestdose old + +use pmcore::prelude::*; +use pmcore::routines::initialization::parse_prior; + +fn main() -> Result<()> { + // Example model + let eq = ode! { + diffeq: |x, p, _t, dx, b, _rateiv, _cov| { + // fetch_cov!(cov, t, wt); + fetch_params!(p, ke, _v); + dx[0] = -ke * x[0] + b[0]; + }, + out: |x, p, _t, _cov, y| { + fetch_params!(p, _ke, v); + y[0] = x[0] / v; + }, + }; + + let params = Parameters::new() + .add("ke", 0.001, 3.0) + .add("v", 25.0, 250.0); + + let ems = AssayErrorModels::new().add( + 0, + AssayErrorModel::additive(ErrorPoly::new(0.0, 0.20, 0.0, 0.0), 0.0), + )?; + + // Make settings + let mut settings = Settings::builder() + .set_algorithm(Algorithm::NPAG) + .set_parameters(params) + .set_error_models(ems.clone()) + .build(); + + settings.disable_output(); + + // Generate a patient with known parameters + // Ke = 0.5, V = 50 + // C(t) = Dose * exp(-ke * t) / V + + fn conc(t: f64, dose: f64) -> f64 { + let ke = 0.3406021231412888; // Elimination rate constant + let v = 99.99475717544556; // Volume of distribution + (dose * (-ke * t).exp()) / v + } + + // Some observed data + let subject = Subject::builder("Nikola Tesla") + .bolus(0.0, 150.0, 0) + .observation(2.0, conc(2.0, 150.0), 0) + .observation(4.0, conc(4.0, 150.0), 0) + .observation(6.0, conc(6.0, 150.0), 0) + .bolus(12.0, 75.0, 0) + .observation(14.0, conc(2.0, 75.0) + conc(14.0, 150.0), 0) + .observation(16.0, conc(4.0, 75.0) + conc(16.0, 150.0), 0) + .observation(18.0, conc(6.0, 75.0) + conc(18.0, 150.0), 0) + .build(); + + let past_data = subject.clone(); + + let target_data = Subject::builder("Thomas Edison") + .bolus(0.0, 0.0, 0) + .observation(2.0, conc(2.0, 150.0), 0) + .observation(4.0, conc(4.0, 150.0), 0) + .observation(6.0, conc(6.0, 150.0), 0) + .bolus(12.0, 0.0, 0) + .observation(14.0, conc(2.0, 75.0) + conc(14.0, 150.0), 0) + .observation(16.0, conc(4.0, 75.0) + conc(16.0, 150.0), 0) + .observation(18.0, conc(6.0, 75.0) + conc(18.0, 150.0), 0) + .build(); + + let (theta, prior) = parse_prior( + &"examples/bimodal_ke/prior.csv".to_string(), + &settings, + ) + .unwrap(); + + let problem = bestdose::BestDoseProblem::new( + &theta, + &prior.unwrap(), + Some(past_data.clone()), + target_data.clone(), + None, + eq.clone(), + bestdose::DoseRange::new(0.0, 300.0), + 0.0, + settings.clone(), + bestdose::Target::Concentration, + )? + .with_optimization_strategy(bestdose::OptimizationStrategy::PosteriorOnly); + + println!("Optimizing dose with posterior-only strategy..."); + + let bias_weights = vec![0.0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1.0]; + let mut results = Vec::new(); + + for bias_weight in &bias_weights { + println!("Running optimization with bias weight: {}", bias_weight); + let optimal = problem.clone().with_bias_weight(*bias_weight).optimize()?; + results.push((bias_weight, optimal)); + } + + for (bias_weight, optimal) in &results { + let opt_doses = optimal.doses(); + + println!( + "Bias weight: {:.2}\t\t Optimal dose: {:?}\t\tCost: {:.6}\t\tln Cost: {:.4}\t\tMethod: {}", + bias_weight, + opt_doses, + optimal.objf(), + optimal.objf().ln(), + optimal.optimization_method() + ); + } + + let optimal = &results.last().unwrap().1; + println!("\nConcentration-time predictions for optimal dose:"); + for pred in optimal.predictions().predictions().into_iter() { + println!( + "Time: {:.2} h, Observed: {:.2}, (Pop Mean: {:.4}, Pop Median: {:.4}, Post Mean: {:.4}, Post Median: {:.4})", + pred.time(), pred.obs().unwrap_or(0.0), pred.pop_mean(), pred.pop_median(), pred.post_mean(), pred.post_median() + ); + } + + let posterior_theta = problem.posterior_theta(); + let posterior_weights = problem.posterior_weights(); + let population_weights = problem.population_weights(); + let param_names = posterior_theta.param_names(); + + println!("\n=== Support Points Summary ==="); + println!("Number of support points: {}", posterior_theta.nspp()); + + print!("\n{:<8} {:<15} {:<15}", "Point", "Prior Weight", "Posterior Weight"); + for name in ¶m_names { + print!(" {:<15}", name); + } + println!(); + println!("{}", "-".repeat(40 + 16 * param_names.len())); + + for point_idx in 0..posterior_theta.nspp() { + let row = posterior_theta.matrix().row(point_idx); + + print!( + "{:<8} {:<15.6e} {:<15.6e}", + point_idx, + population_weights[point_idx], + posterior_weights[point_idx] + ); + + for value in row.iter() { + print!(" {:<15.6}", value); + } + + println!(); + } + + Ok(()) +} \ No newline at end of file diff --git a/src/bestdose/mod.rs b/src/bestdose/mod.rs index f9588dc33..9500450d4 100644 --- a/src/bestdose/mod.rs +++ b/src/bestdose/mod.rs @@ -302,7 +302,7 @@ pub mod predictions; mod types; // Re-export public API -pub use types::{BestDoseProblem, BestDoseResult, DoseRange, Target}; +pub use types::{BestDoseProblem, BestDoseResult, DoseRange, OptimizationStrategy, Target}; /// Helper function to concatenate past and future subjects (Option 3: Fortran MAKETMP approach) /// @@ -710,6 +710,7 @@ impl BestDoseProblem { tracing::info!(" Support points: {}", posterior_theta.matrix().nrows()); tracing::info!(" Target type: {:?}", target_type); tracing::info!(" Bias weight (λ): {}", bias_weight); + tracing::info!(" Optimization strategy: {}", OptimizationStrategy::Dual); Ok(BestDoseProblem { target: final_target, @@ -721,6 +722,7 @@ impl BestDoseProblem { settings, doserange, bias_weight, + optimization_strategy: OptimizationStrategy::Dual, }) } @@ -767,13 +769,24 @@ impl BestDoseProblem { /// - `auc_predictions`: AUC values (if target_type is AUC) /// - `optimization_method`: "posterior" or "uniform" pub fn optimize(self) -> Result { - tracing::info!("╔══════════════════════════════════════════════════════════╗"); - tracing::info!("║ BestDose Algorithm: STAGE 2 & 3 ║"); - tracing::info!("║ Dual Optimization + Final Predictions ║"); - tracing::info!("╚══════════════════════════════════════════════════════════╝"); + match self.optimization_strategy { + OptimizationStrategy::Dual => { + tracing::info!("╔══════════════════════════════════════════════════════════╗"); + tracing::info!("║ BestDose Algorithm: STAGE 2 & 3 ║"); + tracing::info!("║ Dual Optimization + Final Predictions ║"); + tracing::info!("╚══════════════════════════════════════════════════════════╝"); + + optimization::dual_optimization(&self) + } + OptimizationStrategy::PosteriorOnly => { + tracing::info!("╔══════════════════════════════════════════════════════════╗"); + tracing::info!("║ BestDose Algorithm: STAGE 2 & 3 ║"); + tracing::info!("║ Posterior Optimization Only + Final Predictions ║"); + tracing::info!("╚══════════════════════════════════════════════════════════╝"); - // STAGE 2 & 3: Dual optimization + predictions - optimization::dual_optimization(&self) + optimization::posterior_optimization(&self) + } + } } /// Set the bias weight (lambda parameter) @@ -786,6 +799,12 @@ impl BestDoseProblem { self } + /// Set the Stage 2 optimization strategy. + pub fn with_optimization_strategy(mut self, strategy: OptimizationStrategy) -> Self { + self.optimization_strategy = strategy; + self + } + /// Get a reference to the refined posterior support points (Θ) pub fn posterior_theta(&self) -> &Theta { &self.theta @@ -811,6 +830,11 @@ impl BestDoseProblem { self.bias_weight } + /// Get the selected Stage 2 optimization strategy. + pub fn optimization_strategy(&self) -> OptimizationStrategy { + self.optimization_strategy + } + /// Get the selected optimization target type pub fn target_type(&self) -> Target { self.target_type diff --git a/src/bestdose/optimization.rs b/src/bestdose/optimization.rs index bd4056ca2..2caefd302 100644 --- a/src/bestdose/optimization.rs +++ b/src/bestdose/optimization.rs @@ -180,6 +180,78 @@ fn run_single_optimization( Ok((full_doses, final_cost)) } +fn finalize_optimization( + problem: &BestDoseProblem, + final_doses: Vec, + final_cost: f64, + method: OptimalMethod, + final_weights: Weights, +) -> Result { + // ═════════════════════════════════════════════════════════════ + // STAGE 3: Final Predictions + // ═════════════════════════════════════════════════════════════ + tracing::info!("─────────────────────────────────────────────────────────────"); + tracing::info!("STAGE 3: Final Predictions"); + tracing::info!("─────────────────────────────────────────────────────────────"); + tracing::info!( + " Calculating predictions with optimal doses and {} weights", + method + ); + + // Generate target subject with optimal doses + let mut optimal_subject = problem.target.clone(); + let mut dose_number = 0; + + for occasion in optimal_subject.iter_mut() { + for event in occasion.iter_mut() { + match event { + Event::Bolus(bolus) => { + bolus.set_amount(final_doses[dose_number]); + dose_number += 1; + } + Event::Infusion(infusion) => { + infusion.set_amount(final_doses[dose_number]); + dose_number += 1; + } + Event::Observation(_) => {} + } + } + } + + let (preds, auc_predictions) = + calculate_final_predictions(problem, &final_doses, &final_weights)?; + + tracing::info!(" ✓ Predictions complete"); + tracing::info!("─────────────────────────────────────────────────────────────"); + + Ok(BestDoseResult { + optimal_subject, + objf: final_cost, + status: BestDoseStatus::Converged, + preds, + auc_predictions, + optimization_method: method, + }) +} + +pub fn posterior_optimization(problem: &BestDoseProblem) -> Result { + tracing::info!("─────────────────────────────────────────────────────────────"); + tracing::info!("STAGE 2: Posterior Optimization Only"); + tracing::info!("─────────────────────────────────────────────────────────────"); + tracing::info!("│"); + tracing::info!("└─ Optimization: Posterior Weights (Patient-Specific)"); + + let (doses, cost) = run_single_optimization(problem, &problem.posterior, "Posterior")?; + + finalize_optimization( + problem, + doses, + cost, + OptimalMethod::Posterior, + problem.posterior.clone(), + ) +} + /// Stage 2 & 3: Dual optimization + Final predictions /// /// # Algorithm Flow (Matches Diagram) @@ -255,49 +327,5 @@ pub fn dual_optimization(problem: &BestDoseProblem) -> Result { (doses2, cost2, OptimalMethod::Uniform, uniform_weights) }; - // ═════════════════════════════════════════════════════════════ - // STAGE 3: Final Predictions - // ═════════════════════════════════════════════════════════════ - tracing::info!("─────────────────────────────────────────────────────────────"); - tracing::info!("STAGE 3: Final Predictions"); - tracing::info!("─────────────────────────────────────────────────────────────"); - tracing::info!( - " Calculating predictions with optimal doses and {} weights", - method - ); - - // Generate target subject with optimal doses - let mut optimal_subject = problem.target.clone(); - let mut dose_number = 0; - - for occasion in optimal_subject.iter_mut() { - for event in occasion.iter_mut() { - match event { - Event::Bolus(bolus) => { - bolus.set_amount(final_doses[dose_number]); - dose_number += 1; - } - Event::Infusion(infusion) => { - infusion.set_amount(final_doses[dose_number]); - dose_number += 1; - } - Event::Observation(_) => {} - } - } - } - - let (preds, auc_predictions) = - calculate_final_predictions(problem, &final_doses, &final_weights)?; - - tracing::info!(" ✓ Predictions complete"); - tracing::info!("─────────────────────────────────────────────────────────────"); - - Ok(BestDoseResult { - optimal_subject, - objf: final_cost, - status: BestDoseStatus::Converged, - preds, - auc_predictions, - optimization_method: method, - }) + finalize_optimization(problem, final_doses, final_cost, method, final_weights) } diff --git a/src/bestdose/types.rs b/src/bestdose/types.rs index e422cd0be..832a642e8 100644 --- a/src/bestdose/types.rs +++ b/src/bestdose/types.rs @@ -183,6 +183,33 @@ impl Default for DoseRange { } } +/// Strategy used for Stage 2 dose optimization. +/// +/// - [`OptimizationStrategy::Dual`]: Run both posterior and uniform optimizations, +/// then keep the lower-cost result. +/// - [`OptimizationStrategy::PosteriorOnly`]: Run only the posterior-weighted +/// optimization path. +#[derive(Debug, Clone, Copy, Serialize, Deserialize, PartialEq, Eq)] +pub enum OptimizationStrategy { + Dual, + PosteriorOnly, +} + +impl Default for OptimizationStrategy { + fn default() -> Self { + Self::Dual + } +} + +impl Display for OptimizationStrategy { + fn fmt(&self, f: &mut std::fmt::Formatter<'_>) -> std::fmt::Result { + match self { + OptimizationStrategy::Dual => write!(f, "Dual"), + OptimizationStrategy::PosteriorOnly => write!(f, "PosteriorOnly"), + } + } +} + /// The BestDose optimization problem /// /// Contains all data needed for the three-stage BestDose algorithm. @@ -287,6 +314,7 @@ pub struct BestDoseProblem { // Optimization parameters pub(crate) doserange: DoseRange, pub(crate) bias_weight: f64, // λ: 0=personalized, 1=population + pub(crate) optimization_strategy: OptimizationStrategy, } /// Result from BestDose optimization