C ****************************************************************** C ****************************************************************** subroutine fparam(epsfeas,epsopt,iprint,ncomp) implicit none C SCALAR ARGUMENTS integer ncomp,iprint double precision epsfeas,epsopt #include "dim.par" #include "algparam.com" #include "fixvar.com" #include "slacks.com" #include "scaling.com" C PARAMETERS integer nwords parameter ( nwords = 13 ) C DATA BLOCKS character * 1 lower(26),upper(26) data lower /'a','b','c','d','e','f','g','h','i','j','k','l','m', + 'n','o','p','q','r','s','t','u','v','w','x','y','z'/ data upper /'A','B','C','D','E','F','G','H','I','J','K','L','M', + 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z'/ character * 10 dictionary(nwords) data dictionary( 1) /'INCREMENTA'/ data dictionary( 2) /'HESSIAN-AP'/ data dictionary( 3) /'TRUE-HESSI'/ data dictionary( 4) /'PERFORM-AC'/ data dictionary( 5) /'DIRECT-SOL'/ data dictionary( 6) /'SCALE-LINE'/ data dictionary( 7) /'DO-NOT-REM'/ data dictionary( 8) /'ADD-SLACKS'/ data dictionary( 9) /'SCALE-OBJE'/ data dictionary(10) /'FEASIBILIT'/ data dictionary(11) /'OPTIMALITY'/ data dictionary(12) /'OUTPUT-DET'/ data dictionary(13) /'NCOMP-ARRA'/ character * 31 description(nwords) data description( 1) /'INCREMENTAL-QUOTIENTS-IN-CG '/ data description( 2) /'HESSIAN-APPROXIMATION-IN-CG '/ data description( 3) /'TRUE-HESSIAN-PRODUCT-IN-CG '/ data description( 4) /'PERFORM-ACCELERATION-STEP '/ data description( 5) /'DIRECT-SOLVER '/ data description( 6) /'SCALE-LINEAR-SYSTEMS '/ data description( 7) /'DO-NOT-REMOVE-FIXED-VARIABLES '/ data description( 8) /'ADD-SLACKS '/ data description( 9) /'SCALE-OBJECTIVE-AND-CONSTRAINTS'/ data description(10) /'FEASIBILITY-TOLERANCE '/ data description(11) /'OPTIMALITY-TOLERANCE '/ data description(12) /'OUTPUT-DETAIL '/ data description(13) /'NCOMP-ARRAY '/ character * 1 addinfo(nwords) data addinfo( 1) /' '/ data addinfo( 2) /' '/ data addinfo( 3) /' '/ data addinfo( 4) /' '/ data addinfo( 5) /' '/ data addinfo( 6) /' '/ data addinfo( 7) /' '/ data addinfo( 8) /' '/ data addinfo( 9) /' '/ data addinfo(10) /'D'/ data addinfo(11) /'D'/ data addinfo(12) /'I'/ data addinfo(13) /'I'/ C LOCAL SCALARS logical lss,scl integer i,ifirst,ikey,ilast,inum,j double precision dnum C LOCAL ARRAYS character * 80 line character * 10 keyword character * 4 lsssub character * 4 sclsub C EXTERNAL FUNCTIONS external lss,scl C OPENING THE SPECIFICATION FILE open(20,err=300,file='algencan.dat',status='old') C MAIN LOOP C write(*, 9005) write(10,9005) 100 continue C READING LINES read(20,fmt=1000,err=400,end=200) line C PROCESS LINES C Find first character i = 1 110 if ( i .le. 80 .and. line(i:i) .eq. ' ' ) then i = i + 1 go to 110 end if C Skip blank lines if ( i .gt. 80 ) then go to 100 end if ifirst = i C Skip comments if ( line(ifirst:ifirst) .eq. '*' .or. + line(ifirst:ifirst) .eq. '#' ) then go to 100 end if C Find the end of the keyword i = ifirst + 1 120 if ( i .le. 80 .and. line(i:i) .ne. ' ' ) then i = i + 1 go to 120 end if ilast = i - 1 C Obtain the first 10 characters and convert to upper-case keyword = ' ' do i = 1,min( 10, ilast - ifirst + 1 ) keyword(i:i) = line(ifirst+i-1:ifirst+i-1) do j = 1,26 if ( keyword(i:i) .eq. lower(j) ) then keyword(i:i) = upper(j) end if end do end do C Look up the keyword in the dictionary i = 1 130 if ( i .le. nwords .and. keyword .ne. dictionary(i) ) then i = i + 1 go to 130 end if C Ignore unknown keywords if ( i .gt. nwords ) then C write(*, 9020) line(ifirst:ilast) write(10,9020) line(ifirst:ilast) go to 100 end if ikey = i C Read additional information if needed if ( addinfo(ikey) .ne. ' ' ) then C Skip blanks i = ilast + 1 140 if ( i .le. 80 .and. line(i:i) .eq. ' ' ) then i = i + 1 go to 140 end if C Ignore keywords without the required information if ( i .gt. 80 ) then C write(*, 9030) description(ikey) write(10,9030) description(ikey) go to 100 end if C Read additional information if ( addinfo(ikey) .eq. 'I' ) then read(unit=line(i:80),fmt=2000) inum else if ( addinfo(ikey) .eq. 'D' ) then read(unit=line(i:80),fmt=3000) dnum end if end if C Process keyword if ( addinfo(ikey) .eq. ' ' ) then C write(*, 9040) description(ikey) write(10,9040) description(ikey) else if ( addinfo(ikey) .eq. 'I' ) then C write(*, 9041) description(ikey),inum write(10,9041) description(ikey),inum else if ( addinfo(ikey) .eq. 'D' ) then C write(*, 9042) description(ikey),dnum write(10,9042) description(ikey),dnum end if C Set the corresponding algencan argument if ( ikey .eq. 1 ) then hptype = 'INCQUO' else if ( ikey .eq. 2 ) then hptype = 'HAPPRO' else if ( ikey .eq. 3 ) then if ( hlpcoded .or. truehl ) then hptype = 'TRUEHL' else C write(* ,9100) description(ikey) write(10,9100) description(ikey) end if else if ( ikey .eq. 4 ) then if ( .not. truehl ) then C write(* ,9110) description(ikey) write(10,9110) description(ikey) else if ( .not. lss(lsssub) ) then C write(* ,9120) description(ikey) write(10,9120) description(ikey) else skipacc = .false. C write(* ,9060) lsssub write(10,9060) lsssub end if else if ( ikey .eq. 5 ) then if ( .not. truehl ) then C write(* ,9110) description(ikey) write(10,9110) description(ikey) else if ( .not. lss(lsssub) ) then C write(* ,9120) description(ikey) write(10,9120) description(ikey) else avoidds = .false. C write(* ,9050) lsssub write(10,9050) lsssub end if else if ( ikey .eq. 6 ) then if ( lss(lsssub) ) then if ( lsssub .eq. 'MA57' ) then sclsys = .true. C write(* ,9060) lsssub write(10,9060) lsssub else if ( scl(sclsub) ) then sclsys = .true. C write(* ,9070) sclsub write(10,9070) sclsub else C write(* ,9130) description(ikey) write(10,9130) description(ikey) end if end if else if ( ikey .eq. 7 ) then rmfixv = .false. else if ( ikey .eq. 8 ) then slacks = .true. else if ( ikey .eq. 9 ) then scale = .true. else if ( ikey .eq. 10 ) then epsfeas = dnum else if ( ikey .eq. 11 ) then epsopt = dnum else if ( ikey .eq. 12 ) then iprint = inum else if ( ikey .eq. 13 ) then ncomp = inum end if C IIERATE go to 100 C END OF LOOP C TERMINATIONS C CLOSING SPECIFICATION FILE 200 continue close(20) go to 500 C NO SPECIFICATION FILE 300 continue C write(*, 9000) write(10,9000) go to 500 C ERROR READING THE SPECIFICATION FILE 400 continue write(*, 9010) write(10,9010) go to 500 C PRINTING PARAMETERS VALUES 500 continue C write(* ,4000) hptype,avoidds,skipacc,sclsys,rmfixv,slacks, C + scale,epsfeas,epsopt,iprint,ncomp write(10,4000) hptype,avoidds,skipacc,sclsys,rmfixv,slacks, + scale,epsfeas,epsopt,iprint,ncomp C NON-EXECUTABLE STATEMENTS 1000 format(A80) 2000 format(BN,I20) 3000 format(BN,F24.0) 4000 format(/,' ALGENCAN PARAMETERS:', + /,' hptype = ', 14X,A6, + /,' avoidds = ', 19X,L1, + /,' skipacc = ', 19X,L1, + /,' sclsys = ', 19X,L1, + /,' rmfixv = ', 19X,L1, + /,' slacks = ', 19X,L1, + /,' scale = ', 19X,L1, + /,' epsfeas = ',8X,1P,D12.4, + /,' epsopt = ',8X,1P,D12.4, + /,' iprint = ', I20, + /,' ncomp = ', I20) 9000 format(/,' The optional specification file algencan.dat was not', + ' found in the current',/,' directory (this is not a', + ' problem nor an error). The default values for the',/, + ' ALGENCAN parameters will be used.') 9005 format(/,' Specification file algencan.dat is being used.') 9010 format(/,' Error reading specification file algencan.dat.') 9020 format( ' Ignoring unknown keyword ',A27) 9030 format( ' Ignoring incomplete keyword ',A27) 9040 format(1X,A32) 9041 format(1X,A32,5X,I20) 9042 format(1X,A32,1X,1P,D24.8) 9050 format(1X,' (Subroutine ',A4,' from HSL will be used as a direct', + ' solver for linear systems.)') 9060 format(1X,' (Linear systems will be scaled using the embedded', + ' scaling option of',/, + 1X,' subroutine ',A4,' from HSL.)') 9070 format(1X,' (Subroutine ',A4,' from HSL will be used for scaling', + ' linear systems.)') 9100 format(/,' Warning: Ignoring keyword ',A27,'. This option', + ' requires',/,' subroutines EVALH and EVALHC, or,', + ' alternatively, subroutine EVALHLP, to be',/,' coded', + ' by the user. If you already coded them, set array', + ' CODED in subrutine',/,' INIP appropiately.',/) 9110 format(/,' Warning: Ignoring keyword ',A27,'. This option', + ' requires',/,' subroutines EVALH and EVALHC, or,', + ' alternatively, subroutine EVALHL, to be',/,' coded', + ' by the user. If you already coded them, set array', + ' CODED in subrutine',/,' INIP appropiately.',/) 9120 format(/,' Warning: Ignoring keyword ',A27,'. This option', + ' requires',/,' subroutine MA27 or MA57 from HSL to be', + ' provided by the user. If you have any',/,' of them,', + ' see the compilation instructions for details.',/) 9130 format(/,' Warning: Ignoring keyword ',A27,'. This option', + ' requires',/,' subroutine MC30 or MC77 from HSL to be', + ' provided by the user. If you have any',/,' of them,', + ' see the compilation instructions for details.',/) end