From bc7780d2ff0e7eb142f2a1d5ebefa66181b6a4d6 Mon Sep 17 00:00:00 2001 From: "Federico E. Benelli" Date: Wed, 21 Dec 2022 22:49:55 -0300 Subject: [PATCH 1/4] added fpm compatiblity --- app/packmol.f90 | 954 +++++++ fpm.toml | 19 + src/ahestetic.f90 | 21 + src/cenmass.f90 | 103 + src/checkpoint.f90 | 116 + src/comparegrad.f90 | 98 + src/comprest.f90 | 168 ++ src/compute_data.f90 | 63 + src/computef.f90 | 220 ++ src/computeg.f90 | 309 +++ src/exit_codes.f90 | 18 + src/flashmod.f90 | 21 + src/flashsort.f90 | 95 + src/fparc.f90 | 77 + src/gencan.f | 6006 ++++++++++++++++++++++++++++++++++++++++++ src/getinp.f90 | 1115 ++++++++ src/gparc.f90 | 87 + src/gwalls.f90 | 264 ++ src/heuristics.f90 | 151 ++ src/initial.f90 | 592 +++++ src/input.f90 | 80 + src/jacobi.f90 | 106 + src/output.f90 | 807 ++++++ src/pgencan.f90 | 98 + src/polartocart.f90 | 106 + src/random.f90 | 50 + src/resetboxes.f90 | 30 + src/restmol.f90 | 86 + src/setibox.f90 | 30 + src/setijk.f90 | 46 + src/setsizes.f90 | 364 +++ src/sizes.f90 | 31 + src/strlength.f90 | 97 + src/swaptype.f90 | 89 + src/swaptypemod.f90 | 16 + src/title.f90 | 19 + src/tobar.f90 | 42 + src/usegencan.f90 | 18 + src/writesuccess.f90 | 46 + 39 files changed, 12658 insertions(+) create mode 100644 app/packmol.f90 create mode 100644 fpm.toml create mode 100644 src/ahestetic.f90 create mode 100644 src/cenmass.f90 create mode 100644 src/checkpoint.f90 create mode 100644 src/comparegrad.f90 create mode 100644 src/comprest.f90 create mode 100644 src/compute_data.f90 create mode 100644 src/computef.f90 create mode 100644 src/computeg.f90 create mode 100644 src/exit_codes.f90 create mode 100644 src/flashmod.f90 create mode 100644 src/flashsort.f90 create mode 100644 src/fparc.f90 create mode 100644 src/gencan.f create mode 100644 src/getinp.f90 create mode 100644 src/gparc.f90 create mode 100644 src/gwalls.f90 create mode 100644 src/heuristics.f90 create mode 100644 src/initial.f90 create mode 100644 src/input.f90 create mode 100644 src/jacobi.f90 create mode 100644 src/output.f90 create mode 100644 src/pgencan.f90 create mode 100644 src/polartocart.f90 create mode 100644 src/random.f90 create mode 100644 src/resetboxes.f90 create mode 100644 src/restmol.f90 create mode 100644 src/setibox.f90 create mode 100644 src/setijk.f90 create mode 100644 src/setsizes.f90 create mode 100644 src/sizes.f90 create mode 100644 src/strlength.f90 create mode 100644 src/swaptype.f90 create mode 100644 src/swaptypemod.f90 create mode 100644 src/title.f90 create mode 100644 src/tobar.f90 create mode 100644 src/usegencan.f90 create mode 100644 src/writesuccess.f90 diff --git a/app/packmol.f90 b/app/packmol.f90 new file mode 100644 index 0000000..f1d8558 --- /dev/null +++ b/app/packmol.f90 @@ -0,0 +1,954 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +!----------------------------------------------------------------------------- +! +! http://m3g.iqm.unicamp.br/packmol +! +! Usage (see the page above for further information): +! +! ./packmol < inputfile.inp +! +! References: +! +! L. Martinez, R. Andrade, E. G. Birgin, J. M. Martinez, +! PACKMOL: A package for building initial configurations for +! molecular dynamics simulations, J. Comp. Chem. 30:2157-2164, 2009. +! +! J. M. Martinez and L. Martinez, +! Packing optimization for the automated generation of complex +! system's initial configurations for molcular dynamics and +! docking. J. Comp. Chem. 24:819-825, 2003. +! +! This version of Packmol uses the optimization method GENCAN which +! is a part of the TANGO (Trustable Algorithms for Nonlinear General +! Optimization) project. +! Reference: +! E. G. Birgin, J. M. Martinez, Comp. Opt. Appl. 23:101-125, 2002. +! http://www.ime.usp.br/~egbirgin/tango +! +! + +program packmol + + use exit_codes + use sizes + use compute_data + use input + use usegencan + use flashsort + use swaptypemod + use ahestetic + implicit none + + integer :: itype, irest, idatom, iatom + integer :: idtemp, nmtemp, natemp, input_itypetemp + integer :: linesttmp1, linesttmp2, jtype + integer :: ntmol, n, iftype, icart, imol, iicart, iline_atoms + integer :: i, iline, iiatom, iat, iirest, iratcount, ival + integer :: loop + integer :: resntemp, nloop_tmp + integer :: ioerr + integer :: maxmove_tmp + integer :: exit_code = 0 + + double precision, allocatable :: x(:), xprint(:) ! (nn) + double precision :: v1(3),v2(3),v3(3) + double precision :: radscale, value + double precision :: cmx, cmy, cmz, beta, gama, teta + double precision :: xtemp, ytemp, ztemp + double precision :: fx, bestf, flast, fprint, all_type_fx + double precision :: fimp, fimprov + double precision, parameter :: pi=4.d0*datan(1.d0) + + real :: etime, tarray(2), time0 + + character(len=strl) :: record, restart_from_temp, restart_to_temp + character(len=strl) :: xyzfile + character(len=1) :: chain_tmp + + logical :: fixtmp + logical :: rests + logical :: movebadprint + logical :: changechains_tmp, connecttmp + + logical, allocatable :: fixed(:) ! ntype + + ! Printing title + + call title() + + ! Set dimensions of all arrays + + call setsizes() + + ! Allocate local array + + allocate(fixed(ntype),x(nn),xprint(nn),xfull(nn)) + + ! Start time computation + + time0 = etime(tarray) + + ! Reading input file + + call getinp() + + ! Put molecules in their center of mass + + call cenmass() + + ! Writting some input data + + write(*,*) ' Total number of atoms: ', ntotat + + ! Put fixed molecules in the specified position + + do itype = 1, ntype + fixed(itype) = .false. + end do + + do irest = 1, nrest + if(ityperest(irest).eq.1) then + do itype = 1, ntype + if(irestline(irest).gt.linestrut(itype,1).and.& + irestline(irest).lt.linestrut(itype,2)) then + cmx = restpars(irest,1) + cmy = restpars(irest,2) + cmz = restpars(irest,3) + beta = restpars(irest,4) + gama = restpars(irest,5) + teta = restpars(irest,6) + + ! Compute rotation matrix from euler angles + + call eulerfixed(beta,gama,teta,v1,v2,v3) + + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + xtemp = coor(idatom,1)*v1(1) & + + coor(idatom,2)*v2(1) & + + coor(idatom,3)*v3(1) + ytemp = coor(idatom,1)*v1(2) & + + coor(idatom,2)*v2(2) & + + coor(idatom,3)*v3(2) + ztemp = coor(idatom,1)*v1(3) & + + coor(idatom,2)*v2(3) & + + coor(idatom,3)*v3(3) + coor(idatom, 1) = xtemp + cmx + coor(idatom, 2) = ytemp + cmy + coor(idatom, 3) = ztemp + cmz + end do + record = name(itype) + write(*,*) ' Molecule ',trim(adjustl(record)),'(',itype,') will be fixed.' + fixed(itype) = .true. + if(nmols(itype).gt.1) then + write(*,*)' ERROR: Cannot set number > 1',' for fixed molecules. ' + write(*,*) ' Structure: ', itype,': ', trim(adjustl(record)) + stop exit_code_input_error + end if + if ( restart_from(itype) /= 'none' .or. & + restart_to(itype) /= 'none' ) then + write(*,*) ' ERROR: Restart files cannot be used for fixed molecules. ' + write(*,*) ' Structure: ', itype,': ', trim(adjustl(record)) + stop exit_code_input_error + end if + end if + end do + end if + end do + + ! Reseting parameters for removing the fixed molecules + ! fix is the logical variable that informs that there are fixed molecules + + fix = .false. + ntemp = 0 + do itype = 1, ntype + + ! input_itype and fixedoninput vectors are used only to preserve the + ! order of input in the output files + + input_itype(itype) = itype + if(fixed(itype)) then + fix = .true. + fixedoninput(itype) = .true. + else + ntemp = ntemp + 1 + fixedoninput(itype) = .false. + end if + end do + ntfix = ntype + ntype = ntemp + + do i = 1, ntfix - ntype + do itype = 1, ntfix - 1 + if(fixed(itype)) then + record = name(itype) + restart_to_temp = restart_to(itype) + restart_from_temp = restart_from(itype) + fixtmp = fixed(itype) + idtemp = idfirst(itype) + input_itypetemp = input_itype(itype) + nmtemp = nmols(itype) + natemp = natoms(itype) + resntemp = resnumbers(itype) + connecttmp = connect(itype) + if(pdb) xyzfile = pdbfile(itype) + linesttmp1 = linestrut(itype,1) + linesttmp2 = linestrut(itype,2) + changechains_tmp = changechains(itype) + maxmove_tmp = maxmove(itype) + chain_tmp = chain(itype) + nloop_tmp = nloop_type(itype) + jtype = itype + 1 + if(.not.fixed(jtype)) then + name(itype) = name(jtype) + name(jtype) = record(1:10) + restart_to(itype) = restart_to(jtype) + restart_to(jtype) = restart_to_temp + restart_from(itype) = restart_from(jtype) + restart_from(jtype) = restart_from_temp + idfirst(itype) = idfirst(jtype) + idfirst(jtype) = idtemp + input_itype(itype) = input_itype(jtype) + input_itype(jtype) = input_itypetemp + fixed(itype) = fixed(jtype) + fixed(jtype) = fixtmp + nmols(itype) = nmols(jtype) + nmols(jtype) = nmtemp + natoms(itype) = natoms(jtype) + natoms(jtype) = natemp + resnumbers(itype) = resnumbers(jtype) + resnumbers(jtype) = resntemp + connect(itype) = connect(jtype) + connect(jtype) = connecttmp + changechains(itype) = changechains(jtype) + changechains(jtype) = changechains_tmp + maxmove(itype) = maxmove(jtype) + maxmove(jtype) = maxmove_tmp + chain(itype) = chain(jtype) + chain(jtype) = chain_tmp + nloop_type(itype) = nloop_type(jtype) + nloop_type(jtype) = nloop_tmp + if(pdb) then + pdbfile(itype) = pdbfile(jtype) + pdbfile(jtype) = xyzfile + end if + linestrut(itype,1) = linestrut(jtype,1) + linestrut(itype,2) = linestrut(jtype,2) + linestrut(jtype,1) = linesttmp1 + linestrut(jtype,2) = linesttmp2 + end if + end if + end do + end do + + ! Computing the number of variables + ! + ! ntype: 1...ntype (counter for the number of free structures) + ! + ! ntfix: 1...ntype...ntfix (counter for the total number of structures) + ! + + ntmol = 0 + do itype = 1, ntfix + ntmol = ntmol + nmols(itype) + end do + ntotmol = 0 + do itype = 1, ntype + ntotmol = ntotmol + nmols(itype) + end do + n = ntotmol * 6 + write(*,*) ' Total number of molecules: ', ntmol + write(*,*) ' Number of fixed molecules: ', ntmol - ntotmol + write(*,*) ' Number of free molecules: ', ntotmol + write(*,*) ' Number of variables: ', n + + ! Computing the total number of fixed atoms + + natfix = 0 + if(fix) then + do iftype = ntype + 1, ntfix + natfix = natfix + natoms(iftype) + end do + end if + write(*,*) ' Total number of fixed atoms: ', natfix + + ! Setting the array that contains the restrictions per atom + + icart = 0 + do itype = 1, ntype + rests = .false. + do imol = 1, nmols(itype) + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + icart = icart + 1 + idatom = idatom + 1 + nratom(icart) = 0 + iratcount = 0 + do i = 1, mrperatom + iratom(icart,i) = 0 + end do + iline = linestrut(itype,1) + do while(iline.lt.linestrut(itype,2)) + iline = iline + 1 + if(keyword(iline,1).eq.'atoms') then + iiatom = -1 + do iat = 2, maxkeywords + read(keyword(iline,iat),*,iostat=ioerr) iiatom + if ( ioerr /= 0 ) then + if ( iiatom == -1 ) then + write(*,*) ' ERROR: Could not read atom selection for type: ', itype + stop exit_code_input_error + else + exit + end if + end if + if ( iiatom > natoms(itype) ) then + write(*,*) ' ERROR: atom selection with index greater than number of ' + write(*,*) ' atoms in structure ', itype + stop exit_code_input_error + end if + if(iatom.eq.iiatom) exit + end do + do while(keyword(iline,1).ne.'end'.and.& + keyword(iline,2).ne.'atoms') + iline = iline + 1 + if(iatom.eq.iiatom) then + if(keyword(iline,1).eq.'inside'.or.& + keyword(iline,1).eq.'outside'.or.& + keyword(iline,1).eq.'over'.or.& + keyword(iline,1).eq.'above'.or.& + keyword(iline,1).eq.'below') then + nratom(icart) = nratom(icart) + 1 + iratcount = iratcount + 1 + do irest = 1, nrest + if(irestline(irest).eq.iline) iirest = irest + end do + iratom(icart,iratcount) = iirest + end if + end if + end do + iline = iline - 1 + else if(keyword(iline,1).eq.'inside'.or.& + keyword(iline,1).eq.'outside'.or.& + keyword(iline,1).eq.'over'.or.& + keyword(iline,1).eq.'above'.or.& + keyword(iline,1).eq.'below') then + nratom(icart) = nratom(icart) + 1 + iratcount = iratcount + 1 + do irest = 1, nrest + if(irestline(irest).eq.iline) iirest = irest + end do + iratom(icart,iratcount) = iirest + end if + end do + if(nratom(icart).gt.0) rests = .true. + end do + if(.not.rests) then + write(*,*) ' ERROR: Some molecule has no geometrical',& + ' restriction defined: nothing to do.' + stop exit_code_input_error + end if + end do + end do + + ! Read the constraints to rotations about axis, if set + + do itype = 1, ntype + constrain_rot(itype,1) = .false. + constrain_rot(itype,2) = .false. + constrain_rot(itype,3) = .false. + iline = linestrut(itype,1) + do while(iline.lt.linestrut(itype,2)) + iline = iline + 1 + if(keyword(iline,1).eq.'constrain_rotation') then + if(iline.gt.linestrut(itype,1).and.& + iline.lt.linestrut(itype,2)) then + + ! Note that for movable molecules, teta is a rotation on the x-axis, + ! gama is a rotation on the z-axis, + ! beta is a rotation on the y-axis + ! (see eulerrmat routine) + + if(keyword(iline,2).eq.'x') then + constrain_rot(itype,3) = .true. + read(keyword(iline,3),*) rot_bound(itype,3,1) + read(keyword(iline,4),*) rot_bound(itype,3,2) + rot_bound(itype,3,1) = rot_bound(itype,3,1)*pi/180.d0 + rot_bound(itype,3,2) = rot_bound(itype,3,2)*pi/180.d0 + + write(*,*) ' Rotations about x axis of molecules of ',& + ' type ', itype, ' will be constrained. ' + end if + if(keyword(iline,2).eq.'y') then + constrain_rot(itype,1) = .true. + read(keyword(iline,3),*) rot_bound(itype,1,1) + read(keyword(iline,4),*) rot_bound(itype,1,2) + rot_bound(itype,1,1) = rot_bound(itype,1,1)*pi/180.d0 + rot_bound(itype,1,2) = rot_bound(itype,1,2)*pi/180.d0 + + write(*,*) ' Rotations about y axis of molecules of ',& + ' type ', itype, ' will be constrained. ' + end if + if(keyword(iline,2).eq.'z') then + constrain_rot(itype,2) = .true. + read(keyword(iline,3),*) rot_bound(itype,2,1) + read(keyword(iline,4),*) rot_bound(itype,2,2) + rot_bound(itype,2,1) = rot_bound(itype,2,1)*pi/180.d0 + rot_bound(itype,2,2) = rot_bound(itype,2,2)*pi/180.d0 + + write(*,*) ' Rotations about z axis of molecules of ',& + ' type ', itype, ' will be constrained. ' + end if + if ( keyword(iline,2) /= 'x' .and. & + keyword(iline,2) /= 'y' .and. & + keyword(iline,2) /= 'z' ) then + write(*,*) ' ERROR: constrain_rotation option not properly defined (not x, y, or z) ' + stop exit_code_input_error + end if + end if + end if + end do + end do + + ! Setting the vector that contains the default tolerances + + do i = 1, ntotat + radius(i) = dism/2.d0 + fscale(i) = 1.d0 + if ( use_short_tol ) then + use_short_radius(i) = .true. + else + use_short_radius(i) = .false. + end if + short_radius(i) = short_tol_dist/2.d0 + short_radius_scale(i) = short_tol_scale + end do + + ! Setting the radius defined for atoms of each molecule, + ! but not atom-specific, first + + icart = 0 + do itype = 1, ntfix + iline = linestrut(itype,1) + iline_atoms = 0 + do while( iline <= linestrut(itype,2) ) + if ( keyword(iline,1) == "atoms" ) then + iline_atoms = iline + iline = iline + 1 + cycle + end if + if ( keyword(iline,1) == "end" .and. & + keyword(iline,2) == "atoms" ) then + iline_atoms = 0 + iline = iline + 1 + cycle + end if + if ( iline_atoms == 0 ) then + ! + ! Read radius + ! + if ( keyword(iline,1) == "radius" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read radius from keyword. ' + stop exit_code_input_error + end if + iicart = icart + do imol = 1, nmols(itype) + do iatom = 1, natoms(itype) + iicart = iicart + 1 + radius(iicart) = value + end do + end do + end if + ! + ! Read minimum-distance function scale + ! + if ( keyword(iline,1) == "fscale" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read fscale value from keyword. ' + stop exit_code_input_error + end if + iicart = icart + do imol = 1, nmols(itype) + do iatom = 1, natoms(itype) + iicart = iicart + 1 + fscale(iicart) = value + end do + end do + end if + ! + ! Read short_radius + ! + if ( keyword(iline,1) == "short_radius" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read short_radius value from keyword. ' + stop exit_code_input_error + end if + iicart = icart + do imol = 1, nmols(itype) + do iatom = 1, natoms(itype) + iicart = iicart + 1 + short_radius(iicart) = value + use_short_radius(iicart) = .true. + end do + end do + end if + ! + ! Read short_radius scale + ! + if ( keyword(iline,1) == "short_radius_scale" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read short_radius_scale value from keyword. ' + stop exit_code_input_error + end if + iicart = icart + do imol = 1, nmols(itype) + do iatom = 1, natoms(itype) + iicart = iicart + 1 + short_radius_scale(iicart) = value + use_short_radius(iicart) = .true. + end do + end do + end if + end if + iline = iline + 1 + end do + icart = icart + nmols(itype)*natoms(itype) + end do + + ! If some radius was defined using atom-specific definitions, overwrite + ! the general radius defined for the molecule + + icart = 0 + do itype = 1, ntfix + iline = linestrut(itype,1) + iline_atoms = 0 + do while( iline <= linestrut(itype,2) ) + if ( keyword(iline,1) == "atoms" ) then + iline_atoms = iline + iline = iline + 1 + cycle + end if + if ( keyword(iline,1) == "end" .and. & + keyword(iline,2) == "atoms" ) then + iline_atoms = 0 + iline = iline + 1 + cycle + end if + if ( iline_atoms /= 0 ) then + ! + ! Read atom specific radius + ! + if ( keyword(iline,1) == "radius" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read radius from keyword. ' + stop exit_code_input_error + end if + ival = 2 + do + read(keyword(iline_atoms,ival),*,iostat=ioerr) iat + if ( ioerr /= 0 ) exit + if ( iat > natoms(itype) ) then + write(*,*) ' ERROR: atom selection with index greater than number of ' + write(*,*) ' atoms in structure ', itype + stop exit_code_input_error + end if + radius(icart+iat) = value + ival = ival + 1 + end do + end if + ! + ! Read atom specific function scale + ! + if ( keyword(iline,1) == "fscale" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read fscale value from keyword. ' + stop exit_code_input_error + end if + ival = 2 + do + read(keyword(iline_atoms,ival),*,iostat=ioerr) iat + if ( ioerr /= 0 ) exit + if ( iat > natoms(itype) ) then + write(*,*) ' ERROR: atom selection with index greater than number of ' + write(*,*) ' atoms in structure ', itype + stop exit_code_input_error + end if + fscale(icart+iat) = value + ival = ival + 1 + end do + end if + ! + ! Read atom specific short radius + ! + if ( keyword(iline,1) == "short_radius" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read short_radius value from keyword. ' + stop exit_code_input_error + end if + ival = 2 + do + read(keyword(iline_atoms,ival),*,iostat=ioerr) iat + if ( ioerr /= 0 ) exit + if ( iat > natoms(itype) ) then + write(*,*) ' ERROR: atom selection with index greater than number of ' + write(*,*) ' atoms in structure ', itype + stop exit_code_input_error + end if + short_radius(icart+iat) = value + use_short_radius(icart+iat) = .true. + ival = ival + 1 + end do + end if + ! + ! Read atom specific short radius function scale + ! + if ( keyword(iline,1) == "short_radius_scale" ) then + read(keyword(iline,2),*,iostat=ioerr) value + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read short_radius_scale value from keyword. ' + stop exit_code_input_error + end if + ival = 2 + do + read(keyword(iline_atoms,ival),*,iostat=ioerr) iat + if ( ioerr /= 0 ) exit + if ( iat > natoms(itype) ) then + write(*,*) ' ERROR: atom selection with index greater than number of ' + write(*,*) ' atoms in structure ', itype + stop exit_code_input_error + end if + short_radius_scale(icart+iat) = value + use_short_radius(icart+iat) = .true. + ival = ival + 1 + end do + end if + end if + iline = iline + 1 + end do + iicart = icart + icart = icart + natoms(itype) + do imol = 2, nmols(itype) + do iatom = 1, natoms(itype) + icart = icart + 1 + radius(icart) = radius(iicart+iatom) + fscale(icart) = fscale(iicart+iatom) + short_radius(icart) = short_radius(iicart+iatom) + short_radius_scale(icart) = short_radius_scale(iicart+iatom) + use_short_radius(icart) = use_short_radius(iicart+iatom) + end do + end do + end do + + ! Check if the short radii were set correctly, if the case + + ioerr = 0 + do i = 1, ntotat + if ( use_short_radius(i) ) then + if ( short_radius(i) >= radius(i) ) then + write(*,*) ' ERROR: The short radius must be smaller than the default radius. ' + write(*,*) ' (the default radius is one half of the default tolerance).' + stop exit_code_input_error + end if + end if + end do + + ! If there are no variables (only fixed molecules, stop) + + if(n.eq.0) then + call output(n,x) + write(*,dash1_line) + write(*,*) ' There are only fixed molecules, therefore there is nothing to do. ' + write(*,*) ' The output file contains the fixed molecules in the desired positions. ' + write(*,dash1_line) + write(*,*) ' Wrote output file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + write(*,dash1_line) + stop exit_code_input_error + end if + + ! + ! (Re)setting parameters and building initial point + ! + + call initial(n,x) + + ! Computing the energy at the initial point + + radscale = 1.d0 + do i = 1, ntotat + radius_ini(i) = radius(i) + end do + call computef(n,x,all_type_fx) + write(*,*) ' Objective function at initial point: ', all_type_fx + fprint = all_type_fx + do i = 1, n + xprint(i) = x(i) + end do + + ! Stop if only checking the initial approximation + + if(check) then + call output(n,x) + write(*,*) ' Wrote initial point to output file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + stop + end if + + ! + ! Main loop: first pack types of molecules separately, then + ! pack all molecules together + ! + + call swaptype(n,x,itype,0) ! Save all-molecule vector data + itype = 0 + main : do while(itype <= ntype) + itype = itype + 1 + if ( packall ) itype = ntype + 1 + + ! Use larger tolerance than required to improve separation + + radscale = discale + do i = 1, ntotat + radius(i) = discale*radius_ini(i) + end do + + ! Set vectors for specific or all-molecule packing + + if ( itype <= ntype ) then + call swaptype(n,x,itype,1) ! Set vectors to pack only this type of molecule + else + call swaptype(n,x,itype,3) ! Restore all-molecule vectors + end if + + ! Print titles + + write(*,hash3_line) + if ( itype <= ntype ) then + write(*,*) ' Packing molecules of type: ', input_itype(itype) + else + write(*,*) ' Packing all molecules together ' + end if + write(*,hash3_line) + + ! Checking if first approximation is a solution + + call computef(n,x,fx) + + if ( fdist < precision .and. frest < precision ) then + + write(*,*) + write(*,*) ' Initial approximation is a solution. Nothing to do. ' + write(*,*) + call swaptype(n,x,itype,3) ! Restore all-molecule vectors + call output(n,x) + if( itype == ntype + 1 ) then + write(*,*) ' Solution written to file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + else + write(*,*) ' Current point written to file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + end if + call writesuccess(itype,fdist,frest,fx) + + ! Otherwise, pack the molecules + + else + + loop = -1 + + ! Initializing parameters relative to the improvement of the function + fimp = 1.d99 + fimprov = fimp + do i = 1, ntotat + radiuswork(i) = radius(i) + radius(i) = radius_ini(i) + end do + call computef(n,x,fx) + do i = 1, ntotat + radius(i) = radiuswork(i) + end do + bestf = fx + flast = fx + + gencanloop : do while(loop.lt.nloop) + loop = loop + 1 + + ! Moving bad molecules + if(radscale == 1.d0 .and. fimp.le.10.d0) then + movebadprint = .true. + call movebad(n,x,fx,movebadprint) + flast = fx + end if + + + write(*,dash3_line) + write(*,*) ' Starting GENCAN loop: ', loop + write(*,*) ' Scaling radii by: ', radscale + write(*,*) + + ! CALL GENCAN + + write(*,prog1_line) + call pgencan(n,x,fx) + + ! + ! Compute the statistics of the last optimization loop + ! + + ! Use the user-specified radii for statistics + + do i = 1, ntotat + radiuswork(i) = radius(i) + radius(i) = radius_ini(i) + end do + call computef(n,x,fx) + + if(bestf.gt.0.d0) fimprov = -100.d0 * (fx - bestf) / bestf + if(bestf.eq.0.d0) fimprov = 100.d0 + if(flast.gt.0.d0) fimp = -100.d0 * (fx - flast) / flast + if(flast.eq.0.d0) fimp = 100.d0 + fimp = dmin1(99.99d0,dmax1(-99.99d0,fimp)) + fimprov = dmin1(99.99d0,dmax1(-99.99d0,fimprov)) + + write(*,"(/& + &' Function value from last GENCAN loop: f = ', e10.5, /& + &' Best function value before: f = ', e10.5, /& + &' Improvement from best function value: ', f8.2, ' %',/& + &' Improvement from last loop: ', f8.2, ' %', /& + &' Maximum violation of target distance: ', f12.6, /& + &' Maximum violation of the constraints: ', e10.5 & + &)") fx, bestf, fimprov, fimp, fdist, frest + flast = fx + + ! + ! Analysis of final loop packing and output data + ! + + if ( itype <= ntype ) then + + ! Save best function value for this packing + + if ( fx < bestf ) bestf = fx + + ! Check if this point is a solution + + call swaptype(n,x,itype,2) ! Save this type current point + ! If the solution was found for this type + if( fdist < precision .and. frest < precision ) then + call swaptype(n,x,itype,3) ! Restore all molecule vectors + call output(n,x) + write(*,*) ' Current structure written to file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + call writesuccess(itype,fdist,frest,fx) + exit gencanloop + end if + + ! Compute and report function value for all-type packing + + call swaptype(n,x,itype,3) ! Restore all molecule vectors + call computef(n,x,all_type_fx) + write(*,"(' All-type function value: ', e10.5 )") all_type_fx + + else + + call computef(n,x,fx) + all_type_fx = fx + if ( fx < bestf ) bestf = fx + ! If solution was found for all system + if ( fdist < precision .and. frest < precision ) then + call output(n,x) + call writesuccess(itype,fdist,frest,fx) + write(*,*) ' Solution written to file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + write(*,dash3_line) + exit main + end if + + end if + write(*,dash3_line) + + ! If this is the best structure so far + if( mod(loop+1,writeout) == 0 .and. all_type_fx < fprint ) then + call output(n,x) + write(*,*) ' Current solution written to file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + fprint = all_type_fx + do i = 1, n + xprint(i) = x(i) + end do + + ! If the user required printing even bad structures + else if ( mod(loop+1,writeout) == 0 .and. writebad ) then + call output(n,x) + write(*,*) ' Writing current (perhaps bad) structure to file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + end if + + ! Restore vector for packing this type of molecule, if the case + + if ( itype <= ntype ) then + call swaptype(n,x,itype,0) ! Reset type vectors + call swaptype(n,x,itype,1) ! Set vector for molecules of this type + call computef(n,x,fx) + end if + + ! Restore the working radii + + do i = 1, ntotat + radius(i) = radiuswork(i) + end do + if ( radscale > 1.d0 ) then + if( ( fdist < precision .and. fimp < 10.d0 ) .or. & + fimp < 2.d0 ) then + radscale = dmax1(0.9*radscale,1.d0) + do i = 1, ntotat + radius(i) = dmax1(radius_ini(i),0.9d0*radius(i)) + end do + end if + end if + + if(loop.eq.nloop) then + if ( itype .eq. ntype+1 ) then + write(*,*)' STOP: Maximum number of GENCAN loops achieved.' + call checkpoint(n,xprint) + exit_code = exit_code_failed_to_converge + exit main + else + write(*,*)' Maximum number of GENCAN loops achieved.' + end if + end if + + end do gencanloop + + end if + + end do main + + write(*,*) ' Running time: ', etime(tarray) - time0,' seconds. ' + write(*,dash3_line) + write(*,*) + + ! Fortran < 2008 doesn't support non-constant exit codes + if (exit_code == 0) then + stop + elseif (exit_code == exit_code_failed_to_converge) then + stop exit_code_failed_to_converge + else + stop exit_code_general_error + end if + +end program packmol + diff --git a/fpm.toml b/fpm.toml new file mode 100644 index 0000000..66169ff --- /dev/null +++ b/fpm.toml @@ -0,0 +1,19 @@ +name = "packmol" +version = "0.1.0" +license = "license" +author = "" +maintainer = "" +copyright = "" + +[build] +auto-executables = true +auto-tests = true +auto-examples = true + +[[executable]] +name = "packmol" +source-dir = "app" +main = "packmol.f90" + +[install] +library = false diff --git a/src/ahestetic.f90 b/src/ahestetic.f90 new file mode 100644 index 0000000..ed231f6 --- /dev/null +++ b/src/ahestetic.f90 @@ -0,0 +1,21 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Module that contains some ahestetic output definitions +! +module ahestetic + + character(len=13), parameter :: dash1_line = "( 80('-') )",& + dash2_line = "(/,80('-') )",& + dash3_line = "(/,80('-'),/)" + + character(len=13), parameter :: hash1_line = "( 80('#') )",& + hash2_line = "(/,80('#') )",& + hash3_line = "(/,80('#'),/)" + + character(len=31), parameter :: prog1_line = "(' Packing:|0 ',tr60,'100%|' )",& + prog2_line = "(' Moving:|0 ',tr60,'100%|' )" + +end module ahestetic diff --git a/src/cenmass.f90 b/src/cenmass.f90 new file mode 100644 index 0000000..00bb730 --- /dev/null +++ b/src/cenmass.f90 @@ -0,0 +1,103 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine cenmass +! +! Computes the center of mass of free molecules and +! for fixed molecules, if required. +! +subroutine cenmass() + + use sizes + use compute_data, only : ntype, coor, idfirst, natoms + use input, only : keyword, amass, nlines, linestrut + + implicit none + integer :: k, iline + integer :: itype, iatom, idatom + double precision, allocatable :: cm(:,:), totm(:) + logical, allocatable :: domass(:) + + ! Allocate local vectors + + allocate(cm(ntype,3),totm(ntype),domass(ntype)) + + ! Setting the molecules for which the center of mass is computed + + do itype = 1, ntype + domass(itype) = .true. + end do + + do iline = 1, nlines + if(keyword(iline,1).eq.'fixed') then + do itype = 1, ntype + if(iline.gt.linestrut(itype,1).and. & + iline.lt.linestrut(itype,2)) then + domass(itype) = .false. + end if + end do + end if + end do + + do iline = 1, nlines + if(keyword(iline,1).eq.'centerofmass'.or. & + keyword(iline,1).eq.'center') then + do itype = 1, ntype + if(iline.gt.linestrut(itype,1).and. & + iline.lt.linestrut(itype,2)) then + domass(itype) = .true. + end if + end do + end if + end do + + ! Computing the center of mass + + do itype = 1, ntype + do k = 1, 3 + cm(itype, k) = 0.d0 + end do + end do + + do itype = 1, ntype + totm(itype) = 0.d0 + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + totm(itype) = totm(itype) + amass(idatom) + end do + end do + + do itype = 1, ntype + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + do k = 1, 3 + cm(itype, k) = cm(itype, k) + coor(idatom, k)*amass(idatom) + end do + end do + do k = 1, 3 + cm(itype, k) = cm(itype, k) / totm(itype) + end do + end do + + ! Putting molecules in their center of mass + + do itype = 1, ntype + if(domass(itype)) then + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + do k = 1, 3 + coor(idatom, k) = coor(idatom, k) - cm(itype, k) + end do + end do + end if + end do + + deallocate(cm,totm,domass) + + return +end subroutine cenmass diff --git a/src/checkpoint.f90 b/src/checkpoint.f90 new file mode 100644 index 0000000..a40b625 --- /dev/null +++ b/src/checkpoint.f90 @@ -0,0 +1,116 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! + +! +! Subroutine that writes the last point obtained when +! a solution was not found +! + +subroutine checkpoint(n,x) + + use sizes + use compute_data + use input + use usegencan + use ahestetic + + implicit none + integer :: i + integer :: n + double precision :: x(n) + double precision :: fx + logical :: movebadprint + character(len=strl) :: xyzout_forced + + ! All molecules are important + + do i = 1, ntfix + comptype(i) = .true. + end do + + ! Call the subroutine that computes de function value + + call computef(n,x,fx) + + write(*,dash3_line) + write(*,"(& + &' Packmol was not able to find a solution to your',/,& + &' packing problem with the desired distance tolerance.',/,/,& + &' First of all, be sure if the molecules fit in the',/,& + &' regions specified and if the constraints were set',/,& + &' correctly. ',/,/,& + &' Secondly, try simply running it again with a different ',/,& + &' seed for the random number generator of the initial ',/,& + &' point. This is done by adding the keyword seed to the',/,& + &' input file, as in: ',/,/,& + &' seed 192911 ',/,/,& + &' The best configuration found has a function value of',/,& + &' f = ', e14.7,/,/,& + &' IMPORTANT: ',/,& + &' If the number of molecules and the restraints are',/,& + &' correct, it is still very likely that the current point',/,& + &' fits your needs if your purpose is to run a MD',/,& + &' simulation.',/,& + &' Therefore, we recommend to minimize the energy of the',/,& + &' solution found, equilibrate it and run with it as well.',/& + &)") fx + write(*,dash3_line) + + call output(n,x) + + write(*,*) ' The solution with the best function value was ' + write(*,*) ' written to the output file: ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + write(*,dash1_line) + write(*,*) ' Forcing the solution to fit the constraints...' + + ! CALL GENCAN + + init1 = .true. + do i = 1, nloop + iprint1 = 0 + iprint2 = 0 + call pgencan(n,x,fx) + movebadprint = .false. + call movebad(n,x,fx,movebadprint) + end do + init1 = .false. + + write(*,*) + write(*,dash1_line) + xyzout_forced = trim(adjustl(xyzout))//'_FORCED' + call output(n,x) + + write(*,*) ' The forced point was writen to the ' + write(*,*) ' output file: ', trim(adjustl(xyzout_forced)) + if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) + write(*,*) + write(*,*) ' If you want that the packing procedure continues' + write(*,*) ' for a longer time, add the following keyword ' + write(*,*) ' to the input file: ' + write(*,*) + write(*,*) ' nloop [integer] (ex: nloop 200) ' + write(*,*) + write(*,*) ' The default nloop value is 50 for each molecule.' + write(*,*) + + write(*,hash1_line) + write(*,*) ' ENDED WITHOUT PERFECT PACKING: ' + write(*,*) ' The output file:' + write(*,*) + write(*,*) ' ', trim(adjustl(xyzout)) + if ( crd ) write(*,*) ' (... and to CRD file: ', trim(adjustl(crdfile)), ')' + write(*,*) + write(*,*) ' contains the best solution found. ' + write(*,*) + write(*,*) ' Very likely, if the input data was correct, ' + write(*,*) ' it is a reasonable starting configuration.' + write(*,*) ' Check commentaries above for more details. ' + write(*,hash1_line) + + return +end subroutine checkpoint + diff --git a/src/comparegrad.f90 b/src/comparegrad.f90 new file mode 100644 index 0000000..19c6fdb --- /dev/null +++ b/src/comparegrad.f90 @@ -0,0 +1,98 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! + +! +! Subroutine that performs finite difference and analytical gradient +! comparision. Used only for test purpouses +! + +subroutine comparegrad(n,x) + + use sizes + implicit none + + integer :: n, i, iworst + double precision :: x(n), fx, step, gcomp, gbest, eworst, & + error, steperror, stepbest + double precision, allocatable :: g(:) + real :: time0, tarray(2), etime + + ! Allocate local array + + allocate(g(nn)) + + write(*,*) + write(*,*) ' Comparing analytical and finite-difference ' + write(*,*) ' gradients... may take a while. ' + write(*,*) + write(*,*) ' Five first center of masses and angles of tested point: ' + do i = 1, 15, 3 + write(*,"( i4,6(tr2,f8.3) )") (i+2)/3, x(i), x(i+1), x(i+2), x(n/2+i),& + x(n/2+i+1),x(n/2+i+2) + end do + write(*,*) + write(*,*) ' Computing gradient ... ' + + call computef(n,x,fx) + write(*,*) ' Function value on test point: ', fx + open(98, file = 'chkgrad.log',status='unknown') + write(98, *)'Function Value = ', fx + call computeg(n,x,g) + + write(98,"( t2,'Component',t16,'Analytical',t33,'Discrete', & + &t51,'Error',t62,'Best step' )") + time0 = etime(tarray) + eworst = 0.d0 + do i = 1, n + if(etime(tarray)-time0.gt.10.) then + time0 = etime(tarray) + write(*,*) ' Computing the ',i,'th of ',n,' components. Worst error: ', eworst + end if + error = 1.d20 + step = 1.d-2 + do while(error.gt.1.d-6.and.step.ge.1.d-20) + call discret(i,n,x,gcomp,step) + if(dmin1(abs(g(i)),abs(gcomp)).gt.1.d-10) then + steperror = abs( ( gcomp - g(i) ) / g(i) ) + else + steperror = abs( gcomp - g(i) ) + end if + if( steperror .lt. error ) then + error = steperror + gbest = gcomp + stepbest = step + end if + step = step / 10.d0 + end do + write(98,"(i10,5(tr2,d13.7))") i, g(i), gbest, error, stepbest + if(error.gt.eworst) then + iworst = i + eworst = error + end if + end do + write(98,*) 'Maximum difference = ', iworst,' Error= ', eworst + write(*,*) ' Done. ' + stop + +end subroutine comparegrad + +subroutine discret(icomp,n,x,gcomp,step) + + implicit none + integer :: n, icomp + double precision :: save, step, x(n), fplus, fminus, gcomp + + save = x(icomp) + x(icomp) = save + step + call computef(n,x,fplus) + x(icomp) = save - step + call computef(n,x,fminus) + gcomp = (fplus - fminus) / (2.d0 * step) + x(icomp) = save + + return +end subroutine discret + diff --git a/src/comprest.f90 b/src/comprest.f90 new file mode 100644 index 0000000..72addb3 --- /dev/null +++ b/src/comprest.f90 @@ -0,0 +1,168 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! +! Subroutine comprest: Compute the function value relative to +! to the restrictions for one atom +! + +subroutine comprest(icart,f) + + use sizes + use compute_data, only : xcart, restpars, scale, scale2, nratom, ityperest, iratom + + implicit none + integer :: iratcount, irest, icart + double precision :: xmin, ymin, zmin, clength, a1, a2, a3, a4, w, b1, b2, b3, d, a5, a6 + double precision :: f + double precision :: xmax, ymax, zmax + double precision :: v1, v2, v3 + double precision :: vnorm + + f = 0.d0 + do iratcount = 1, nratom(icart) + irest = iratom(icart,iratcount) + if(ityperest(irest).eq.2) then + clength = restpars(irest,4) + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,1) + clength + ymax = restpars(irest,2) + clength + zmax = restpars(irest,3) + clength + a1 = dmin1(xcart(icart,1) - xmin, 0.d0) + a2 = dmin1(xcart(icart,2) - ymin, 0.d0) + a3 = dmin1(xcart(icart,3) - zmin, 0.d0) + f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) + a1 = dmax1(xcart(icart,1) - xmax, 0.d0) + a2 = dmax1(xcart(icart,2) - ymax, 0.d0) + a3 = dmax1(xcart(icart,3) - zmax, 0.d0) + f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) + else if(ityperest(irest).eq.3) then + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,4) + ymax = restpars(irest,5) + zmax = restpars(irest,6) + a1 = dmin1(xcart(icart,1) - xmin, 0.d0) + a2 = dmin1(xcart(icart,2) - ymin, 0.d0) + a3 = dmin1(xcart(icart,3) - zmin, 0.d0) + f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) + a1 = dmax1(xcart(icart,1) - xmax, 0.d0) + a2 = dmax1(xcart(icart,2) - ymax, 0.d0) + a3 = dmax1(xcart(icart,3) - zmax, 0.d0) + f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) + else if(ityperest(irest).eq.4) then + w = (xcart(icart,1)-restpars(irest,1))**2 + & + (xcart(icart,2)-restpars(irest,2))**2 + & + (xcart(icart,3)-restpars(irest,3))**2 - & + restpars(irest,4)**2 + a1 = dmax1(w,0.d0) + f = f + scale2*a1*a1 + else if(ityperest(irest).eq.5) then + a1 = (xcart(icart,1)-restpars(irest,1))**2 / restpars(irest,4)**2 + a2 = (xcart(icart,2)-restpars(irest,2))**2 / restpars(irest,5)**2 + a3 = (xcart(icart,3)-restpars(irest,3))**2 / restpars(irest,6)**2 + a4 = restpars(irest,7)**2 + w = a1 + a2 + a3 - a4 + a1 = dmax1(w,0.d0) + f = f + scale2*a1*a1 + else if(ityperest(irest).eq.6) then + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,1) + restpars(irest,4) + ymax = restpars(irest,2) + restpars(irest,4) + zmax = restpars(irest,3) + restpars(irest,4) + a1 = dmax1(xcart(icart,1) - xmin,0.d0) + a2 = dmax1(xcart(icart,2) - ymin,0.d0) + a3 = dmax1(xcart(icart,3) - zmin,0.d0) + a4 = dmax1(xmax - xcart(icart,1),0.d0) + a5 = dmax1(ymax - xcart(icart,2),0.d0) + a6 = dmax1(zmax - xcart(icart,3),0.d0) + f = f + a1*a2*a3*a4*a5*a6 + else if(ityperest(irest).eq.7) then + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,4) + ymax = restpars(irest,5) + zmax = restpars(irest,6) + a1 = dmax1(xcart(icart,1) - xmin,0.d0) + a2 = dmax1(xcart(icart,2) - ymin,0.d0) + a3 = dmax1(xcart(icart,3) - zmin,0.d0) + a4 = dmax1(xmax - xcart(icart,1),0.d0) + a5 = dmax1(ymax - xcart(icart,2),0.d0) + a6 = dmax1(zmax - xcart(icart,3),0.d0) + f = f + a1*a2*a3*a4*a5*a6 + else if(ityperest(irest).eq.8) then + w = (xcart(icart,1)-restpars(irest,1))**2 + & + (xcart(icart,2)-restpars(irest,2))**2 + & + (xcart(icart,3)-restpars(irest,3))**2 - & + restpars(irest,4)**2 + a1 = dmin1(w,0.d0) + f = f + scale2*a1*a1 + else if(ityperest(irest).eq.9) then + a1 = (xcart(icart,1)-restpars(irest,1))**2 / restpars(irest,4)**2 + a2 = (xcart(icart,2)-restpars(irest,2))**2 / restpars(irest,5)**2 + a3 = (xcart(icart,3)-restpars(irest,3))**2 / restpars(irest,6)**2 + a4 = restpars(irest,7)**2 + w = a1 + a2 + a3 - a4 + a1 = dmin1(w,0.d0) + f = f + a1*a1 + else if(ityperest(irest).eq.10) then + w = restpars(irest,1)*xcart(icart,1) + & + restpars(irest,2)*xcart(icart,2) + & + restpars(irest,3)*xcart(icart,3) - & + restpars(irest,4) + a1 = dmin1(w,0.d0) + f = f + scale * a1*a1 + else if(ityperest(irest).eq.11) then + w = restpars(irest,1)*xcart(icart,1) + & + restpars(irest,2)*xcart(icart,2) + & + restpars(irest,3)*xcart(icart,3) - & + restpars(irest,4) + a1 = dmax1(w,0.d0) + f = f + scale * a1*a1 + else if(ityperest(irest).eq.12) then + a1 = xcart(icart,1) - restpars(irest,1) + a2 = xcart(icart,2) - restpars(irest,2) + a3 = xcart(icart,3) - restpars(irest,3) + vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 + restpars(irest,6)**2) + v1 = restpars(irest,4)/vnorm + v2 = restpars(irest,5)/vnorm + v3 = restpars(irest,6)/vnorm + b1 = v1 * a1 + b2 = v2 * a2 + b3 = v3 * a3 + w = b1 + b2 + b3 + d = ( a1 - v1*w )**2 + ( a2 - v2*w )**2 + ( a3 - v3*w )**2 + f = f + scale2 * ( & + dmax1(-w , 0.d0)**2 + & + dmax1(w - restpars(irest,9), 0.d0)**2 + & + dmax1(d - restpars(irest,7)**2 , 0.d0 )**2 ) + else if(ityperest(irest).eq.13) then + a1 = xcart(icart,1) - restpars(irest,1) + a2 = xcart(icart,2) - restpars(irest,2) + a3 = xcart(icart,3) - restpars(irest,3) + vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 + restpars(irest,6)**2) + v1 = restpars(irest,4)/vnorm + v2 = restpars(irest,5)/vnorm + v3 = restpars(irest,6)/vnorm + b1 = v1 * a1 + b2 = v2 * a2 + b3 = v3 * a3 + w = b1 + b2 + b3 + d = ( a1 - v1*w )**2 +( a2 - v2*w )**2 + ( a3 - v3*w )**2 + f = f + scale2 * ( & + dmin1(-w , 0.d0)**2 * & + dmin1(w - restpars(irest,9), 0.d0)**2 * & + dmin1(d - restpars(irest,7)**2 , 0.d0 )**2 ) + end if + end do + return +end subroutine comprest + diff --git a/src/compute_data.f90 b/src/compute_data.f90 new file mode 100644 index 0000000..655dc63 --- /dev/null +++ b/src/compute_data.f90 @@ -0,0 +1,63 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +module compute_data + + use sizes + + integer :: ntotmol, ntype, natfix, ntotat + integer :: nboxes(3), nb2(3) + + integer, allocatable :: nmols(:) ! (ntype) + integer, allocatable :: natoms(:) ! (ntype) + integer, allocatable :: idfirst(:) ! (ntype) + integer, allocatable :: nratom(:) ! (ntotat) + integer, allocatable :: iratom(:,:) ! (ntotat,mrperatom) + integer, allocatable :: ityperest(:) ! (maxrest) + integer, allocatable :: ibmol(:) ! (ntotat) + integer, allocatable :: ibtype(:) ! (ntotat) + + double precision :: scale, scale2 + double precision :: fdist, frest + double precision :: sizemin(3), sizemax(3) + double precision :: boxl(3) + + double precision, allocatable :: xcart(:,:) ! (ntotat,3) + double precision, allocatable :: coor(:,:) ! (ntotat,3) + double precision, allocatable :: restpars(:,:) ! (maxrest,9) + double precision, allocatable :: rot_bound(:,:,:) ! (ntype,3,2) + double precision, allocatable :: radius(:), radius_ini(:), fscale(:) ! (ntotat) + double precision, allocatable :: short_radius(:), short_radius_scale(:) ! ntotat + double precision, allocatable :: gxcar(:,:) ! (ntotat,3) + + double precision, allocatable :: fdist_atom(:), frest_atom(:) ! (ntotat) + double precision, allocatable :: dmax(:) ! (ntype) + double precision, allocatable :: cmxmin(:), cmymin(:), cmzmin(:) ! (ntype) + double precision, allocatable :: cmxmax(:), cmymax(:), cmzmax(:) ! (ntype) + + logical, allocatable :: constrain_rot(:,:) ! (ntype,3) + logical, allocatable :: comptype(:) ! (ntype) + logical, allocatable :: fixedatom(:) ! (ntotat) + logical, allocatable :: use_short_radius(:) ! ntotat + logical :: init1, move + + ! For linked lists + integer, allocatable :: latomnext(:) ! (ntotat) + integer, allocatable :: latomfirst(:,:,:) ! (0:nbp+1,0:nbp+1,0:nbp+1) + integer, allocatable :: latomfix(:,:,:) ! (0:nbp+1,0:nbp+1,0:nbp+1) + + ! For movebad + double precision, allocatable :: fmol(:), radiuswork(:) ! (ntotat) + + ! For restmol + double precision, allocatable :: xmol(:) ! (nn) + logical, allocatable :: compsafe(:) ! (ntype) + + ! For boxes with atoms linked lists + integer :: lboxfirst + integer, allocatable :: lboxnext(:) ! ((nbp+2)**3) + logical, allocatable :: hasfree(:,:,:) ! (0:nbp+1,0:nbp+1,0:nbp+1) + +end module compute_data diff --git a/src/computef.f90 b/src/computef.f90 new file mode 100644 index 0000000..e01890b --- /dev/null +++ b/src/computef.f90 @@ -0,0 +1,220 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine that computes the function value +! + +subroutine computef(n,x,f) + + use sizes + use compute_data + use input, only : fix + implicit none + + integer :: n, i, j, k, ibox + integer :: ilugan, ilubar, icart, itype, imol, iatom, idatom, & + iboxx, iboxy, iboxz + + double precision :: v1(3), v2(3), v3(3) + double precision :: x(n) + double precision :: f,fparc,fplus + double precision :: xtemp, ytemp, ztemp + double precision :: xbar, ybar, zbar + double precision :: beta, gama, teta + + ! Reset function value + + f = 0.d0 + frest = 0.d0 + fdist = 0.d0 + + ! Reset boxes + + if(.not.init1) call resetboxes() + + ! Transform baricenter and angles into cartesian coordinates + ! Computes cartesian coordinates from vector x and coor + + ilubar = 0 + ilugan = ntotmol*3 + icart = 0 + + do itype = 1, ntype + if(.not.comptype(itype)) then + icart = icart + nmols(itype)*natoms(itype) + else + do imol = 1, nmols(itype) + + xbar = x(ilubar+1) + ybar = x(ilubar+2) + zbar = x(ilubar+3) + + ! Computing the rotation matrix + + beta = x(ilugan+1) + gama = x(ilugan+2) + teta = x(ilugan+3) + + call eulerrmat(beta,gama,teta,v1,v2,v3) + + ! Looping over the atoms of this molecule + + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + + icart = icart + 1 + idatom = idatom + 1 + + ! Computing the cartesian coordinates for this atom + + call compcart(icart,xbar,ybar,zbar, & + coor(idatom,1),coor(idatom,2),coor(idatom,3), & + v1,v2,v3) + + ! Adding to f the value relative to constraints for this atom + + call comprest(icart,fplus) + f = f + fplus + frest = dmax1(frest,fplus) + if(move) frest_atom(icart) = frest_atom(icart) + fplus + + ! Putting atoms in their boxes + + if(.not.init1) then + + xtemp = xcart(icart,1) - sizemin(1) + ytemp = xcart(icart,2) - sizemin(2) + ztemp = xcart(icart,3) - sizemin(3) + + iboxx = int(xtemp/boxl(1)) + 1 + iboxy = int(ytemp/boxl(2)) + 1 + iboxz = int(ztemp/boxl(3)) + 1 + + if(xtemp.le.0) iboxx = 1 + if(ytemp.le.0) iboxy = 1 + if(ztemp.le.0) iboxz = 1 + if(iboxx.gt.nboxes(1)) iboxx = nboxes(1) + if(iboxy.gt.nboxes(2)) iboxy = nboxes(2) + if(iboxz.gt.nboxes(3)) iboxz = nboxes(3) + + ! Atom linked list + + latomnext(icart) = latomfirst(iboxx,iboxy,iboxz) + latomfirst(iboxx,iboxy,iboxz) = icart + + ! Box with atoms linked list + + if ( .not. hasfree(iboxx,iboxy,iboxz) ) then + hasfree(iboxx,iboxy,iboxz) = .true. + call ijk_to_ibox(iboxx,iboxy,iboxz,ibox) + lboxnext(ibox) = lboxfirst + lboxfirst = ibox + + ! Add boxes with fixed atoms which are vicinal to this box, and + ! are behind + + if ( fix ) then + + call add_box_behind(iboxx-1,iboxy,iboxz) + call add_box_behind(iboxx,iboxy-1,iboxz) + call add_box_behind(iboxx,iboxy,iboxz-1) + + call add_box_behind(iboxx,iboxy-1,iboxz+1) + call add_box_behind(iboxx,iboxy-1,iboxz-1) + call add_box_behind(iboxx-1,iboxy+1,iboxz) + call add_box_behind(iboxx-1,iboxy,iboxz+1) + call add_box_behind(iboxx-1,iboxy-1,iboxz) + call add_box_behind(iboxx-1,iboxy,iboxz-1) + + call add_box_behind(iboxx-1,iboxy+1,iboxz+1) + call add_box_behind(iboxx-1,iboxy+1,iboxz-1) + call add_box_behind(iboxx-1,iboxy-1,iboxz+1) + call add_box_behind(iboxx-1,iboxy-1,iboxz-1) + + end if + + end if + + ibtype(icart) = itype + ibmol(icart) = imol + + end if + + end do + + ilugan = ilugan + 3 + ilubar = ilubar + 3 + + end do + end if + end do + + if(init1) return + + ! Minimum distance function evaluation + + ibox = lboxfirst + do while( ibox > 0 ) + + call ibox_to_ijk(ibox,i,j,k) + + icart = latomfirst(i,j,k) + do while( icart > 0 ) + + if(comptype(ibtype(icart))) then + + ! Interactions inside box + + f = f + fparc(icart,latomnext(icart)) + + ! Interactions of boxes that share faces + + f = f + fparc(icart,latomfirst(i+1,j,k)) + f = f + fparc(icart,latomfirst(i,j+1,k)) + f = f + fparc(icart,latomfirst(i,j,k+1)) + + ! Interactions of boxes that share axes + + f = f + fparc(icart,latomfirst(i+1,j+1,k)) + f = f + fparc(icart,latomfirst(i+1,j,k+1)) + f = f + fparc(icart,latomfirst(i+1,j-1,k)) + f = f + fparc(icart,latomfirst(i+1,j,k-1)) + f = f + fparc(icart,latomfirst(i,j+1,k+1)) + f = f + fparc(icart,latomfirst(i,j+1,k-1)) + + ! Interactions of boxes that share vertices + + f = f + fparc(icart,latomfirst(i+1,j+1,k+1)) + f = f + fparc(icart,latomfirst(i+1,j+1,k-1)) + f = f + fparc(icart,latomfirst(i+1,j-1,k+1)) + f = f + fparc(icart,latomfirst(i+1,j-1,k-1)) + + end if + + icart = latomnext(icart) + end do + + ibox = lboxnext(ibox) + end do + + return +end subroutine computef + +subroutine add_box_behind(i,j,k) + + use sizes + use compute_data + implicit none + integer :: ibox, i, j, k + + if ( .not. hasfree(i,j,k) .and. latomfix(i,j,k) /= 0 ) then + hasfree(i,j,k) = .true. + call ijk_to_ibox(i,j,k,ibox) + lboxnext(ibox) = lboxfirst + lboxfirst = ibox + end if + +end subroutine add_box_behind + diff --git a/src/computeg.f90 b/src/computeg.f90 new file mode 100644 index 0000000..9139183 --- /dev/null +++ b/src/computeg.f90 @@ -0,0 +1,309 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine that computes the analytical derivatives +! + +subroutine computeg(n,x,g) + + use sizes + use compute_data + use input, only : fix + implicit none + + integer :: n + integer :: idatom, iatom, irest + integer :: i, j, k, ilubar, ilugan, icart, itype, imol + integer :: ibox, iboxx, iboxy, iboxz + integer :: k1, k2 + integer :: iratcount + + double precision :: x(n), g(n) + double precision :: dv1beta(3), dv1gama(3), dv1teta(3),& + dv2beta(3), dv2gama(3), dv2teta(3),& + dv3beta(3), dv3gama(3), dv3teta(3) + double precision :: v1(3), v2(3), v3(3) + double precision :: xbar, ybar, zbar + double precision :: xtemp, ytemp, ztemp + double precision :: beta, gama, teta, cb, sb, cg, sg, ct, st + + ! Reset gradients + + do i = 1, ntotat + do j = 1, 3 + gxcar(i,j) = 0.d0 + end do + end do + + ! Reset boxes + + if(.not.init1) call resetboxes() + + ! Transform baricenter and angles into cartesian coordinates + + ! Computes cartesian coordinates from vector x and coor + + ilubar = 0 + ilugan = ntotmol*3 + icart = 0 + + do itype = 1, ntype + + if(.not.comptype(itype)) then + icart = icart + nmols(itype)*natoms(itype) + else + do imol = 1, nmols(itype) + + xbar = x(ilubar + 1) + ybar = x(ilubar + 2) + zbar = x(ilubar + 3) + + ! Compute the rotation matrix + + beta = x(ilugan + 1) + gama = x(ilugan + 2) + teta = x(ilugan + 3) + + call eulerrmat(beta,gama,teta,v1,v2,v3) + + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + + icart = icart + 1 + idatom = idatom + 1 + + call compcart(icart,xbar,ybar,zbar, & + coor(idatom,1),coor(idatom,2),coor(idatom,3), & + v1,v2,v3) + + ! Gradient relative to the wall distace + + do iratcount = 1, nratom(icart) + irest = iratom(icart,iratcount) + call gwalls(icart,irest) + end do + + if(.not.init1) then + xtemp = xcart(icart,1) - sizemin(1) + ytemp = xcart(icart,2) - sizemin(2) + ztemp = xcart(icart,3) - sizemin(3) + + iboxx = int(xtemp/boxl(1)) + 1 + iboxy = int(ytemp/boxl(2)) + 1 + iboxz = int(ztemp/boxl(3)) + 1 + + if(xtemp.le.0) iboxx = 1 + if(ytemp.le.0) iboxy = 1 + if(ztemp.le.0) iboxz = 1 + if(iboxx.gt.nboxes(1)) iboxx = nboxes(1) + if(iboxy.gt.nboxes(2)) iboxy = nboxes(2) + if(iboxz.gt.nboxes(3)) iboxz = nboxes(3) + + ! Atom linked list + + latomnext(icart) = latomfirst(iboxx,iboxy,iboxz) + latomfirst(iboxx,iboxy,iboxz) = icart + + ! Box with atoms linked list + + if ( .not. hasfree(iboxx,iboxy,iboxz) ) then + hasfree(iboxx,iboxy,iboxz) = .true. + call ijk_to_ibox(iboxx,iboxy,iboxz,ibox) + lboxnext(ibox) = lboxfirst + lboxfirst = ibox + + ! Add boxes with fixed atoms which are vicinal to this box, and + ! are behind + + if ( fix ) then + + call add_box_behind(iboxx-1,iboxy,iboxz) + call add_box_behind(iboxx,iboxy-1,iboxz) + call add_box_behind(iboxx,iboxy,iboxz-1) + + call add_box_behind(iboxx,iboxy-1,iboxz+1) + call add_box_behind(iboxx,iboxy-1,iboxz-1) + call add_box_behind(iboxx-1,iboxy+1,iboxz) + call add_box_behind(iboxx-1,iboxy,iboxz+1) + call add_box_behind(iboxx-1,iboxy-1,iboxz) + call add_box_behind(iboxx-1,iboxy,iboxz-1) + + call add_box_behind(iboxx-1,iboxy+1,iboxz+1) + call add_box_behind(iboxx-1,iboxy+1,iboxz-1) + call add_box_behind(iboxx-1,iboxy-1,iboxz+1) + call add_box_behind(iboxx-1,iboxy-1,iboxz-1) + + end if + + end if + + ibtype(icart) = itype + ibmol(icart) = imol + end if + + end do + ilugan = ilugan + 3 + ilubar = ilubar + 3 + end do + end if + end do + + if( .not. init1 ) then + + ! + ! Gradient relative to minimum distance + ! + + ibox = lboxfirst + do while( ibox > 0 ) + + call ibox_to_ijk(ibox,i,j,k) + + icart = latomfirst(i,j,k) + do while ( icart .ne. 0 ) + + if(comptype(ibtype(icart))) then + + ! Interactions inside box + + call gparc(icart,latomnext(icart)) + + ! Interactions of boxes that share faces + + call gparc(icart,latomfirst(i+1,j,k)) + call gparc(icart,latomfirst(i,j+1,k)) + call gparc(icart,latomfirst(i,j,k+1)) + + ! Interactions of boxes that share axes + + call gparc(icart,latomfirst(i+1,j+1,k)) + call gparc(icart,latomfirst(i+1,j,k+1)) + call gparc(icart,latomfirst(i+1,j-1,k)) + call gparc(icart,latomfirst(i+1,j,k-1)) + call gparc(icart,latomfirst(i,j+1,k+1)) + call gparc(icart,latomfirst(i,j+1,k-1)) + + ! Interactions of boxes that share vertices + + call gparc(icart,latomfirst(i+1,j+1,k+1)) + call gparc(icart,latomfirst(i+1,j+1,k-1)) + call gparc(icart,latomfirst(i+1,j-1,k+1)) + call gparc(icart,latomfirst(i+1,j-1,k-1)) + + end if + + icart = latomnext(icart) + end do + + ibox = lboxnext(ibox) + end do + + end if + + ! Computing the gradient using chain rule + + do i = 1, n + g(i) = 0.d0 + end do + + k1 = 0 + k2 = ntotmol * 3 + + icart = 0 + do itype = 1, ntype + + if(.not.comptype(itype)) then + icart = icart + nmols(itype)*natoms(itype) + else + do imol = 1, nmols(itype) + + beta = x(k2 + 1) + gama = x(k2 + 2) + teta = x(k2 + 3) + + cb = dcos(beta) + sb = dsin(beta) + cg = dcos(gama) + sg = dsin(gama) + ct = dcos(teta) + st = dsin(teta) + + dv1beta(1) = - cb * sg * ct - sb * cg + dv2beta(1) = - sb * sg * ct + cb * cg + dv3beta(1) = 0.d0 + + dv1gama(1) = - sb * cg * ct - cb * sg + dv2gama(1) = cb * cg * ct - sb * sg + dv3gama(1) = cg * st + + dv1teta(1) = sb * sg * st + dv2teta(1) = - cb * sg * st + dv3teta(1) = sg * ct + + dv1beta(2) = - cb * cg * ct + sb * sg + dv2beta(2) = - sb * cg * ct - cb * sg + dv3beta(2) = 0.d0 + + dv1gama(2) = sb * sg * ct - cb * cg + dv2gama(2) = - sg * cb * ct - cg * sb + dv3gama(2) = - sg * st + + dv1teta(2) = sb * cg * st + dv2teta(2) = - cb * cg * st + + dv3teta(2) = cg * ct + + dv1beta(3) = cb * st + dv2beta(3) = sb * st + dv3beta(3) = 0.d0 + + dv1gama(3) = 0.d0 + dv2gama(3) = 0.d0 + dv3gama(3) = 0.d0 + + dv1teta(3) = sb * ct + dv2teta(3) = - cb * ct + dv3teta(3) = - st + + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + + icart = icart + 1 + idatom = idatom + 1 + + do k = 1, 3 + g(k1+k) = g(k1+k) + gxcar(icart, k) + end do + + do k = 1, 3 + g(k2 + 1) = g(k2 + 1) & + + (coor(idatom,1) * dv1beta(k) & + + coor(idatom, 2) * dv2beta(k) & + + coor(idatom, 3) * dv3beta(k)) & + * gxcar(icart, k) + + g(k2 + 2) = g(k2 + 2) & + + (coor(idatom,1) * dv1gama(k) & + + coor(idatom, 2) * dv2gama(k) & + + coor(idatom, 3) * dv3gama(k)) & + * gxcar(icart, k) + + g(k2 + 3) = g(k2 + 3) & + + (coor(idatom,1) * dv1teta(k) & + + coor(idatom, 2) * dv2teta(k) & + + coor(idatom, 3) * dv3teta(k)) & + * gxcar(icart, k) + end do + + end do + k2 = k2 + 3 + k1 = k1 + 3 + end do + end if + end do + + return +end subroutine computeg + diff --git a/src/exit_codes.f90 b/src/exit_codes.f90 new file mode 100644 index 0000000..29114d5 --- /dev/null +++ b/src/exit_codes.f90 @@ -0,0 +1,18 @@ +! +! Written by Alexandr Fonari, 2022. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! + +module exit_codes + + IMPLICIT NONE + + ! Codes 1, 2, 126 – 165 and 255 have special meaning + integer, parameter :: exit_code_success = 0 + integer, parameter :: exit_code_general_error = 170 + integer, parameter :: exit_code_input_error = 171 + integer, parameter :: exit_code_open_file = 172 + integer, parameter :: exit_code_failed_to_converge = 173 + +end module exit_codes diff --git a/src/flashmod.f90 b/src/flashmod.f90 new file mode 100644 index 0000000..84aaa74 --- /dev/null +++ b/src/flashmod.f90 @@ -0,0 +1,21 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! + +! +! Arrays required by the flashsort package. Used only in heuristics, but +! defined here to be allocated dynamically +! + +module flashsort + + use sizes + implicit none + integer, allocatable :: indflash(:) ! (ntotat) + integer, allocatable :: lflash(:) ! (ntotat) + integer :: mflash + +end module flashsort + diff --git a/src/flashsort.f90 b/src/flashsort.f90 new file mode 100644 index 0000000..0112e3c --- /dev/null +++ b/src/flashsort.f90 @@ -0,0 +1,95 @@ +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! c +! Subroutine Flash1 c +! SORTS ARRAY A WITH N ELEMENTS BY USE OF INDEX VECTOR L c +! OF DIMENSION M WITH M ABOUT 0.1 N. c +! Karl-Dietrich Neubert, FlashSort1 Algorithm c +! in Dr. Dobb's Journal Feb.1998,p.123 c +! c +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + subroutine flash1 (A, N, L, M, ind) + + implicit none + double precision :: a(*), anmin, c1, hold, flash + integer :: L(*), ind(*), i, n, nmax, m, k, ihold, nmove, j, iflash +! ============================ CLASS FORMATION ===== + + + do i = 1, n + ind(i) = i + end do + + ANMIN=A(1) + NMAX=1 + DO I=1,N + IF( A(I).LT.ANMIN) ANMIN=A(I) + IF( A(I).GT.A(NMAX)) NMAX=I + END DO + + IF (ANMIN.EQ.A(NMAX)) RETURN + C1=(M - 1) / (A(NMAX) - ANMIN) + DO K=1,M + L(K)=0 + END DO + DO I=1,N + K=1 + INT(C1 * (A(I) - ANMIN)) + L(K)=L(K) + 1 + END DO + DO K=2,M + L(K)=L(K) + L(K - 1) + END DO + HOLD=A(NMAX) + A(NMAX)=A(1) + A(1)=HOLD + + ihold = ind(nmax) + ind(nmax) = ind(1) + ind(1) = ihold + + +! =============================== PERMUTATION ===== + NMOVE=0 + J=1 + K=M + DO WHILE (NMOVE.LT.N - 1) + DO WHILE (J.GT.L(K)) + J=J + 1 + K=1 + INT(C1 * (A(J) - ANMIN)) + END DO + FLASH=A(J) + iflash=ind(j) + + DO WHILE (.NOT.(J.EQ.L(K) + 1)) + K=1 + INT(C1 * (FLASH - ANMIN)) + HOLD=A(L(K)) + ihold = ind(L(k)) + A(L(K))=FLASH + ind(L(k)) = iflash + iflash = ihold + FLASH=HOLD + L(K)=L(K) - 1 + NMOVE=NMOVE + 1 + END DO + END DO + +! ========================= STRAIGHT INSERTION ===== + DO I=N-2,1,-1 + IF (A(I + 1).LT.A(I)) THEN + HOLD=A(I) + ihold = ind(i) + J=I + DO WHILE (A(J + 1).LT.HOLD) + A(J)=A(J + 1) + ind(j) = ind(j+1) + J=J + 1 + END DO + A(J)=HOLD + ind(j) = ihold + ENDIF + END DO + +! =========================== RETURN,END FLASH1 ===== + RETURN + END + diff --git a/src/fparc.f90 b/src/fparc.f90 new file mode 100644 index 0000000..2b876c3 --- /dev/null +++ b/src/fparc.f90 @@ -0,0 +1,77 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Function that computes the atom-to-atom component of the objective +! function +! + +double precision function fparc(icart,firstjcart) + + use sizes + use compute_data + implicit none + + ! SCALAR ARGUMENTS + integer :: icart,firstjcart + + ! LOCAL SCALARS + integer :: jcart + double precision :: datom, tol, short_tol, short_tol_penalty, short_tol_scale + + fparc = 0.0d0 + jcart = firstjcart + do while ( jcart > 0 ) + ! + ! Cycle if this type is not to be computed + ! + if ( .not. comptype(ibtype(jcart))) then + jcart = latomnext(jcart) + cycle + end if + ! + ! Cycle if the atoms are from the same molecule + ! + if ( ibmol(icart) == ibmol(jcart) .and. & + ibtype(icart) == ibtype(jcart) ) then + jcart = latomnext(jcart) + cycle + end if + ! + ! Cycle if both atoms are from fixed molecules + ! + if ( fixedatom(icart) .and. fixedatom(jcart) ) then + jcart = latomnext(jcart) + cycle + end if + ! + ! Otherwise, compute distance and evaluate function for this pair + ! + datom = ( xcart(icart,1)-xcart(jcart,1) )**2 + & + ( xcart(icart,2)-xcart(jcart,2) )**2 + & + ( xcart(icart,3)-xcart(jcart,3) )**2 + tol = (radius(icart)+radius(jcart))**2 + if ( datom < tol ) then + fparc = fparc + fscale(icart)*fscale(jcart)*(datom-tol)**2 + if ( use_short_radius(icart) .or. use_short_radius(jcart) ) then + short_tol = (short_radius(icart)+short_radius(jcart))**2 + if ( datom < short_tol ) then + short_tol_penalty = datom-short_tol + short_tol_scale = dsqrt(short_radius_scale(icart)*short_radius_scale(jcart)) + short_tol_scale = short_tol_scale*(tol**2/short_tol**2) + fparc = fparc + fscale(icart)*fscale(jcart)*short_tol_scale*short_tol_penalty**2 + end if + end if + end if + tol = (radius_ini(icart)+radius_ini(jcart))**2 + fdist = dmax1(tol-datom,fdist) + if ( move ) then + fdist_atom(icart) = dmax1(tol-datom,fdist_atom(icart)) + fdist_atom(jcart) = dmax1(tol-datom,fdist_atom(jcart)) + end if + jcart = latomnext(jcart) + end do + +end function fparc + diff --git a/src/gencan.f b/src/gencan.f new file mode 100644 index 0000000..3f98f10 --- /dev/null +++ b/src/gencan.f @@ -0,0 +1,6006 @@ +C ***************************************************************** +C ***************************************************************** + + subroutine evalal(n,x,m,lambda,rho,f,flag) + +C This subroutine computes the objective function when GENCAN is +C being used stand-alone to solve a unique bound-constrained problem. +C When GENCAN is being used in an Augmented Lagrangian framework, +C this subroutine must compute the Augmented Lagrangian function. +C +C On Entry: +C +C n integer, +C number of variables, +C +C x double precision x(n), +C current point, +C +C m integer, +C number of constraints (equalities plus inequalities), +C +C lambda double precision lambdae(m), +C current estimation of the Lagrange multipliers, +C +C rho double precision rho(m) +C penalty parameters, +C +C NOTE: arguments m, lambda and rho are useful when GENCAN is being used +C for solving the box-constrained subproblems of an Augmented Lagrangian +C framework. When GENCAN is being used stand-alone for solving a bound- +C constrained problem, these arguments are dummy arguments. +C +C On Return +C +C f double precision, +C objective function value at x, +C +C flag integer +C 0 means "no errors", +C 1 means "some error occurs in the objective funtion evaluation". + + implicit none + +C SCALAR ARGUMENTS + integer flag,m,n + double precision f + +C ARRAY ARGUMENTS + double precision lambda(m),rho(m),x(n) + +C LOCAL SCALARS + + flag = 0 + + call computef(n,x,f) + + end + +C ***************************************************************** +C ***************************************************************** + + subroutine evalnal(n,x,m,lambda,rho,g,flag) + +C This subroutine computes the gradient of the objective function +C when GENCAN is being used stand-alone to solve a unique bound- +C constrained problem. When GENCAN is being used in an Augmented +C Lagrangian framework, this subroutine must compute the gradient of +C Augmented Lagrangian. +C +C On Entry: +C +C n integer, +C number of variables, +C +C x double precision x(n), +C current point, +C +C m integer, +C number of constraints (equalities plus inequalities), +C +C lambda double precision lambdae(m), +C current estimation of the Lagrange multipliers, +C +C rho double precision rho(m) +C penalty parameters, +C +C NOTE: arguments m, lambda and rho are useful when GENCAN is being used +C for solving the box-constrained subproblems of an Augmented Lagrangian +C framework. When GENCAN is being used stand-alone for solving a bound- +C constrained problem, these arguments are dummy arguments. +C +C On Return +C +C g double precision g(n), +C gradient of the objective function at x, +C +C flag integer +C 0 means "no errors", +C 1 means "some error occurs in the gradient evaluation". + + implicit none + +C SCALAR ARGUMENTS + integer flag,m,n + +C ARRAY ARGUMENTS + double precision g(n),lambda(m),rho(m),x(n) + +C LOCAL SCALARS + + flag = 0 + + call computeg(n,x,g) + + end + +C ***************************************************************** +C ***************************************************************** + +c Modified by L. Martinez (there was an error on the number of +c parameters when calling this subroutine). This subroutine does +c nothing. +c subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) + + subroutine evalhd(n) + +C This subroutine computes the product of the Hessian matrix times +C the input vector argument d. If GENCAN is being used stand-alone +C to solve a bound-constrained problem, the ''Hessian matrix'' must +C be the Hessian matrix of the objective function. On the other hand, +C if GENCAN is being used to solve the bound-constrained subproblems +C in an Augmented Lagrangian framework, the Hessian matrix must be +C the Hessian of the Augmented Lagrangian function. +C +C IMPORTANT: This subroutine does not need to be coded if the user +C prefers to approximate the Hessian-vector product by incremental +C quotients. In this case, it is enough to set the GENCAN input +C argument htvtype equal to 1 and an internal GENCAN subroutine will +C be used to compute the approximation. In fact, this is the default +C GENCAN option. See the GENCAN and EASYGENCAN arguments descriptions +C for details. +C +C On Entry: +C +C nind integer +C number of component of the Hessian-vector product that +C must be computed, +C +C ind integer ind(nind) +C the component that must be computed are ind(1)-th ... ind(nind)-th, +C +C n integer, +C number of variables, +C +C x double precision x(n), +C current point, +C +C m integer, +C number of constraints (equalities plus inequalities), +C +C lambda double precision lambdae(m), +C current estimation of the Lagrange multipliers, +C +C rho double precision rho(m) +C penalty parameters, +C +C d double precision d(n) +C vector of the Hessian-vector product. +C +C NOTE: arguments m, lambda and rho are useful when GENCAN is being used +C for solving the box-constrained subproblems of an Augmented Lagrangian +C framework. When GENCAN is being used stand-alone for solving a bound- +C constrained problem, these arguments are dummy arguments. +C +C On Return +C +C hd double precision g(n), +C Hessian-vector product, +C +C flag integer +C 0 means "no errors", +C 1 means "some error occurs in the gradient evaluation". + + implicit none + +C SCALAR ARGUMENTS +c integer flag,m,n,nind + integer n + +C ARRAY ARGUMENTS +c integer ind(nind) +c double precision d(n),hd(n),lambda(m),rho(m),x(n) + +c flag = - 1 + + end + +C************************************************************************** + +C Last update of EASYGENCAN: February 18th, 2005. + + subroutine easygencan(n,x,l,u,m,lambda,rho,epsgpsn,maxit,maxfc, + +trtype,iprint,ncomp,f,g,gpsupn,iter,fcnt,gcnt,cgcnt,inform,wi,wd, + +delmin) + + implicit none + +C SCALAR ARGUMENTS + integer cgcnt,fcnt,gcnt,m,maxfc,maxit,n,ncomp,inform,iprint,iter + double precision epsgpsn,f,gpsupn + +C ARRAY ARGUMENTS + integer wi(n) + double precision g(n),l(n),lambda(m),rho(m),u(n),wd(8*n),x(n) + +C This subroutine aims to simplify the use of GENCAN. For this +C purpose it gives values to most of the GENCAN arguments and +C leaves to the user those arguments which he/she may would like to +C set by him/herself. +C +C The arguments of EASYGENCAN are the input and output arguments of +C GENCAN that are supposed to be useful for a common user. The input +C arguments are mostly related to basic problem information, like +C dimension and bounds, and the initial point. There are also input +C arguments related to simple stopping criteria (like norm of the +C projected gradient, and maximum number of iterations and +C functional evaluations). There are also two input arguments +C related to control the amount of information written into the +C screen. The output arguments are related to information of the +C solution and some few performance measurements. Basically, on +C return, EASYGENCAN gives to the user the solution, the objective +C functional value and its gradient at the solution, Euclidian and +C sup-norm of the projected gradient at the solution, the number of +C iterations, functional and gradient evaluations, and Conjugate +C Gradient iterations used to reach the solution, and, finally, a +C flag that indicates the stopping criterion that was satisfied. +C +C All the other arguments of GENCAN are setted with its default +C values by EASYGENCAN. EASYGENCAN divides the arguments of GENCAN +C in two sets. Those that are related to the behaviour of GENCAN are +C declared as Fortran parameters (constants). The other arguments of +C GENCAN, most of them related to alternative stopping criteria, and +C that may depend of, for example, maxit, are declared as local +C variables of EASYGENCAN. +C +C GENCAN arguments that are defined as Fortran parameters in this +C subroutine are GENCAN arguments that should not be modified by a +C common user. They are arguments that modify the behaviour of +C GENCAN and whos values were selected because they are classical +C values in some cases or because some numerical experiments seemed +C to indicate that they are the best choices. +C +C GENCAN arguments that are declared as local variables in this +C subroutine are GENCAN arguments that may be modified if, with +C their suggested values, GENCAN does not give the desired result. +C Most of them are related to Conjugate Gradients or to disabled +C stopping criteria that may be useful in bad-scaled problems or +C problems with not trustable derivatives. +C +C Finally, this subroutine declares as local variables some +C arguments of GENCAN which in fact are output arguments. Most of +C them are related to quantities that can be used for statistics +C related to the GENCAN performance, like number Spectral Projected +C Gradient iterations, Truncated Newton iterations, Conjugate +C Gradient iterations, etc. As we assume that this values are not +C useful for the common user, this subroutine throw all of them +C away. +C +C We describe below the meaning of the arguments of the EASYGENCAN +C subroutine. More detailed descriptions as well as the descriptions +C of all the other GENCAN arguments that are not arguments of +C EASYGENCAN are also described at the begining of the GENCAN +C subroutine. +C +C On entry: +C +C n integer +C number of variables +C +C x double precision x(n) +C initial estimation of the solution +C +C l double precision l(n) +C lower bounds on the variables +C +C u double precision u(n) +C upper bounds on the variables +C +C m integer +C lambda double precision lambda(m) +C rho double precision rho(m) +C These three parameters are not used nor modified by +C GENCAN and they are passed as arguments to the user- +C defined subroutines evalal and evalnal to compute the +C objective function and its gradient, respectively. +C Clearly, in an Augmented Lagrangian context, if GENCAN is +C being used to solve the bound-constrainted subproblems, m +C would be the number of constraints, lambda the Lagrange +C multipliers approximation and rho the penalty parameters +C +C epsgpsn double precision +C GENCAN stops declaring convergence if it finds a point +C whos projected gradient sup-norm is smaller than or equal +C to epsgpsn +C +C maxit integer +C GENCAN stops declaring ''maximum number of iteration +C achieved'' if the number of iterations exceeds maxit +C +C maxfc integer +C the same as before but with the number of functional +C evaluations +C +C iprint integer +C indicates the degree of details of the output generated +C by GENCAN. Setting iprint to a value smaller than 2 will +C make GENCAN to generate no output at all. An iprint value +C greater than or equal to 2 will generate information of +C every GENCAN iteration. An iprint value greater than or +C equal to 3 will also show information of the Conjugate +C Gradient iterations (used to compute the Truncated Newton +C direction) and also information related to the line +C search procedures in the Spectral Projected Gradient +C direction and the Truncated Newton direction. +C +C ncomp integer +C Sometimes, vectors like the current point x, the gradient +C of the objective function g, or the search directions +C (Spectral Projected Gradient direction or Truncated +C Newton direction), among other vector, are showed in the +C screen. In such cases, if the problem dimension is large, +C to show just a few elements of these vectors may be +C preferable. Argument ncomp can be used to indicate how +C many array elements must be displayed. +C +C wi integer wi(n) +C integer working space +C +C wd double precision wd(8*n) +C double precision working space +C +C On return: +C +C x double precision x(n) +C estimation of the solution +C +C f double precision +C objective function value at the solution +C +C g double precision g(n) +C gradient of the objective function at the solution +C +C gpsupn double precision +C sup-norm of the continuous projected gradient +C +C iter integer +C number of iterations used to reach the solution +C +C fcnt integer +C number of functional evaluations +C +C gcnt integer +C number of gradient evaluations +C +C cgcnt integer +C number of Conjugate Gradient iterations +C +C inform integer +C termination criteria. inform equal to 1 means that +C GENCAN converged with the sup-norm of the continuous +C projected gradient stopping criterion (inform equal to 0 +C means the same but with the Euclidian norm). Other +C positive values means that GENCAN stopped by a may be not +C successful stopping criteria. A negative value means that +C there was an error in the user-defined subroutines that +C computes the objective function (subroutine evalal), the +C gradient (subroutine evalnal), or the Hessian-vector +C product (subroutine evalhd). See the GENCAN description +C for more details. + +C HERE STARTS THE DESCRIPTION OF SOME GENCAN ARGUMENTS THAT ARE +C BEING SETTED INSIDE EASYGENCAN. THE FIRST SET OF ARGUMENTS ARE +C THOSE ARGUMENTS THAT WE WILL CALL ''CONSTANTS'' AND THAT, AS THEIR +C VALUES ALTER THE BEHAVIOUR OF GENCAN, SHOULD NOT BE MODIFIED BY A +C COMMON USER. + +C CONSTANTS FOR GENERAL USES + +C Steps: h = max( steabs, sterel * abs( x ) ) should be a number +C such that h is small ( relatively to x ) and x + h is different +C from x. So, h is something that can be used a a step for a finite +C differences approximation of a partial derivative relative to x. + +C Epsilons: something smaller than max( epsabs, epsrel * abs( x ) ) +C should be considered as ``zero'' when compared with x. It is used, +C for example, to detect that a step taken during a line search is +C too small. + +C Infinitys: infrel is a big number that may appear in the +C calculations. infabs is a number that should never be reached in +C the calculations and is used the represent ``infinite''. Detailed +C explanations of how are they used are rather cumbersome. + + double precision steabs,sterel,epsabs,epsrel,infabs,infrel + parameter ( steabs = 1.0d-10 ) + parameter ( sterel = 1.0d-07 ) + parameter ( epsabs = 1.0d-20 ) + parameter ( epsrel = 1.0d-10 ) + parameter ( infabs = 1.0d+99 ) + parameter ( infrel = 1.0d+20 ) + +C CONSTANTS FOR CLASSICAL LINE-SEARCH CONDITIONS + +C beta is the constant for the ''beta condition''. We use this +C condition to test whether is promising to extrapolate or not. + +C gamma is the constant for the sufficient decrease ''Armijo +C condition''. + +C theta is the constant for the ''angle condition''. + +C sigma1 and sigma2 are the constants for the safeguarding quadratic +C interpolations. We use them in a rather unusual way. Instead of +C discarding a new step anew if it does not belong to the interval +C [ sigma1 * aprev, sigma2 * aprev ], we discard it if it does not +C belong to the interval [ sigma1, sigma2 * aprev ]. In such a case +C we take something similar to ''anew = aprev / 2''. + + double precision beta,gamma,theta,sigma1,sigma2 + parameter ( beta = 0.5d0 ) + parameter ( gamma = 1.0d-04 ) + parameter ( theta = 1.0d-06 ) + parameter ( sigma1 = 0.1d0 ) + parameter ( sigma2 = 0.9d0 ) + +C CONSTANTS FOR SPECIFIC PROCEDURES (NOT SO CLASSICAL) + +C In line searches, when interpolating, the step may become so +C small that we should declare a line search failure indicating that +C direction may not be a descent direction. This decision is never +C take before doing at least mininterp interpolations. + +C In line searches, the beta condition (see above) may recommend to +C extrapolate. We never do more than maxextrap extrapolations. + +C In the line searches, when we need to interpolate and the result +C of the quadratic interpolation is rejected, the new step is +C computed as anew = aprev / nint. When the beta condition +C recommends to extrapolate, we compute anew = aprev * next. + +C When computing the Newton direction by Conjugate Gradients we +C never go further an artificial ''trust region''. This ''trust +C radius'' is never smaller than delmin. + +C In active set strategies, constants eta is used to decide whether +C the current face should be abandoned or not. In particular, the +C current face is abandoned when the norm of the internal to face +C component of the continuous projected gradient is smaller than +C ( 1 - eta ) times the norm of the continuous projected gradient. +C In this way, values of eta near 1 makes the method to work hard +C inside the faces and values of eta near 0 makes the method to +C abandon the faces very quickly. + +C We always use as a first step in a line search procedure along a +C first order direction the spectral steplength. This steplength +C must belong to the interval [lspgmi,lspgma]. + + integer maxextrap,mininterp + parameter ( maxextrap = 100 ) + parameter ( mininterp = 4 ) + + double precision nint,next,delmin,eta,lspgma,lspgmi + parameter ( nint = 2.0d0 ) + parameter ( next = 2.0d0 ) +c parameter ( delmin = 1.d4 ) + parameter ( eta = 0.9d0 ) + parameter ( lspgma = 1.0d+10 ) + parameter ( lspgmi = 1.0d-10 ) + +C DIMENSIONS FOR SOME WORKING SPACES + +C In non-monotone line searches, given p, the last p objective +C functional values must be stored. For this reason we declare a +C vector with pmax double precision elements. So p must be less than +C or equal to pmax. + +C Sometimes, is the problem is bad scaled, to request a small +C gradient norm at the solution may be inadequate. For this reason, +C a test to verify if this norm is not decreasing during maxitngp +C (MAXimum of ITerations with No Gradient Progress) consecutive +C iterations then we stop the method with a warning. As it is not +C expected a monotone decreasing of the gradient norm, again, the +C norm of the last maxitngp iterations must be saved. For this +C purpose, we declare a vector of tmax elements. So maxitngp must +C be less than or equal to tmax. + + integer tmax + parameter ( tmax = 10000 ) + +C HERE STARTS THE DESCRIPTION OF THE OTHER ARGUMENTS OF GENCAN BEING +C SETTED BY EASYGENCAN. THESE ARGUMENTS MAY BE MODIFIED BY A COMMON +C USER IF, WITH THEIR SUGGESTED VALUES, GENCAN DOES NOT GIVE THE +C EXPECTED RESULT. + +C GENCAN INPUT ARGUMENTS THAT WILL BE SETTED BELOW + + logical nearlyq + + integer cgmaxit,cgscre,gtype,htvtype,maxitnfp,maxitngp,maxitnqmp, + + trtype + + double precision cgepsf,cgepsi,cggpnf,delta0,epsgpen,epsnfp, + + epsnqmp,fmin + +C GENCAN OUTPUT ARGUMENTS THAT WILL BE DISCARDED + + integer spgfcnt,spgiter,tnexbcnt,tnexgcnt,tnexbfe,tnexgfe,tnfcnt, + + tnintcnt,tnintfe,tniter,tnstpcnt + + double precision gpeucn2 + +C GENCAN WORKING VECTORS (WHICH DIMENSION IS NOT RELATED TO THE +C PROBLEM DIMENSION) + + double precision lastgpns(tmax) + +C ARGUMENTS RELATED TO DERIVATIVES CALCULATIONS + +C gtype indicates in which way the gradient of the objective +C function will be computed. If the user have been implemented the +C user-supplied evalnal subroutine to compute the gradient of the +C objective function then gtype argument must be set to 0 (ZERO) and +C the user-supplied evalnal subroutine will be called by GENCAN any +C time the gradient would be required. +C +C The prototype of the evalnal subroutine must be: +C +C subroutine evalnal(n,x,m,lambda,rho,nal,flag) +C +C SCALAR ARGUMENTS +C integer n,m,flag +C +C ARRAY ARGUMENTS +C double precision x(n),lambda(m),rho(m),nal(n) +C +C ''Here must be written the subroutine body that calculates the +C n-dimensional gradient vector of the objective function +C evaluated at x and saves it in nal. It also must set flag to 0 +C (ZERO) if the gradient was successfully computed and to any +C other value if the gradient vector is not well defined at the +C required point x. If GENCAN is been used stand-alone to solve +C a unique bound-constrained problem then m, lambda and rho are +C dummy arguments. On the other hand, if GENCAN is been used in +C an Augmented Lagrangian framework then these arguments should +C be used for the number of constraints, the Lagrange +C multipliers approximation and the penalty parameters, +C respectively.'' +C +C end +C +C If, on the other hand, the user is not able to provide evalnal +C subroutine, gtype argument must be set to 1 (ONE). In this case, +C every time GENCAN needs to compute the gradient of the objective +C function, an internal subroutine that approximates it by finite- +C differences will be used (be aware that it maybe very time +C consuming). Moreover, note that the evalnal subroutine must still +C be present (with an empty body). + + gtype = 0 + +C htvtype indicates in which way the product of the Hessian of the +C objective function times an arbitrary vector will be computed. If +C the user has not been implemented the user-supplied evalhd +C subroutine to do this task then htvtype argument must be set to 1 +C (ONE). In this case an internal subroutine that approximates this +C product by incremental quotients will be used. Note that, even in +C this case, evalhd subroutine must be present (with an empty body). +C This is the default option and the empty-body subroutine follows: +C +C subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) +C +C SCALAR ARGUMENTS +C integer nind,n,m,flag +C +C ARRAY ARGUMENTS +C integer ind(nind) +C double precision d(n),hd(n),lambda(m),rho(m),x(n) +C +C flag = - 1 +C +C end +C +C If, on the other hand, the user prefers to implement his/her own +C evalhd subroutine then htvtype argument must be set to 0 (ZERO). +C In this case, the product of the Hessian times vector d (input +C argument of evalhd subroutine) must be saved in vector hd (output +C argument of evalhd subroutine). The other arguments description as +C well as some hints on how to implement your own evalhd subroutine +C can be found in the GENCAN arguments description. + +C When ALGENCAN uses GENCAN to solve the subproblems in the classical +C Augmented Lagrangian framework, ALGENCAN uses its own evalhd +C subroutine to overcome the lack of continuity of the second +C derivatives. So, when GENCAN is being used toghether with ALGENCAN, +C htvtype must be equal to 0 (ZERO). On the other hand, if GENCAN is +C being used stand-alone, just set htvtype equal to 1 (ONE) and add +C the empty-body subroutine described above. + + htvtype = 1 + +C ARGUMENTS RELATED TO STOPPING CRITERIA + +C Besides the stopping criterion related to the sup-norm of the +C continuous projected gradient, there is another stopping criterion +C related to its Euclidian norm. So, GENCAN stops the process if it +C finds a point at which the Euclidian norm of the continuous +C projected gradient is smaller than epsgpen. + + epsgpen = 0.0d0 + +C For an explanation of maxitngp see above the explanation of tmax +C in ''DIMENSIONS FOR SOME WORKING SPACES''. Just note that the +C value of maxitngp must be less than or equal to tmax. + + maxitngp = tmax + +C maxitnfp means MAXimum of allowed number of iterations with No +C Progress in the objective functional value. ''Progress'' from one +C iteration to the next one refers to ( fnew - fprev ). Since the +C begining of the algorithm we save the ''best progress'' and +C consider that there was no progress in an iteration if the +C progress of this iterations was smaller than epsnfp times the best +C progress. Finally, the algorithm stops if there was no progress +C during maxitnfp consecutive iterations. + + maxitnfp = maxit + epsnfp = 0.0d0 + +C There is a stopping criterion that stops the method if a point +C with a functional value smaller than fmin is found. The idea +C behind this stopping criterion is to stop the method if the +C objective function is not bounded from below. + + fmin = 1.0d-05 + +C ARGUMENTS RELATED TO CONJUGATE GRADIENTS + +C When computing the Truncated Newton direction by Conjugate +C Gradients there is something similar to a ''trust-region radius''. +C This trust radius is updated from iteration to iteration depending +C on the agreement of the objective function and its quadratic +C model. But an initial value for the trust radius is required. If +C the user has a good guess for this initial value then it should be +C passed to GENCAN using the delta0 arguments. On the other hand, if +C delta0 is set to -1, a default value depending on the norm of the +C current point will be used. + + delta0 = - 1.0d0 + delmin = 1.d-2 +c delta0 = delmin + +C The ''trust-region'' can be like a ball (using Euclidian norm) or +C like a box (using sup-norm). This choice can be made using trtype +C (TRust region TYPE) argument. trtype equal to 0 means Euclidian +C norm and trtype equal to 1 means sup-norm. + + trtype = 1 + +C When the method is far from the solution, it may be not useful to +C do a very large effort in computing the Truncated Newton direction +C precisely. To avoid it, a fixed maximum number of iterations for +C Conjugate Gradients can be given to GENCAN. If the user would like +C to choose this maximum number of iterations for Conjugate +C Gradient then it should use the cgmaxit arguments. On the other +C hand he/she prefers to leave this task to GENCAN then he/she +C should set cgmaxit to -1. + + cgmaxit = -1 + +C If the task of deciding the accuracy for computing the Truncated +C Newton direction is leaved to GENCAN then a default strategy based +C on increasing accuracies will be used. The proximity to the +C solution is estimated observing the norm of the projected gradient +C at the current point and locating it between that norm at the +C initial point and the expected value of that norm at the solution. +C Then the accuracy for the Truncated Newton direction of the +C current iteration will be computed taking a precision located in +C the same relative position with respect to two given values for +C the accuracies for the first and the last Truncated Newton +C direction calculations. These two accuracies (cgepsi and cgepsf, +C respectively) must be given by the user. Moreover, the expected +C value of the projected gradient norm at the solution (cggpnf) must +C also be given by the user who must indicate setting argument +C cgscre to 1 or 2 if that norm is the Euclidian or the sup-norm. + + cggpnf = max( 1.0d-04, max( epsgpen, epsgpsn ) ) + cgscre = 2 + cgepsi = 1.0d-01 + cgepsf = 1.0d-05 + +C The next two arguments are used for an alternative stopping +C criterion for Conjugate Gradients. Conjugate Gradients method is +C stopped if the quadratic model makes no progress during maxitnqmp +C (MAXimum of ITerations with No Quadratic Model Progress) +C consecutive iterations. In this context, ''no progress'' means +C that the progress is smaller than epsnqmp (EPSilon to measure the +C No Quadratic Model Progress) times the best progress obtained +C during the previous iterations. + + epsnqmp = 1.0d-04 + maxitnqmp = 5 + +C Depending on how much the objective function seems to be a +C quadratic, function, Conjugate Gradients may take different +C decision. So, if the objective function is a quadratic function or +C is very similar to a quadratic function then the nearlyq argument +C should be set to TRUE, else, it should be set to FALSE. However, +C the option with nearlyq equal TRUE never showed good results. +C Regarding this unexpected no good performance, rather recently it +C was found a bug that affected the behaviour of GENCAN just in this +C case (See the April 1st, 2003 modifications report at the end of +C this file). So, new experiments setting nearlyq equal TRUE should +C be made. + + nearlyq = .false. + +C FINALLY, CALL GENCAN + + call gencan(n,x,l,u,m,lambda,rho,epsgpen,epsgpsn,maxitnfp,epsnfp, + +maxitngp,fmin,maxit,maxfc,delta0,cgmaxit,cgscre,cggpnf,cgepsi, + +cgepsf,epsnqmp,maxitnqmp,nearlyq,nint,next,mininterp,maxextrap, + +gtype,htvtype,trtype,iprint,ncomp,f,g,gpeucn2,gpsupn,iter,fcnt, + +gcnt,cgcnt,spgiter,spgfcnt,tniter,tnfcnt,tnstpcnt,tnintcnt, + +tnexgcnt,tnexbcnt,tnintfe,tnexgfe,tnexbfe,inform,wd(1),wd(n+1), + +wd(2*n+1),wi,lastgpns,wd(3*n+1),eta,delmin,lspgma,lspgmi,theta, + +gamma,beta,sigma1,sigma2,sterel,steabs,epsrel,epsabs,infrel, + +infabs) + + end + +C ****************************************************************** +C ****************************************************************** + +C Last update of GENCAN or any of its dependencies: +C +C February 18th, 2005. +C +C See report of modifications at the end of this file. + + subroutine gencan(n,x,l,u,m,lambda,rho,epsgpen,epsgpsn,maxitnfp, + +epsnfp,maxitngp,fmin,maxit,maxfc,udelta0,ucgmaxit,cgscre,cggpnf, + +cgepsi,cgepsf,epsnqmp,maxitnqmp,nearlyq,nint,next,mininterp, + +maxextrap,gtype,htvtype,trtype,iprint,ncomp,f,g,gpeucn2,gpsupn, + +iter,fcnt,gcnt,cgcnt,spgiter,spgfcnt,tniter,tnfcnt,tnstpcnt, + +tnintcnt,tnexgcnt,tnexbcnt,tnintfe,tnexgfe,tnexbfe,inform,s,y,d, + +ind,lastgpns,w,eta,delmin,lspgma,lspgmi,theta,gamma,beta,sigma1, + +sigma2,sterel,steabs,epsrel,epsabs,infrel,infabs) + + implicit none + +C SCALAR ARGUMENTS + logical nearlyq + integer cgcnt,cgscre,fcnt,gcnt,gtype,htvtype,inform,iprint,iter,m, + + maxextrap,maxfc,maxit,maxitnfp,maxitngp,maxitnqmp, + + mininterp,n,ncomp,spgfcnt,spgiter,tnexbcnt,tnexbfe, + + tnexgcnt,tnexgfe,tnfcnt,tnintcnt,tnintfe,tniter,tnstpcnt, + + trtype,ucgmaxit + double precision beta,cgepsf,cgepsi,cggpnf,delmin,epsabs,epsgpen, + + epsgpsn,epsnfp,epsnqmp,epsrel,eta,f,fmin,gamma,gpeucn2, + + gpsupn,infabs,infrel,lspgma,lspgmi,next,nint,sigma1, + + sigma2,steabs,sterel,theta,udelta0 + +C ARRAY ARGUMENTS + integer ind(n) + double precision d(n),g(n),l(n),lambda(m),lastgpns(0:maxitngp-1), + + rho(m),s(n),u(n),w(5*n),x(n),y(n) + +C Solves the box-constrained minimization problem +C +C Minimize f(x) +C +C subject to +C +C l <= x <= u +C +C using a method described in +C +C E. G. Birgin and J. M. Martinez, ''Large-scale active-set box- +C constrained optimization method with spectral projected +C gradients'', Computational Optimization and Applications 23, pp. +C 101-125, 2002. +C +C Subroutine evalal must be supplied by the user to evaluate the +C objective function. The prototype of evalal subroutine must be +C +C subroutine evalal(n,x,m,lambda,rho,f,flag) +C +C C On Entry: +C C +C C n integer +C C number of variables +C C +C C x double precision x(n) +C C current point +C C +C C m integer +C C number of constraints (equalities plus inequalities) +C C +C C lambda double precision lambda(m) +C C current estimation of the Lagrange multipliers +C C +C C rho double precision rho(m) +C C penalty parameters +C C +C C NOTE: arguments m, lambda and rho are useful when GENCAN is +C C being used for solving the box-constrained subproblems of an +C C Augmented Lagrangian framework. When GENCAN is being used +C C stand-alone for solving a bound-constrained problem, these +C C arguments are dummy arguments and must be ignored. +C C +C C On Return +C C +C C f double precision +C C objective function value at x +C C +C C flag integer +C C 0 means ''no errors'' +C C any other value means ''there was an error in the +C C objective function calculation''. +C C +C C SCALAR ARGUMENTS +C integer flag,m,n +C double precision f +C +C C ARRAY ARGUMENTS +C double precision lambda(m),rho(m),x(n) +C +C C ''Here it should be the body of evalal subroutine that saves +C C in f the objective function value at x. Moreover, it sets +C C flag equal to 0 if the calculation was successfully done and +C C sets flag equal to any other value different from 0 if the +C C objective function is not well defined at the current point +C C x.'' +C +C end +C +C Subroutine evalnal to calculate the gradient of the objective +C function may be supplied by the user or not, depending on the +C value of gtype argument (gtype equal to 0 means that the evalnal +C subroutine will be supplied by the user and gtype equal to 1 means +C that an internal GENCAN subroutine will be used to estimate the +C gradient vector by central finite differences). In any case, a +C subroutine named evalnal with the following prototype must +C present. +C +C subroutine evalnal(n,x,m,lambda,rho,g,flag) +C +C C On Entry: +C +C C n integer +C C number of variables +C C +C C x double precision x(n) +C C current point +C C +C C m integer +C C number of constraints (equalities plus inequalities) +C C +C C lambda double precision lambda(m) +C C current estimation of the Lagrange multipliers +C C +C C rho double precision rho(m) +C C penalty parameters +C C +C C NOTE: arguments m, lambda and rho are useful when GENCAN is +C C being used for solving the box-constrained subproblems of an +C C Augmented Lagrangian framework. When GENCAN is being used +C C stand-alone for solving a bound-constrained problem, these +C C arguments are dummy arguments and must be ignored. +C C +C C On Return +C C +C C g double precision g(n) +C C gradient of the objective function at x +C C +C C flag integer +C C 0 means ''no errors'', +C C any other value means ''there was an error in the +C C gradient calculation''. +C C +C C SCALAR ARGUMENTS +C integer flag,m,n +C +C C ARRAY ARGUMENTS +C double precision g(n),lambda(m),rho(m),x(n) +C +C C ''Here it should be the body of evalnal subroutine that +C C saves in g the gradient vector of the objective function at +C C x. Moreover, it sets flag equal to 0 if the calculation was +C C successfully done and sets flag equal to any other value +C C different from 0 if the gradient vector is not well defined +C C at the current point x. If GENCAN gtype argument was setted +C C to 1, i.e., the finite difference approximation provided by +C C GENCAN will be used, then this subroutine must even be +C C present for compilation purpose but it will never be +C C called.'' +C +C end +C +C Subroutine evalhd to calculate of the Hessian of the objective +C function times a given vector may be supplied by the user or not, +C depending on the value of htvtype argument (htvtype equal to 0 +C means that the evalhd subroutine will be supplied by the user and +C htvtype equal to 1 means tha an internal GENCAN subroutine will be +C used to estimate the product by incremental quotients). In any +C case, a subroutine named evalhd with the following prototype must +C present. +C +C subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) +C +C C On Entry: +C C +C C nind integer +C C number of component of the Hessian-vector product that +C C must be computed +C C +C C ind integer ind(nind) +C C the component that must be computed are ind(1)-th ... +C C ind(nind)-th +C C +C C n integer +C C number of variables +C C +C C x double precision x(n) +C C current point +C C +C C m integer +C C number of constraints (equalities plus inequalities) +C C +C C lambda double precision lambda(m) +C C current estimation of the Lagrange multipliers +C C +C C rho double precision rho(m) +C C penalty parameters +C C +C C NOTE: arguments m, lambda and rho are useful when GENCAN is +C C being used for solving the box-constrained subproblems of an +C C Augmented Lagrangian framework. When GENCAN is being used +C C stand-alone for solving a bound-constrained problem, these +C C arguments are dummy arguments and must be ignored. +C C +C C d double precision d(n) +C C vector of the Hessian-vector product +C C +C C On Return +C C +C C hd double precision g(n) +C C Hessian-vector product +C C +C C flag integer +C C 0 means ''no errors'', +C C any other value means ''there was an error in the +C C product calculation''. Just as an example, as it has +C C no sense that an error occurs in a matrix-vector +C C product, the error could happen in the Hessian +C C calculation. But the possible errors will depend +C C on the way this Hessian-vector product is computed +C C or approximated. +C +C C SCALAR ARGUMENTS +C integer flag,m,n,nind +C +C C ARRAY ARGUMENTS +C integer ind(nind) +C double precision d(n),hd(n),lambda(m),rho(m),x(n) +C +C C ''Here it should be the body of evalhd subroutine that saves +C C in hd the product of the Hessian of the objective function +C C times vector d. Moreover, it sets flag equal to 0 if the +C C calculation was successfully done and sets flag equal to any +C C other value different from 0 if the Hessian matrix is not +C C well defined at the current point x. If GENCAN htvtype +C C argument was setted to 1, i.e., the incremental quotients +C C approximation provided by GENCAN will be used, then this +C C subroutine must even be present for compilation purposes +C C but it will never be called.'' +C +C end +C +C In evalhd subroutine, the information about the matrix H must be +C passed by means of common declarations. This subroutine must be +C coded by the user, taking into account that only nind components +C of d are nonnull and that ind is the set of indices of those +C components. In other words, the user must write evalhd in such a +C way that hd is the vector whose i-th entry is +C +C hd(i) = \Sum_{j=1}^{nind} H_{i,ind(j)} d_ind(j) +C +C Moreover, the only components of hd that must be computed are +C those which correspond to the indices ind(1),...,ind(nind). +C However, observe that it must be assumed that, in d, the whole +C dense vector is present, with its n components, even the null +C ones. So, if the user decides to code evalhd without taking into +C account the presence of ind and nind, it can be easily done. A +C final observation: probably, if nind is close to n, it is not +C worthwhile to use ind, due to the cost of accessing the correct +C indices. +C +C Example: Assume that H is dense. The main steps of evalhd could +C be: +C +C do i = 1,nind +C indi = ind(i) +C hd(indi) = 0.0d0 +C do j = 1,nind +C indj = ind(j) +C hd(indi) = hd(indi) + H(indi,indj) * d(indj) +C end do +C end do +C +C +C Description of the GENCAN arguments: +C +C On Entry +C +C n integer +C number of variables +C +C x double precision x(n) +C initial estimation of the solution +C +C l double precision l(n) +C lower bounds on the variables +C +C u double precision u(n) +C upper bounds on the variables +C +C m integer +C lambda double precision lambda(m) +C rho double precision rho(m) +C These three parameters are not used nor modified by +C GENCAN and they are passed as arguments to the user- +C defined subroutines evalal and evalnal to compute the +C objective function and its gradient, respectively. +C Clearly, in an Augmented Lagrangian context, if GENCAN is +C being used to solve the bound-constrainted subproblems, m +C would be the number of constraints, lambda the Lagrange +C multipliers approximation and rho the penalty parameters +C +C epsgpen double precision +C epsgpen means EPSilon for the Projected Gradient Euclidian +C Norm. It is a small positive number for declaring +C convergence when the Euclidian norm of the continuous +C projected gradient is less than or equal to epsgpen +C +C RECOMMENDED: epsgpen = 1.0d-05 +C +C CONSTRAINTS: epsgpen >= 0.0 +C +C epsgpsn double precision +C epsgpsn means EPSilon for the Projected Gradient Sup Norm. +C It is a small positive number for declaring convergence +C when the sup norm of the continuous projected gradient is +C less than or equal to epsgpsn +C +C RECOMMENDED: epsgpsn = 1.0d-05 +C +C CONSTRAINTS: epsgpsn >= 0.0 +C +C maxitnfp integer +C maxitnfp means MAXimum of ITerations with No Function +C Progress. See below for more details. +C +C epsnfp double precision +C epsnfp means EPSilon for No Function Progress. It is a +C small positive number for declaring ''lack of progress in +C the objective function value'' if f(x_k) - f(x_{k+1}) <= +C epsnfp * max{ f(x_j) - f(x_{j+1}, j < k } during maxitnfp +C consecutive iterations. This stopping criterion may be +C inhibited setting maxitnfp equal to maxit. +C +C RECOMMENDED: maxitnfp = 5 and epsnfp = 1.0d-02 +C +C CONSTRAINTS: maxitnfp >= 1 and epsnfp >= 0.0 +C +C maxitngp integer +C maxitngp means MAXimum of ITerations with No Gradient +C Progress. If the order of the Euclidian norm of the +C continuous projected gradient did not change during +C maxitngp consecutive iterations then the execution stops. +C +C RECOMMENDED: maxitngp = 10 +C +C CONSTRAINTS: maxitngp >= 1 +C +C fmin double precision +C function value for the stopping criteria f <= fmin +C +C There is a stopping criterion that stops GENCAN if a +C point with a functional value smaller than fmin is found. +C The idea behind this stopping criterion is to stop the +C method if the objective function is not bounded from +C below. +C +C RECOMMENDED: fmin = - infabs +C +C CONSTRAINTS: there are no constraints for this argument +C +C maxit integer +C maximum number of allowed iterations +C +C RECOMMENDED: maxit = 1000 +C +C CONSTRAINTS: maxit >= 0 +C +C maxfc integer +C maximum allowed number of functional evaluations +C +C RECOMMENDED: maxfc = 5 * maxit +C +C CONSTRAINTS: maxfc >= 1 +C +C udelta0 double precision +C initial ''trust-radius'' for Conjugate Gradients. The +C default value max( delmin, 0.1 * max( 1, ||x|| ) ) is +C used if the user sets udelta0 <= 0. +C +C RECOMMENDED: udelta0 = - 1.0 +C +C CONSTRAINTS: there are no constraints for this argument +C +C ucgmaxit integer +C maximum allowed number of iterations for each run of the +C Conjugate Gradient subalgorithm +C +C The default values for this argument is max( 1, 10 * +C log( nind ) ), where nind is the number of free +C variables, and it will be used if the user sets ucgmaxit +C to any non-positive value. +C +C RECOMMENDED: ucgmaxit = - 1 +C +C CONSTRAINTS: there are no constraints for this argument +C +C cgscre integer +C See below +C +C cggpnf double precision +C cgscre means conjugate gradient stopping criterion +C relation, and cggpnf means Conjugate Gradients projected +C gradient final norm. Both are related to a stopping +C criterion of Conjugate Gradients. This stopping criterion +C depends on the norm of the residual of the linear system. +C The norm of the residual should be less or equal than a +C ''small'' quantity which decreases as we are +C approximating the solution of the minimization problem +C (near the solution, better the truncated-Newton direction +C we aim). Then, the log of the required accuracy requested +C to Conjugate Gradient has a linear dependence on the log +C of the norm of the continuous projected gradient. This +C linear relation uses the squared Euclidian norm of the +C projected gradient if cgscre is equal to 1 and uses the +C sup-norm if cgscre is equal to 2. In addition, the +C precision required to CG is equal to cgepsi (conjugate +C gradient initial epsilon) at x0 and cgepsf (conjugate +C gradient final epsilon) when the Euclidian- or sup-norm +C of the projected gradient is equal to cggpnf (conjugate +C gradients projected gradient final norm) which is an +C estimation of the value of the Euclidian- or sup-norm of +C the projected gradient at the solution. +C +C RECOMMENDED: cgscre = 1, cggpnf = epsgpen; or +C cgscre = 2, cggpnf = epsgpsn. +C +C CONSTRAINTS: allowed values for cgscre are just 1 or 2 +C cggpnf >= 0.0 +C +C cgepsi double precision +C See below +C +C cgepsf double precision +C small positive numbers for declaring convergence of the +C Conjugate Gradients subalgorithm when ||r||_2 < cgeps * +C ||rhs||_2, where r is the residual and rhs is the right +C hand side of the linear system, i.e., CG stops when the +C relative error of the solution is smaller than cgeps. +C +C cgeps varies from cgepsi to cgepsf in a way that depends +C on cgscre as follows: +C +C i) CASE cgscre = 1: log10(cgeps^2) depends linearly on +C log10(||g_P(x)||_2^2) which varies from ||g_P(x_0)||_2^2 +C to epsgpen^2 +C +C ii) CASE cgscre = 2: log10(cgeps) depends linearly on +C log10(||g_P(x)||_inf) which varies from ||g_P(x_0)||_inf +C to epsgpsn +C +C RECOMMENDED: cgepsi = 1.0d-01, cgepsf = 1.0d-05 +C +C CONSTRAINTS: cgepsi >= cgepsf >= 0.0 +C +C epsnqmp double precision +C See below +C +C maxitnqmp integer +C This and the previous argument are used for a stopping +C criterion of the Conjugate Gradients subalgorithm. If the +C progress in the quadratic model is smaller than fraction +C of the best progress ( epsnqmp * bestprog ) during +C maxitnqmp consecutive iterations then CG is stopped +C declaring ''not enough progress of the quadratic model''. +C +C RECOMMENDED: epsnqmp = 1.0d-04, maxitnqmp = 5 +C +C CONSTRAINTS: epsnqmp >= 0.0, maxitnqmp >= 1. +C +C nearlyq logical +C If the objective function is (nearly) quadratic, use the +C option nearlyq = TRUE. Otherwise, keep the default +C option. +C +C If, in an iteration of CG we find a direction d such that +C d^T H d <= 0 then we take the following decision: +C +C (i) If nearlyq = TRUE then we take direction d and try to +C go to the boundary choosing the best point among the two +C points at the boundary and the current point. +C +C (ii) If nearlyq = FALSE then we stop at the current point. +C +C Moreover, if the objective function is quadratic more +c effort is due in computing the Truncated Newton direction. +C +C RECOMMENDED: nearlyq = FALSE +C +C CONSTRAINTS: allowed values are just TRUE or FALSE. +C +C nint double precision +C Constant for the interpolation. See the description of +C sigma1 and sigma2 above. Sometimes, in a line search, we +C take the new trial step as the previous one divided by +C nint +C +C RECOMMENDED: nint = 2.0 +C +C CONSTRAINTS: nint > 1.0. +C +C next double precision +C Constant for the extrapolation. When extrapolating we +C try alpha_new = alpha * next +C +C RECOMMENDED: next = 2.0 +C +C CONSTRAINTS: next > 1.0 +C +C mininterp integer +C Constant for testing if, after having made at least +C mininterp interpolations, the steplength is too small. In +C that case, failure of the line search is declared (may be +C the direction is not a descent direction due to an error +C in the gradient calculations). Use mininterp greater +C than or equal to maxfc for inhibit this stopping +C criterion +C +C RECOMMENDED: mininterp = 4 +C +C CONSTRAINTS: mininterp >= 1 +C +C maxextrap integer +C Constant to limit the number of extrapolations in the +C Truncated Newton direction. +C +C RECOMMENDED: maxextrap = 100 +C +C CONSTRAINTS: maxextrap >= 0 +C +C gtype integer +C gtype indicates in which way the gradient of the +C objective function will be computed. If the user have +C been implemented the user-supplied evalnal subroutine to +C compute the gradient of the objective function then +C gtype argument must be set to 0 (ZERO) and the user- +C supplied evalnal subroutine will be called by GENCAN any +C time the gradient would be required. +C +C subroutine evalnal(n,x,m,lambda,rho,g,flag) +C +C C On Entry: +C +C C n integer, +C C number of variables, +C C +C C x double precision x(n), +C C current point, +C C +C C m integer, +C C number of constraints (equalities plus +C C inequalities), +C C +C C lambda double precision lambda(m), +C C current estimation of the Lagrange +C C multipliers, +C C +C C rho double precision rho(m) +C C penalty parameters, +C C +C C NOTE: arguments m, lambda and rho are useful when +C C GENCAN is being used for solving the box- +C C constrained subproblems of an Augmented Lagrangian +C C framework. When GENCAN is being used stand-alone +C C for solving a bound-constrained problem, these +C C arguments are dummy arguments. +C C +C C On Return +C C +C C g double precision g(n), +C C gradient of the objective function at x, +C C +C C flag integer +C C 0 means ''no errors'', +C C 1 means ''some error occurs in the gradient +C C evaluation''. +C C +C C SCALAR ARGUMENTS +C integer flag,m,n +C +C C ARRAY ARGUMENTS +C double precision g(n),lambda(m),rho(m),x(n) +C +C C ''Here it should be the body of evalnal subroutine +C C that saves in g the gradient vector of the +C C objective at x. Moreover, it sets flag equal to 0 +C C if the calculation was successfully done and sets +C C flag equal to any other value different from 0 if +C C the gradient vector is not well defined at the +C C current point x. If GENCAN gtype argument was +C C setted to 1, i.e., the finite difference +C C approximation provided by GENCAN will be used, then +C C this subroutine must even be present for +C C compilation purposes but it will never be called.'' +C +C end +C +C If, on the other hand, the user is not able to provide +C evalnal subroutine, gtype argument must be set to 1 +C (ONE). In this case, every time GENCAN needs to compute +C the gradient of the objective function, an internal +C subroutine that approximates it by finite-differences +C will be used (be aware that it maybe very time +C consuming). Moreover, note that the evalnal subroutine +C must still be present (with an empty body). +C +C RECOMMENDED: gtype = 0 (provided you have the evalg +C subroutine) +C +C CONSTRAINTS: allowed values are just 0 or 1. +C +C htvtype integer +C htvtype indicates in which way the product of the Hessian +C of the objective function times an arbitrary vector will be +C computed. If the user has not been implemented the user- +C supplied evalhd subroutine to do this task then htvtype +C argument must be set to 1 (ONE). In this case an internal +C subroutine that approximates this product by incremental +C quotients will be used. Note that, even in this case, +C evalhd subroutine must be present (with an empty body). +C This is the default option and the empty-body subroutine +C follows: +C +C subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) +C +C C SCALAR ARGUMENTS +C integer nind,n,m,flag +C +C C ARRAY ARGUMENTS +C integer ind(nind) +C double precision x(n),lambda(m),rho(m),d(n),hd(n) +C +C flag = - 1 +C +C end +C +C If, on the other hand, the user prefers to implement his/ +C her own evalhd subroutine then htvtype argument must be +C set to 0 (ZERO). In this case, the product of the Hessian +C times vector d (input argument of evalhd subroutine) must +C be saved in vector hd (output argument of evalhd +C subroutine). The other arguments description as well as +C some hints on how to implement your own evalhd subroutine +C can be found in the GENCAN arguments description. +C +C RECOMMENDED: htvtype = 1 +C +C (you take some risk using this option but, unless you +C have a good evalhd subroutine, incremental quotients is a +C very cheap option) +C +C CONSTRAINTS: allowed values are just 0 or 1. +C +C trtype integer +C Type of Conjugate Gradients ''trust-radius''. trtype +C equal to 0 means Euclidian-norm trust-radius and trtype +C equal to 1 means sup-norm trust radius +C +C RECOMMENDED: trtype = 0 +C +C CONSTRAINTS: allowed values are just 0 or 1. +C +C iprint integer +C Commands printing. Nothing is printed if iprint is +C smaller than 2. If iprint is greater than or equal to +C 2, GENCAN iterations information is printed. If iprint +C is greater than or equal to 3, line searches and +C Conjugate Gradients information is printed. +C +C RECOMMENDED: iprint = 2 +C +C CONSTRAINTS: allowed values are just 2 or 3. +C +C ncomp integer +C This constant is just for printing. In a detailed +C printing option, ncomp component of some vectors will be +C printed +C +C RECOMMENDED: ncomp = 5 +C +C CONSTRAINTS: ncomp >= 0 +C +C s double precision s(n) +C y double precision y(n) +C d double precision d(n) +C ind integer ind(n) +C lastgpns double precision lastgpns(maxitngp) +C w double precision w(5*n) +C working vectors +C +C eta double precision +C Constant for deciding abandon the current face or not. We +C abandon the current face if the norm of the internal +C gradient (here, internal components of the continuous +C projected gradient) is smaller than ( 1 - eta ) times the +C norm of the continuous projected gradient. Using eta = +C 0.9 is a rather conservative strategy in the sense that +C internal iterations are preferred over SPG iterations. +C +C RECOMMENDED: eta = 0.9 +C +C CONSTRAINTS: 0.0 < eta < 1.0 +C +C delmin double precision +C Smaller Conjugate Gradients ''trust radius'' to compute +C the Truncated Newton direction +C +C RECOMMENDED: delmin = 0.1 +C +C CONSTRAINTS: delmin > 0.0 +C +C lspgmi double precision +C See below +C +C lspgma double precision +C The spectral steplength, called lamspg, is projected onto +C the box [lspgmi,lspgma] +C +C RECOMMENDED: lspgmi = 1.0d-10 and lspgma = 1.0d+10 +C +C CONSTRAINTS: lspgma >= lspgmi > 0.0 +C +C theta double precision +C Constant for the angle condition, i.e., at iteration k we +C need a direction dk such that <= - theta +C ||gk||_2 ||dk||_2, where gk is \nabla f(xk) +C +C RECOMMENDED: theta = 10^{-6} +C +C CONSTRAINTS: 0.0 < theta < 1.0 +C +C gamma double precision +C Constant for the Armijo criterion +C f(x + alpha d) <= f(x) + gamma * alpha * +C +C RECOMMENDED: gamma = 1.0d-04 +C +C CONSTRAINTS: 0.0 < gamma < 0.5. +C +C beta double precision +C Constant for the beta condition < beta +C * . If (xk + dk) satisfies the Armijo condition +C but does not satisfy the beta condition then the point is +C accepted, but if it satisfied the Armijo condition and +C also satisfies the beta condition then we know that there +C is the possibility for a successful extrapolation +C +C RECOMMENDED: beta = 0.5 +C +C CONSTRAINTS: 0.0 < beta < 1.0. +C +C sigma1 double precision +C See below +C +C sigma2 double precision +C Constant for the safeguarded interpolation. If alpha_new +C is not inside the interval [sigma1, sigma * alpha] then +C we take alpha_new = alpha / nint +C +C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 +C +C CONSTRAINTS: 0 < sigma1 < sigma2 < 1. +C +C sterel double precision +C See below +C +C steabs double precision +C This constants mean a ''relative small number'' and ''an +C absolute small number'' for the increments in finite +C difference approximations of derivatives +C +C RECOMMENDED: epsrel = 1.0d-07 and epsabs = 1.0d-10 +C +C CONSTRAINTS: sterel >= steabs > 0 +C +C epsrel double precision +C See below +C +C epsabs double precision +C See below +C +C infrel double precision +C See below +C +C infabs double precision +C This four constants mean a ''relative small number'', +C ''an absolute small number'', ''a relative large number'' +C and ''an absolute large number''. Basically, a quantity A +C is considered negligible with respect to another quantity +C B if |A| < max ( epsrel * |B|, epsabs ) +C +C RECOMMENDED: epsrel = 1.0d-10, epsabs = 1.0d-20, +C infrel = 1.0d+20, infabs = 1.0d+99 +C +C CONSTRAINTS: epsrel >= epsabs >= 0.0 +C infabs >= infrel >= 0.0 +C +C On Return +C +C x double precision x(n) +C Final estimation to the solution +C +C f double precision +C Function value at the final estimation +C +C g double precision g(n) +C Gradient at the final estimation +C +C gpeucn2 double precision +C Squared Euclidian norm of the continuous projected +C gradient at the final estimation +C +C gpsupn double precision +C the same as before but with sup-norm +C +C iter integer +C number of iterations +C +C fcnt integer +C number of function evaluations +C +C gcnt integer +C number of gradient evaluations +C +C cgcnt integer +C number of Conjugate Gradients iterations +C +C spgiter integer +C number of Spectral Projected Gradient iterations +C +C spgfcnt integer +C number of functional evaluations along Spectral Projected +C Gradient directions +C +C tniter integer +C number of Truncated-Newton iterations +C +C tnfcnt integer +C number of functional evaluations along Truncated-Newton +C directions +C +C tnintcnt integer +C number of times a backtracking in a Truncated-Newton +C direction was needed +C +C tnexgcnt integer +C number of times an extrapolation in a Truncated-Newton +C direction successfully decreased the objective funtional +C value +C +C tnexbcnt integer +C number of times an extrapolation was aborted in the first +C extrapolated point by an increase in the objective +C functional value +C +C tnstpcnt integer +C number of times the Newton point was accepted (without +C interpolations nor extrapolations) +C +C tnintfe integer +C number of functional evaluations used in interpolations +C along Truncated-Newton directions +C +C tnexgfe integer +C number of functional evaluations used in successful +C extrapolations along Truncated-Newton directions +C +C tnexbfe integer +C number of functional evaluations used in unsuccessful +C extrapolations along Truncated-Newton directions +C +C inform integer +C This output parameter tells what happened in this +C subroutine, according to the following conventions: +C +C 0 = convergence with small Euclidian norm of the +C continuous projected gradient (smaller than epsgpen); +C +C 1 = convergence with small sup-norm of the continuous +C projected gradient (smaller than epsgpsn); +C +C 2 = the algorithm stopped by ''lack of progress'', that +C means that f(xk) - f(x_{k+1}) <= epsnfp * +C max{ f(x_j) - f(x_{j+1}, j < k } during maxitnfp +C consecutive iterations. If desired, set maxitnfp +C equal to maxit to inhibit this stopping criterion. +C +C 3 = the algorithm stopped because the order of the +C Euclidian norm of the continuous projected gradient +C did not change during maxitngp consecutive +C iterations. Probably, we are asking for an +C exaggerated small norm of continuous projected +C gradient for declaring convergence. If desired, set +C maxitngp equal to maxit to inhibit this stopping +C criterion. +C +C 4 = the algorithm stopped because the functional value +c is very small (smaller than fmin). If desired, set +C fmin equal to minus infabs to inhibit this stopping +C criterion. +C +C 6 = too small step in a line search. After having made at +C least mininterp interpolations, the steplength +C becames small. ''small steplength'' means that we are +C at point x with direction d and step alpha, and +C +C alpha * ||d||_infty < max( epsabs, epsrel * +C ||x||_infty ). +C +C In that case failure of the line search is declared +C (may be the direction is not a descent direction due +C to an error in the gradient calculations). If +C desired, set mininterp equal to maxfc to inhibit this +C stopping criterion. +C +C 7 = it was achieved the maximum allowed number of +C iterations (maxit); +C +C 8 = it was achieved the maximum allowed number of +C function evaluations (maxfc); +C +C < 0 = error in evalal, evalnal or evalhd subroutines. + +C LOCAL SCALARS + character * 3 ittype + integer cgiter,cgmaxit,fcntprev,i,infotmp,itnfp,nind,nprint, + + rbdind,rbdtype,tnexbprev,tnexgprev,tnintprev + double precision acgeps,amax,amaxx,bestprog,bcgeps,cgeps,currprog, + + delta,epsgpen2,fprev,gieucn2,gpeucn20,gpi,gpnmax,gpsupn0, + + kappa,lamspg,ometa2,sts,sty,xnorm + logical packmolprecision + +C ================================================================== +C Initialization +C ================================================================== + +C Set some initial values: + +C counters, + iter = 0 + fcnt = 0 + gcnt = 0 + cgcnt = 0 + + spgiter = 0 + spgfcnt = 0 + + tniter = 0 + tnfcnt = 0 + + tnstpcnt = 0 + tnintcnt = 0 + tnexgcnt = 0 + tnexbcnt = 0 + + tnintfe = 0 + tnexgfe = 0 + tnexbfe = 0 + +C just for printing, + nprint = min0( n, ncomp ) + +C for testing convergence, + epsgpen2 = epsgpen ** 2 + +C for testing whether to abandon the current face or not, +C (ometa2 means '(one minus eta) squared') + ometa2 = ( 1.0d0 - eta ) ** 2 + +C for testing progress in f, and + fprev = infabs + bestprog = 0.0d0 + itnfp = 0 + +C for testing progress in the projected gradient norm. + do i = 0,maxitngp - 1 + lastgpns(i) = infabs + end do + +C Print problem information + + if( iprint .ge. 3 ) then + write(*, 977) n + write(*, 978) nprint,(l(i),i=1,nprint) + write(*, 979) nprint,(u(i),i=1,nprint) + write(*, 980) nprint,(x(i),i=1,nprint) + + write(10,977) n + write(10,978) nprint,(l(i),i=1,nprint) + write(10,979) nprint,(u(i),i=1,nprint) + write(10,980) nprint,(x(i),i=1,nprint) + end if + +C Project initial guess. If the initial guess is infeasible, +C projection puts it into the box. + + do i = 1,n + x(i) = max( l(i), min( x(i), u(i) ) ) + end do + +C Compute x Euclidian norm + + xnorm = 0.0d0 + do i = 1,n + xnorm = xnorm + x(i) ** 2 + end do + xnorm = sqrt( xnorm ) + +C Compute function and gradient at the initial point + + call evalal(n,x,m,lambda,rho,f,inform) + +c LM: Added packmolprecision function test, for Packmol + + if ( packmolprecision(n,x) ) then + if(iprint.gt.0) then + write(*,780) +780 format(' Current point is a solution.') + end if + return + end if + + fcnt = fcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + end if + + if ( gtype .eq. 0 ) then + call evalnal(n,x,m,lambda,rho,g,inform) + else ! if ( gtype .eq. 1 ) then + call evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + end if + +C Compute continuous-project-gradient Euclidian and Sup norms, +C internal gradient Euclidian norm, and store in nind the number of +C free variables and in array ind their identifiers. + + nind = 0 + gpsupn = 0.0d0 + gpeucn2 = 0.0d0 + gieucn2 = 0.0d0 + do i = 1,n + gpi = min( u(i), max( l(i), x(i) - g(i) ) ) - x(i) + gpsupn = max( gpsupn, abs( gpi ) ) + gpeucn2 = gpeucn2 + gpi ** 2 + if ( x(i) .gt. l(i) .and. x(i) .lt. u(i) ) then + gieucn2 = gieucn2 + gpi ** 2 + nind = nind + 1 + ind(nind) = i + end if + end do + +C Compute a linear relation between gpeucn2 and cgeps2, i.e., +C scalars a and b such that +c +C a * log10(||g_P(x_0)||_2^2) + b = log10(cgeps_0^2) and +c +C a * log10(||g_P(x_f)||_2^2) + b = log10(cgeps_f^2), +c +C where cgeps_0 and cgeps_f are provided. Note that if +C cgeps_0 is equal to cgeps_f then cgeps will be always +C equal to cgeps_0 and cgeps_f. + +C We introduce now a linear relation between gpsupn and cgeps also. + +c LM: changed to avoid error with gpsupn=0 + if ( gpsupn .ne. 0.0d0 ) then + acgeps = log10( cgepsf / cgepsi ) / log10( cggpnf / gpsupn ) + bcgeps = log10( cgepsi ) - acgeps * log10( gpsupn ) + else + acgeps = 0.0d0 + bcgeps = cgepsf + end if +c if ( cgscre .eq. 1 ) then +c acgeps = 2.0d0 * log10( cgepsf / cgepsi ) / +c + log10( cggpnf ** 2 / gpeucn2 ) +c bcgeps = 2.0d0 * log10( cgepsi ) - acgeps * log10( gpeucn2 ) +c else ! if ( cgscre .eq. 2 ) then +c acgeps = log10( cgepsf / cgepsi ) / log10( cggpnf / gpsupn ) +c bcgeps = log10( cgepsi ) - acgeps * log10( gpsupn ) +c end if + +C And it will be used for the linear relation of cgmaxit + + gpsupn0 = gpsupn + gpeucn20 = gpeucn2 + +C Print initial information + + if( iprint .ge. 2 ) then +c LM: output for packmol +c write(*,1003) iter,f,gpsupn + if((mod((iter-1),10).eq.0.or.iter.eq.0).and.iter.ne.1) then + write(*,778) + else if(mod(iter,10).eq.0) then + write(*,779) + else if(iter.ne.1) then + write(*,777) + end if + end if +777 format('*******',$) +778 format(' |',$) +779 format('**********|') + + if( iprint .ge. 3 ) then + write(*, 981) iter + write(*, 985) nprint,(x(i),i=1,nprint) + write(*, 986) nprint,(g(i),i=1,nprint) + write(*, 987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, + + nprint) + write(*, 988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, + + nind)) + write(*, 1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, + + spgiter,tniter,fcnt,gcnt,cgcnt + + write(10,981) iter + write(10,985) nprint,(x(i),i=1,nprint) + write(10,986) nprint,(g(i),i=1,nprint) + write(10,987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, + + nprint) + write(10,988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, + + nind)) + write(10,1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, + + spgiter,tniter,fcnt,gcnt,cgcnt + end if + +C ================================================================== +C Main loop +C ================================================================== + + 100 continue + +C ================================================================== +C Test stopping criteria +C ================================================================== + +c LM: Added packmolprecision function test, for Packmol + + if ( packmolprecision(n,x) ) then + goto 500 + end if + +C Test whether the continuous-projected-gradient Euclidian norm +C is small enough to declare convergence + + if ( gpeucn2 .le. epsgpen2 ) then + inform = 0 + + if ( iprint .ge. 3 ) then + write(*, 990) inform,epsgpen + write(10,990) inform,epsgpen + end if + + go to 500 + end if + +C Test whether the continuous-projected-gradient Sup norm +C is small enough to declare convergence + + if ( gpsupn .le. epsgpsn ) then + inform = 1 + + if ( iprint .ge. 3 ) then + write(*, 991) inform,epsgpsn + write(10,991) inform,epsgpsn + end if + + go to 500 + end if + +C Test whether we performed many iterations without good progress +C of the functional value + + currprog = fprev - f + bestprog = max( currprog, bestprog ) + + if ( currprog .le. epsnfp * bestprog ) then + + itnfp = itnfp + 1 + + if ( itnfp .ge. maxitnfp ) then + inform = 2 + + if ( iprint .ge. 3 ) then + write(*, 992) inform,epsnfp,maxitnfp + write(10,992) inform,epsnfp,maxitnfp + end if + + go to 500 + endif + + else + itnfp = 0 + endif + +C Test whether we have performed many iterations without good +C reduction of the euclidian-norm of the projected gradient + + gpnmax = 0.0d0 + do i = 0,maxitngp - 1 + gpnmax = max( gpnmax, lastgpns(i) ) + end do + + lastgpns(mod( iter, maxitngp )) = gpeucn2 + + if ( gpeucn2 .ge. gpnmax ) then + + inform = 3 + + if ( iprint .ge. 3 ) then + write(*, 993) inform,maxitngp + write(10,993) inform,maxitngp + end if + + go to 500 + + endif + +C Test whether the functional value is very small + + if ( f .le. fmin ) then + + inform = 4 + + if ( iprint .ge. 3 ) then + write(*, 994) inform,fmin + write(10,994) inform,fmin + end if + + go to 500 + + end if + +C Test whether the number of iterations is exhausted + + if ( iter .ge. maxit ) then + + inform = 7 + + if ( iprint .ge. 3 ) then + write(*, 997) inform,maxit + write(10,997) inform,maxit + end if + + go to 500 + + end if + +C Test whether the number of functional evaluations is exhausted + + if ( fcnt .ge. maxfc ) then + + inform = 8 + + if ( iprint .ge. 3 ) then + write(*, 998) inform,maxfc + write(10,998) inform,maxfc + end if + + go to 500 + + end if + +C ================================================================== +C The stopping criteria were not satisfied, a new iteration will be +C made +C ================================================================== + + iter = iter + 1 + +C ================================================================== +C Save current values, f, x and g +C ================================================================== + + fprev = f + + do i = 1,n + s(i) = x(i) + y(i) = g(i) + end do + +C ================================================================== +C Compute new iterate +C ================================================================== + +C We abandon the current face if the norm of the internal gradient +C (here, internal components of the continuous projected gradient) +C is smaller than (1-eta) times the norm of the continuous +C projected gradient. Using eta=0.9 is a rather conservative +C strategy in the sense that internal iterations are preferred over +C SPG iterations. Replace eta = 0.9 by other tolerance in (0,1) if +C you find it convenient. + + if ( gieucn2 .le. ometa2 * gpeucn2 ) then + +C ============================================================== +C Some constraints should be abandoned. Compute the new iterate +C using an SPG iteration +C ============================================================== + + ittype = 'SPG' + spgiter = spgiter + 1 + +C Compute spectral steplength + + if ( iter .eq. 1 .or. sty .le. 0.0d0 ) then + lamspg = max( 1.0d0, xnorm ) / sqrt( gpeucn2 ) + else + lamspg = sts / sty + end if + lamspg = min( lspgma, max( lspgmi, lamspg ) ) + +C Perform a line search with safeguarded quadratic interpolation +C along the direction of the spectral continuous projected +C gradient + + fcntprev = fcnt + + call spgls(n,x,m,lambda,rho,f,g,l,u,lamspg,nint,mininterp, + + fmin,maxfc,iprint,fcnt,inform,w(1),w(n+1),gamma,sigma1,sigma2, + + sterel,steabs,epsrel,epsabs,infrel,infabs) + + spgfcnt = spgfcnt + ( fcnt - fcntprev ) + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + end if + +C Compute the gradient at the new iterate + + if ( gtype .eq. 0 ) then + call evalnal(n,x,m,lambda,rho,g,inform) + else ! if ( gtype .eq. 1 ) then + call evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + end if + + else + +C ============================================================== +C The new iterate will belong to the closure of the current face +C ============================================================== + + ittype = 'TN ' + tniter = tniter + 1 + +C Compute trust-region radius + + if ( iter .eq. 1 ) then + if( udelta0 .le. 0.0d0 ) then + delta = max( delmin, 0.1d0 * max( 1.0d0, xnorm ) ) + else + delta = udelta0 + end if + else + delta = max( delmin, 10.0d0 * sqrt( sts ) ) + end if + +C Shrink the point, its gradient and the bounds + + call shrink(nind,ind,n,x) + call shrink(nind,ind,n,g) + call shrink(nind,ind,n,l) + call shrink(nind,ind,n,u) + +C Compute the descent direction solving the newtonian system by +C conjugate gradients + +C Set conjugate gradient stopping criteria. Default values are +C taken if you set ucgeps < 0 and ucgmaxit < 0, respectively. +C Otherwise, the parameters cgeps and cgmaxit will be the ones +C set by the user. + + if( ucgmaxit .le. 0 ) then + if ( nearlyq ) then + cgmaxit = nind + else + if ( cgscre .eq. 1 ) then + kappa = log10( gpeucn2 / gpeucn20 )/ + + log10( epsgpen2 / gpeucn20 ) + else ! if ( cgscre .eq. 2 ) then + kappa= log10( gpsupn / gpsupn0 ) / + + log10( epsgpsn / gpsupn0 ) + end if + kappa = max( 0.0d0, min( 1.0d0, kappa ) ) + cgmaxit = int( + + ( 1.0d0 - kappa ) * max( 1.0d0, 10.0d0 * + + log10( dfloat( nind ) ) ) + kappa * dfloat( nind ) ) +c L. Martinez added to accelerate the iterations near the solution + cgmaxit = min(20,cgmaxit) + end if +c cgmaxit = 2 * nind + else + cgmaxit = ucgmaxit + end if + + if ( cgscre .eq. 1 ) then + cgeps = sqrt( 10.0d0 ** ( acgeps * log10( gpeucn2 ) + + + bcgeps ) ) + else ! if ( cgscre .eq. 2 ) then + cgeps = 10.0d0 ** ( acgeps * log10( gpsupn ) + bcgeps ) + end if + cgeps = max( cgepsf, min( cgepsi, cgeps ) ) + +C Call conjugate gradients + + call cg(nind,ind,n,x,m,lambda,rho,g,delta,l,u,cgeps,epsnqmp, + + maxitnqmp,cgmaxit,nearlyq,gtype,htvtype,trtype,iprint,ncomp,d, + + cgiter,rbdtype,rbdind,inform,w(1),w(n+1),w(2*n+1),w(3*n+1), + + w(4*n+1),theta,sterel,steabs,epsrel,epsabs,infrel,infabs) + + cgcnt = cgcnt + cgiter + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + +C Compute maximum step + + if ( inform .eq. 2 ) then + amax = 1.0d0 + else + amax = infabs + do i = 1,nind + if ( d(i) .gt. 0.0d0 ) then + amaxx = ( u(i) - x(i) ) / d(i) + if ( amaxx .lt. amax ) then + amax = amaxx + rbdind = i + rbdtype = 2 + end if + else if ( d(i) .lt. 0.0d0 ) then + amaxx = ( l(i) - x(i) ) / d(i) + if ( amaxx .lt. amax ) then + amax = amaxx + rbdind = i + rbdtype = 1 + end if + end if + end do + end if + +C Perform the line search + + tnintprev = tnintcnt + tnexgprev = tnexgcnt + tnexbprev = tnexbcnt + + fcntprev = fcnt + + call tnls(nind,ind,n,x,m,lambda,rho,l,u,f,g,d,amax,rbdtype, + + rbdind,nint,next,mininterp,maxextrap,fmin,maxfc,gtype,iprint, + + fcnt,gcnt,tnintcnt,tnexgcnt,tnexbcnt,inform,w(1),w(n+1), + + w(2*n+1),gamma,beta,sigma1,sigma2,sterel,steabs,epsrel,epsabs, + + infrel,infabs) + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + if ( tnintcnt .gt. tnintprev ) then + tnintfe = tnintfe + ( fcnt - fcntprev ) + else if ( tnexgcnt .gt. tnexgprev ) then + tnexgfe = tnexgfe + ( fcnt - fcntprev ) + else if ( tnexbcnt .gt. tnexbprev ) then + tnexbfe = tnexbfe + ( fcnt - fcntprev ) + else + tnstpcnt = tnstpcnt + 1 + end if + + tnfcnt = tnfcnt + ( fcnt - fcntprev ) + +C Expand the point, its gradient and the bounds + + call expand(nind,ind,n,x) + call expand(nind,ind,n,g) + call expand(nind,ind,n,l) + call expand(nind,ind,n,u) + +C If the line search (interpolation) in the Truncated Newton +C direction stopped due to a very small step (inform = 6), we +C will discard this iteration and force a SPG iteration + +C Note that tnls subroutine was coded in such a way that in case +C of inform = 6 termination the subroutine discards all what was +C done and returns with the same point it started + + if ( inform .eq. 6 ) then + + if ( iprint .ge. 3 ) then + write(*,*) + write(*,*) + + ' The previous TN iteration was discarded due to', + + ' a termination for very small step in the line ', + + ' search. A SPG iteration will be forced now. ' + + write(10,*) + write(10,*) + + ' The previous TN iteration was discarded due to', + + ' a termination for very small step in the line ', + + ' search. A SPG iteration will be forced now. ' + end if + + ittype = 'SPG' + spgiter = spgiter + 1 + +C Compute spectral steplength + + if ( iter .eq. 1 .or. sty .le. 0.0d0 ) then + lamspg = max( 1.0d0, xnorm ) / sqrt( gpeucn2 ) + else + lamspg = sts / sty + end if + lamspg = min( lspgma, max( lspgmi, lamspg ) ) + +C Perform a line search with safeguarded quadratic +C interpolation along the direction of the spectral +C continuous projected gradient + + fcntprev = fcnt + + call spgls(n,x,m,lambda,rho,f,g,l,u,lamspg,nint,mininterp, + + fmin,maxfc,iprint,fcnt,inform,w(1),w(n+1),gamma,sigma1, + + sigma2,sterel,steabs,epsrel,epsabs,infrel,infabs) + + spgfcnt = spgfcnt + ( fcnt - fcntprev ) + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + end if + +C Compute the gradient at the new iterate + + infotmp = inform + + if ( gtype .eq. 0 ) then + call evalnal(n,x,m,lambda,rho,g,inform) + else ! if ( gtype .eq. 1 ) then + call evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs, + + inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 3 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + end if + + inform = infotmp + + end if + + end if + +C ================================================================== +C Prepare for the next iteration +C ================================================================== + +C This adjustment/projection is ''por lo que las putas pudiera'' + + do i = 1,n + if ( x(i) .le. l(i) + max( epsrel * abs( l(i) ), epsabs ) ) + + then + x(i) = l(i) + else if (x(i). ge. u(i) - max( epsrel * abs( u(i) ), epsabs )) + + then + x(i) = u(i) + end if + end do + +C Compute x Euclidian norm + + xnorm = 0.0d0 + do i = 1,n + xnorm = xnorm + x(i) ** 2 + end do + xnorm = sqrt( xnorm ) + +C Compute s = x_{k+1} - x_k, y = g_{k+1} - g_k, and + + sts = 0.0d0 + sty = 0.0d0 + do i = 1,n + s(i) = x(i) - s(i) + y(i) = g(i) - y(i) + sts = sts + s(i) ** 2 + sty = sty + s(i) * y(i) + end do + +C Compute continuous-project-gradient Euclidian and Sup norms, +C internal gradient Euclidian norm, and store in nind the number of +C free variables and in array ind their identifiers. + + nind = 0 + gpsupn = 0.0d0 + gpeucn2 = 0.0d0 + gieucn2 = 0.0d0 + do i = 1,n + gpi = min( u(i), max( l(i), x(i) - g(i) ) ) - x(i) + gpsupn = max( gpsupn, abs( gpi ) ) + gpeucn2 = gpeucn2 + gpi ** 2 + if ( x(i) .gt. l(i) .and. x(i) .lt. u(i) ) then + gieucn2 = gieucn2 + gpi ** 2 + nind = nind + 1 + ind(nind) = i + end if + end do + +C Print information of this iteration + + if( iprint .ge. 2 ) then +c Output for packmol +c write(*, 1003) iter,f,gpsupn + if((mod((iter-1),10).eq.0.or.iter.eq.0).and.iter.ne.1) then + write(*,778) + else if(mod(iter,10).eq.0) then + write(*,779) + else if(iter.ne.1) then + write(*,777) + end if + end if + + if ( iprint .ge. 3 ) then + write(*, 983) iter,ittype + write(*, 985) nprint,(x(i),i=1,nprint) + write(*, 986) nprint,(g(i),i=1,nprint) + write(*, 987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, + + nprint) + write(*, 988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, + + nind)) + write(*, 1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, + + spgiter,tniter,fcnt,gcnt,cgcnt + + write(10,983) iter,ittype + write(10,985) nprint,(x(i),i=1,nprint) + write(10,986) nprint,(g(i),i=1,nprint) + write(10,987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, + + nprint) + write(10,988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, + + nind)) + write(10,1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, + + spgiter,tniter,fcnt,gcnt,cgcnt + end if + +C ================================================================== +C Test some stopping criteria that may occur inside the line +C searches +C ================================================================== + + if ( inform .eq. 6 ) then + + if ( iprint .ge. 3 ) then + write(*, 996) inform,mininterp,epsrel,epsabs + write(10,996) inform,mininterp,epsrel,epsabs + end if + + go to 500 + + end if + +C ================================================================== +C Iterate +C ================================================================== + + go to 100 + +C ================================================================== +C End of main loop +C ================================================================== + +C ================================================================== +C Report output status and return +C ================================================================== + + 500 continue + +C Print final information + + if ( iprint .ge. 3 ) then + write(*, 982) iter + write(*, 985) nprint,(x(i),i=1,nprint) + write(*, 986) nprint,(g(i),i=1,nprint) + write(*, 987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, + + nprint) + write(*, 988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, + + nind)) + write(*, 1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, + + spgiter,tniter,fcnt,gcnt,cgcnt + + write(10,982) iter + write(10,985) nprint,(x(i),i=1,nprint) + write(10,986) nprint,(g(i),i=1,nprint) + write(10,987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, + + nprint) + write(10,988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, + + nind)) + write(10,1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, + + spgiter,tniter,fcnt,gcnt,cgcnt + end if + + return + +C Non-executable statements + + 977 format(/1X, 'Entry to GENCAN. Number of variables: ',I7) + 978 format(/1X,'Lower bounds (first ',I6, ' components): ', + */,6(1X,1PD11.4)) + 979 format(/1X,'Upper bounds (first ',I6, ' components): ', + */,6(1X,1PD11.4)) + 980 format(/1X,'Initial point (first ',I6, ' components): ', + */,6(1X,1PD11.4)) + 981 format(/1X,'GENCAN iteration: ',I6, ' (Initial point)') + 982 format(/1X,'GENCAN iteration: ',I6, ' (Final point)') + 983 format(/,1X,'GENCAN iteration: ',I6, + *' (This point was obtained using a ',A3,' iteration)') + 985 format(1X,'Current point (first ',I6, ' components): ', + */,6(1X,1PD11.4)) + 986 format(1X,'Current gradient (first ',I6, ' components): ', + */,6(1X,1PD11.4)) + 987 format(1X,'Current continuous projected gradient (first ',I6, + *' components): ',/,6(1X,1PD11.4)) + 988 format(1X,'Current free variables (first ',I6, + *', total number ',I6,'): ',/,10(1X,I6)) + 990 format(/1X,'Flag of GENCAN = ',I3, + *' (convergence with Euclidian-norm of the projected gradient', + */,1X,'smaller than ',1PD11.4,')') + 991 format(/1X,'Flag of GENCAN = ',I3, + *' (convergence with sup-norm of the projected gradient', + */,1X,'smaller than ',1PD11.4,')') + 992 format(/1X,'Flag of GENCAN= ',I3, + *' (The algorithm stopped by lack of enough progress. This means', + */,1X,'that f(x_k) - f(x_{k+1}) .le. ',1PD11.4, + *' * max [ f(x_j)-f(x_{j+1}, j < k ]',/,1X,'during ',I7, + *' consecutive iterations') + 993 format(/1X,'Flag of GENCAN = ',I3, + *' (The algorithm stopped because the order of the', + */,1X,'Euclidian-norm of the continuous projected gradient did', + *' not change during ',/,1X,I7,' consecutive iterations.', + *' Probably, an exaggerated small norm of the',/,1X,'continuous', + *' projected gradient is required for declaring convergence') + 994 format(/1X,'Flag of GENCAN = ',I3, + *' (The algorithm stopped because the functional value is', + */,1X,'smaller than ',1PD11.4) + 996 format(/1X,'Flag of GENCAN = ',I3, + *' (Too small step in a line search. After having made at ', + */,1X,'least ',I7,' interpolations, the steplength becames small.', + *' Small means that',/,1X,'we were at point x with direction d', + *' and took a step alpha such that',/,1X,'alpha * |d_i| .lt.', + *' max [',1PD11.4,' * |x_i|,',1PD11.4,' ] for all i)') + 997 format(/1X,'Flag of GENCAN = ',I3, + *' (It was exceeded the maximum allowed number of iterations', + */,1X,'(maxit=',I7,')') + 998 format(/1X,'Flag of GENCAN = ',I3, + *' (It was exceeded the maximum allowed number of functional', + */,1X,'evaluations (maxfc=',I7,')') + 1002 format(1X,'Functional value: ', 1PD11.4, + */,1X,'Euclidian-norm of the continuous projected gradient: ', + *1PD11.4, + */,1X,'Euclidian-norm of the internal projection of gp: ',1PD11.4, + */,1X,'Sup-norm of the continuous projected gradient: ',1PD11.4, + */,1X,'Free variables at this point: ',I7, + *' (over a total of ',I7,')', + */,1X,'SPG iterations: ',I7, + */,1X,'TN iterations: ',I7, + */,1X,'Functional evaluations: ',I7, + */,1X,'Gradient evaluations: ',I7, + */,1X,'Conjugate gradient iterations: ',I7) + 1003 format(6X,I6,T22,D17.6,T43,D17.6) +C1003 format(6X,'Iter = ',I6,' f = ',1PD11.4,' gpsupn = ',1PD11.4) + 1000 format(/1X,'Flag of GENCAN = ',I3,' Fatal Error') + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine spgls(n,x,m,lambda,rho,f,g,l,u,lamspg,nint,mininterp, + +fmin,maxfc,iprint,fcnt,inform,xtrial,d,gamma,sigma1,sigma2,sterel, + +steabs,epsrel,epsabs,infrel,infabs) + + implicit none + +C SCALAR ARGUMENTS + integer fcnt,m,maxfc,mininterp,n,inform,iprint + double precision epsabs,epsrel,f,fmin,gamma,infrel,infabs,lamspg, + + nint,sigma1,sigma2,steabs,sterel + +C ARRAY ARGUMENTS + double precision d(n),g(n),l(n),lambda(m),rho(m),u(n),x(n), + + xtrial(n) + +C Safeguarded quadratic interpolation, used in the Spectral +C Projected Gradient directions. +C +C On Entry +C +C n integer +C the order of the x +C +C x double precision x(n) +C current point +C +C m integer +C lambda double precision lambda(m) +C rho double precision rho(m) +C These three parameters are not used nor modified by +C GENCAN and they are passed as arguments to the user- +C defined subroutines evalal and evalnal to compute the +C objective function and its gradient, respectively. +C Clearly, in an Augmented Lagrangian context, if GENCAN is +C being used to solve the bound-constrainted subproblems, m +C would be the number of constraints, lambda the Lagrange +C multipliers approximation and rho the penalty parameters +C +C f double precision +C function value at the current point +C +C g double precision g(n) +C gradient vector at the current point +C +C l double precision l(n) +C lower bounds +C +C u double precision u(n) +C upper bounds +C +C lamspg double precision +C spectral steplength +C +C nint double precision +C constant for the interpolation. See the description of +C sigma1 and sigma2 above. Sometimes we take as a new +C trial step the previous one divided by nint +C +C RECOMMENDED: nint = 2.0 +C +C mininterp integer +C constant for testing if, after having made at least +C mininterp interpolations, the steplength is so small. In +C that case failure of the line search is declared (may be +C the direction is not a descent direction due to an error +C in the gradient calculations) +C +C RECOMMENDED: mininterp = 4 +C +C fmin double precision +C functional value for the stopping criterion f <= fmin +C +C maxfc integer +C maximum number of functional evaluations +C +C iprint integer +C Commands printing. Nothing is printed if iprint is +C smaller than 2. If iprint is greater than or equal to +C 2, GENCAN iterations information is printed. If iprint +C is greater than or equal to 3, line searches and +C Conjugate Gradients information is printed. +C +C RECOMMENDED: iprint = 2 +C +C CONSTRAINTS: allowed values are just 2 or 3. +C +C xtrial double precision xtrial(n) +C d double precision d(n) +C working vectors +C +C gamma double precision +C constant for the Armijo criterion +C f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d> +C +C RECOMMENDED: gamma = 10^{-4} +C +C sigma1 double precision +C sigma2 double precision +C constant for the safeguarded interpolation +C if alpha_new \notin [sigma1, sigma*alpha] then we take +C alpha_new = alpha / nint +C +C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 +C +C sterel double precision +C steabs double precision +C this constants mean a ``relative small number'' and ``an +C absolute small number'' for the increments in finite +C difference approximations of derivatives +C +C RECOMMENDED: epsrel = 10^{-7}, epsabs = 10^{-10} +C +C epsrel double precision +C epsabs double precision +C infrel double precision +C infabs double precision +C this constants mean a ``relative small number'', ``an +C absolute small number'', and ``infinite or a very big +C number''. Basically, a quantity A is considered +C negligible with respect to another quantity B if |A| < +C max ( epsrel * |B|, epsabs ) +C +C RECOMMENDED: epsrel = 10^{-10}, epsabs = 10^{-20}, +C infrel = 10^{+20}, infabs = 10^{+99} +C +C On Return +C +C x double precision +C final estimation of the solution +C +C f double precision +C functional value at the final estimation +C +C fcnt integer +C number of functional evaluations used in the line search +C +C inform integer +C This output parameter tells what happened in this +C subroutine, according to the following conventions: +C +C 0 = convergence with an Armijo-like criterion +C (f(xnew) <= f(x) + gamma * alpha * ); +C +C 4 = the algorithm stopped because the functional value +C is smaller than fmin; +C +C 6 = too small step in the line search. After having made +C at least mininterp interpolations, the steplength +C becames small. ''small steplength'' means that we are +C at point x with direction d and step alpha, and, for +C all i, +C +C | alpha * d(i) | <= max ( epsrel * |x(i)|, epsabs ). +C +C In that case failure of the line search is declared +C (maybe the direction is not a descent direction due +C to an error in the gradient calculations). Use +C mininterp > maxfc to inhibit this criterion; +C +C 8 = it was achieved the maximum allowed number of +C function evaluations (maxfc); +C +C < 0 = error in evalf subroutine. + +C LOCAL SCALARS + logical samep + integer i,interp + double precision alpha,atmp,ftrial,gtd + +C Print presentation information + + if ( iprint .ge. 4 ) then + write(*, 980) lamspg + write(10,980) lamspg + end if + +C Initialization + + interp = 0 + +C Compute first trial point, spectral projected gradient direction, +C and directional derivative . + + alpha = 1.0d0 + + gtd = 0.0d0 + do i = 1,n + xtrial(i) = min( u(i), max( l(i), x(i) - lamspg * g(i) ) ) + d(i) = xtrial(i) - x(i) + gtd = gtd + g(i) * d(i) + end do + + call evalal(n,xtrial,m,lambda,rho,ftrial,inform) + fcnt = fcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + +C Print information of the first trial + + if ( iprint .ge. 4 ) then + write(*, 999) alpha,ftrial,fcnt + write(10,999) alpha,ftrial,fcnt + end if + +C Main loop + + 100 continue + +C Test Armijo stopping criterion + + if ( ftrial .le. f + gamma * alpha * gtd ) then + + f = ftrial + + do i = 1,n + x(i) = xtrial(i) + end do + + inform = 0 + + if ( iprint .ge. 4 ) then + write(*, 990) inform + write(10,990) inform + end if + + go to 500 + + end if + +C Test whether f is very small + + if ( ftrial .le. fmin ) then + + f = ftrial + + do i = 1,n + x(i) = xtrial(i) + end do + + inform = 4 + + if ( iprint .ge. 4 ) then + write(*, 994) inform + write(10,994) inform + end if + + go to 500 + + end if + +C Test whether the number of functional evaluations is exhausted + + if ( fcnt .ge. maxfc ) then + + if ( ftrial .lt. f ) then + + f = ftrial + + do i = 1,n + x(i) = xtrial(i) + end do + + end if + + inform = 8 + + if ( iprint .ge. 4 ) then + write(*, 998) inform + write(10,998) inform + end if + + go to 500 + + end if + +C Compute new step (safeguarded quadratic interpolation) + + interp = interp + 1 + + if ( alpha .lt. sigma1 ) then + alpha = alpha / nint + + else + atmp = ( - gtd * alpha ** 2 ) / + + ( 2.0d0 * ( ftrial - f - alpha * gtd ) ) + + if ( atmp .lt. sigma1 .or. atmp .gt. sigma2 * alpha ) then + alpha = alpha / nint + + else + alpha = atmp + end if + end if + +C Compute new trial point + + do i = 1,n + xtrial(i) = x(i) + alpha * d(i) + end do + + call evalal(n,xtrial,m,lambda,rho,ftrial,inform) + fcnt = fcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + +C Print information of the current trial + + if ( iprint .ge. 4 ) then + write(*, 999) alpha,ftrial,fcnt + write(10,999) alpha,ftrial,fcnt + end if + +C Test whether at least mininterp interpolations were made and two +C consecutive iterates are close enough + + samep = .true. + do i = 1,n + if ( abs( alpha * d(i) ) .gt. + + max( epsrel * abs( x(i) ), epsabs ) ) then + samep = .false. + end if + end do + + if ( interp .ge. mininterp .and. samep ) then + + if ( ftrial .lt. f ) then + + f = ftrial + + do i = 1,n + x(i) = xtrial(i) + end do + + end if + + inform = 6 + + if ( iprint .ge. 4 ) then + write(*, 996) inform + write(10,996) inform + end if + + go to 500 + + end if + +C Iterate + + go to 100 + +C Return + + 500 continue + + return + +C Non-executable statements + + 980 format(/,6x,'SPG (spectral steplength ',1PD11.4,')',/,/, + * 6x,'SPG Line search') + 999 format(6x,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I5) + 990 format(6x,'Flag of SPG Line search = ',I3, + * ' (Convergence with an Armijo-like criterion)') + 994 format(6x,'Flag of SPG Line search = ',I3, + * ' (Small functional value, smaller than ',/, + * 6X,'parameter fmin)') + 996 format(6x,'Flag of SPG Line search = ',I3, + * ' (Too small step in the interpolation)') + 998 format(6x,'Flag of SPG Line search = ',I3, + * ' (Too many functional evaluations)') + 1000 format(6x,'Flag of SPG Line search = ',I3,' Fatal Error') + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine cg(nind,ind,n,x,m,lambda,rho,g,delta,l,u,eps,epsnqmp, + +maxitnqmp,maxit,nearlyq,gtype,htvtype,trtype,iprint,ncomp,s,iter, + +rbdtype,rbdind,inform,w,y,r,d,sprev,theta,sterel,steabs,epsrel, + +epsabs,infrel,infabs) + + implicit none + +C SCALAR ARGUMENTS + logical nearlyq + integer gtype,htvtype,inform,iprint,iter,m,maxit,maxitnqmp,n, + + ncomp,nind,trtype,rbdind,rbdtype + double precision delta,eps,epsnqmp,epsabs,epsrel,infrel,infabs, + + steabs,sterel,theta + +C ARRAY ARGUMENTS + integer ind(nind) + double precision d(n),g(n),l(n),lambda(m),r(n),rho(m),s(n), + + sprev(n),u(n),w(n),x(n),y(n) + +C This subroutine implements the Conjugate Gradients method for +C minimizing the quadratic approximation q(s) of f(x) at x, where +C +C q(s) = 1/2 s^T H s + g^T s, +C +C H = \nabla^2 f(x), +C +C g = \nabla f(x), +C +C subject to || s || <= delta and l <= x + s <= u. +C +C In the constraint ''|| s || <= delta'', the norm will be the +C Euclidian norm if the input parameter trtype is equal to 0, and +C it will be the Sup norm if trtype is equal to 1. +C +C The method returns an approximation s to the solution such that +C ||H s + g||_2 <= eps * ||g||_2; or converges to the boundary of +C ||s||_2 <= delta and l <= x + s <= u; or finds a point s and a +C direction d such that q(s + alpha d) = q(s) for any alpha, i.e., +C d^T H d = g^T d = 0. +C +C On Entry +C +C nind integer +C number of free variables (this is thee dimension in +C which this subroutine will work) +C +C ind integer ind(n) +C array which contains, in the first nind positions, the +C identifiers of the free variables +C +C n integer +C dimension of the full space +C +C x double precision x(n) +C point at which f function is being approximated by the +C quadratic model +C +C The first nind positions of x contains the free variables +C x_ind(1), x_ind(2), ..., x_ind(nind). +C +C m integer +C lambda double precision lambda(m) +C rho double precision rho(m) +C These three parameters are not used nor modified by +C GENCAN and they are passed as arguments to the user- +C defined subroutines evalal and evalnal to compute the +C objective function and its gradient, respectively. +C Clearly, in an Augmented Lagrangian context, if GENCAN is +C being used to solve the bound-constrainted subproblems, m +C would be the number of constraints, lambda the Lagrange +C multipliers approximation and rho the penalty parameters +C +C g double precision g(n) +C linear coefficient of the quadratic function +C +C This is \nabla f(x) and it also contains in the first +C nind positions the components g_ind(1), g_ind(2), ..., +C g_ind(nind). +C +C IMPORTANT: the linear algebra of this subroutine lies in +C a space of dimension nind. The value of the full +C dimension n, the non-free variables (which are at the end +C of array x) and its gradient components (which are at the +C and of array g) are, at this moment, being used to +C approximate the Hessian times vector products by +C incremental quotients. +C +C delta double precision +C trust region radius (||s||_2 <= delta) +C +C l double precision l(n) +C lower bounds on x + s. It components are ordered in the +C same way as x and g. +C +C u double precision u(n) +C upper bounds on x + s. It components are ordered in the +C same way as x, g and l. +C +C eps double precision +C tolerance for the stopping criterion ||H s + g||_2 < eps +C * ||g||_2 +C +C epsnqmp double precision +C See below +C +C maxitnqmp integer +C This and the previous one parameter are used for a +C stopping criterion of the conjugate gradient +C subalgorithm. If the progress in the quadratic model is +C less or equal than a fraction of the best progress +C ( epsnqmp * bestprog ) during maxitnqmp consecutive +C iterations then CG is stopped by not enough progress of +C the quadratic model. +C +C RECOMMENDED: epsnqmp = 1.0d-4, maxitnqmp = 5 +C +C maxit integer +C maximum number of iterations allowed +C +C nearlyq logical +C if function f is (nearly) quadratic, use the option +C nearlyq = TRUE. Otherwise, keep the default option. +C +C if, in an iteration of CG we find a direction d such that +C d^T H d <= 0 then we take the following decision: +C +C (i) if nearlyq = TRUE then take direction d and try to go +C to the boundary choosing the best point among the two +C point at the boundary and the current point. +C +C (ii) if nearlyq = FALSE then we stop at the current +C point. +C +C RECOMMENDED: nearlyq = FALSE +C +C gtype integer +C type of gradient calculation +C gtype = 0 means user suplied evalg subroutine, +C gtype = 1 means central difference approximation. +C +C RECOMMENDED: gtype = 0 +C +C (provided you have the evalg subroutine) +C +C htvtype integer +C type of Hessian times vector product calculation +C htvtype = 0 means user supplied evalhd subroutine, +C htvtype = 1 means incremental quotients approximation. +C +C RECOMMENDED: htvtype = 1 +C +C (you take some risk using this option but, unless you +C have a good evalhd subroutine, incremental quotients is a +C very cheap option) +C +C trtype integer +C type of trust-region radius +C trtype = 0 means 2-norm trust-region +C trtype = 1 means infinite-norm trust-region +C +C RECOMMENDED: trtype = 0 +C +C iprint integer +C Commands printing. Nothing is printed if iprint is +C smaller than 2. If iprint is greater than or equal to +C 2, GENCAN iterations information is printed. If iprint +C is greater than or equal to 3, line searches and +C Conjugate Gradients information is printed. +C +C RECOMMENDED: iprint = 2 +C +C CONSTRAINTS: allowed values are just 2 or 3. +C +C ncomp integer +C This constant is just for printing. In a detailed +C printing option, ncomp component of some vectors will be +C printed +C +C RECOMMENDED: ncomp = 5 +C +C CONSTRAINTS: ncomp >= 0 +C +C w double precision w(n) +C y double precision y(n) +C r double precision r(n) +C d double precision d(n) +C sprev double precision sprev(n) +C working vectors +C +C theta double precision +C constant for the angle condition, i.e., at iteration k we +C need a direction d_k such that <= - theta +C ||gk||_2 ||dk||_2, where gk is \nabla f(xk) +C +C RECOMMENDED: theta = 10^{-6} +C +C sterel double precision +C steabs double precision +C this constants mean a ``relative small number'' and ``an +C absolute small number'' for the increments in finite +C difference approximations of derivatives +C +C RECOMMENDED: epsrel = 10^{-7}, epsabs = 10^{-10} +C +C epsrel double precision +C epsabs double precision +C infrel double precision +C infabs double precision +C this constants mean a ``relative small number'', ``an +C absolute small number'', and ``infinite or a very big +C number''. Basically, a quantity A is considered +C negligible with respect to another quantity B if |A| < +C max ( epsrel * |B|, epsabs ) +C +C RECOMMENDED: epsrel = 10^{-10}, epsabs = 10^{-20}, +C infrel = 10^{+20}, infabs = 10^{+99} +C +C On Return +C +C s double precision s(n) +C final estimation of the solution +C +C iter integer +C number of Conjugate Gradient iterations performed +C +C inform integer +C termination parameter: +C +C 0 = convergence with ||H s + g||_2 <= eps * ||g||_2; +C +C 1 = convergence to the boundary of ||s||_2 <= delta; +C +C 2 = convergence to the boundary of l - x <= s <= u - x; +C +C 3 = stopping with s = sk such that <= -t heta +C ||gk||_2 ||sk||_2 and > - theta +C ||gk||_2 ||s_{k+1}||_2; +C +C 4 = not enough progress of the quadratic model during +C maxitnqmp iterations, i.e., during maxitnqmp +C iterations | q - qprev | <= max ( epsrel * | q |, +C epsabs ); +C +C 6 = very similar consecutive iterates, for two +C consecutive iterates x and y, for all i | x(i) - +C y(i) | <= max ( epsrel * | x(i) |, epsabs ); +C +C 7 = stopping with d such that d^T H d = 0 and g^T d = 0; +C +C 8 = too many iterations; +C +C < 0 = error in evalhd subroutine. + +C LOCAL SCALARS + character * 5 rbdtypea + logical samep + integer i,itnqmp,rbdnegaind,rbdnegatype,rbdposaind,rbdposatype + double precision aa,alpha,amax,amax1,amax1n,amaxn,amax2,amax2n, + + amax2nx,amax2x,bb,bestprog,beta,cc,currprog,dd,dnorm2,dtr, + + dts,dtw,gnorm2,gts,norm2s,q,qamax,qamaxn,qprev,rnorm2, + + rnorm2prev,snorm2,snorm2prev + +C ================================================================== +C Initialization +C ================================================================== + + gnorm2 = norm2s(nind,g) + + iter = 0 + itnqmp = 0 + qprev = infabs + bestprog = 0.0d0 + + do i = 1,nind + s(i) = 0.0d0 + r(i) = g(i) + end do + + q = 0.0d0 + gts = 0.0d0 + snorm2 = 0.0d0 + rnorm2 = gnorm2 + +C ================================================================== +C Print initial information +C ================================================================== + + if ( iprint .ge. 4 ) then + write(*, 980) maxit,eps + if ( trtype .eq. 0 ) then + write(*, 981) delta + else if ( trtype .eq. 1 ) then + write(*, 982) delta + else + write(*, 983) + end if + write(*, 984) iter,rnorm2,sqrt(snorm2),q + + write(10,980) maxit,eps + if ( trtype .eq. 0 ) then + write(10,981) delta + else if ( trtype .eq. 1 ) then + write(10,982) delta + else + write(10,983) + end if + write(10,984) iter,rnorm2,sqrt(snorm2),q + + end if + +C ================================================================== +C Main loop +C ================================================================== + + 100 continue + +C ================================================================== +C Test stopping criteria +C ================================================================== + +C if ||r||_2 = ||H s + g||_2 <= eps * ||g||_2 then stop + + if ( rnorm2 .le. 1.0d-16 .or. + + ( ( rnorm2 .le. eps ** 2 * gnorm2 .or. + + ( rnorm2 .le. 1.0d-10 .and. iter .ne. 0 ) ) + + .and. iter .ge. 4 ) ) then + + inform = 0 + + if ( iprint .ge. 4 ) then + write(*, 990) inform + write(10,990) inform + end if + + go to 500 + + end if + +C if the maximum number of iterations was achieved then stop + + if ( iter .ge. max(4, maxit) ) then + + inform = 8 + + if ( iprint .ge. 4 ) then + write(*, 998) inform + write(10,998) inform + end if + + go to 500 + + end if + +C ================================================================== +C Compute direction +C ================================================================== + + if ( iter .eq. 0 ) then + + do i = 1,nind + d(i) = - r(i) + end do + + dnorm2 = rnorm2 + dtr = - rnorm2 + + else + + beta = rnorm2 / rnorm2prev + + do i = 1,nind + d(i) = - r(i) + beta * d(i) + end do + + dnorm2 = rnorm2 - 2.0d0 * beta * ( dtr + alpha * dtw ) + + + beta ** 2 * dnorm2 + dtr = - rnorm2 + beta * ( dtr + alpha * dtw ) + + end if + +C Force d to be a descent direction of q(s), i.e., +C <\nabla q(s), d> = = \le 0. + + if ( dtr .gt. 0.0d0 ) then + + do i = 1,nind + d(i) = - d(i) + end do + dtr = - dtr + + end if + +C ================================================================== +C Compute d^T H d +C ================================================================== + +C w = A d + + if ( htvtype .eq. 0 ) then + call calchd(nind,ind,x,d,g,n,x,m,lambda,rho,w,y,sterel,steabs, + + inform) + + else if ( htvtype .eq. 1 ) then + call calchddiff(nind,ind,x,d,g,n,x,m,lambda,rho,gtype,w,y, + + sterel,steabs,inform) + end if + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + end if + +C Compute d^T w and ||w||^2 + + dtw = 0.0d0 + do i = 1,nind + dtw = dtw + d(i) * w(i) + end do + +C ================================================================== +C Compute maximum step +C ================================================================== + +C amax1 > 0 and amax1n < 0 are the values of alpha such that +C ||s + alpha * d||_2 or ||s + alpha * d||_\infty = delta + + dts = 0.0d0 + do i = 1,nind + dts = dts + d(i) * s(i) + end do + +C Euclidian-norm trust radius + + if ( trtype .eq. 0 ) then + + aa = dnorm2 + bb = 2.0d0 * dts + cc = snorm2 - delta ** 2 + dd = sqrt( bb ** 2 - 4.0d0 * aa * cc ) + + amax1 = ( - bb + dd ) / ( 2.0d0 * aa ) + amax1n = ( - bb - dd ) / ( 2.0d0 * aa ) + +C Sup-norm trust radius + + else if ( trtype .eq. 1 ) then + + amax1 = infabs + amax1n = -infabs + + do i = 1,nind + if ( d(i) .gt. 0.0d0 ) then + amax1 = min( amax1, ( delta - s(i) ) / d(i) ) + amax1n = max( amax1n, ( - delta - s(i) ) / d(i) ) + else if ( d(i) .lt. 0.0d0 ) then + amax1 = min( amax1, ( - delta - s(i) ) / d(i) ) + amax1n = max( amax1n, ( delta - s(i) ) / d(i) ) + end if + end do + + end if + +C amax2 > 0 and amax2n < 0 are the maximum and the minimum values of +C alpha such that l - x <= s + alpha * d <= u - x, respectively + + amax2 = infabs + amax2n = - infabs + + do i = 1,nind + if ( d(i) .gt. 0.0d0 ) then +C if (u(i).lt.infrel) then + amax2x = ( u(i) - x(i) - s(i) ) / d(i) + if ( amax2x .lt. amax2 ) then + amax2 = amax2x + rbdposaind = i + rbdposatype = 2 + end if +C end if +C if (l(i).gt.-infrel) then + amax2nx = ( l(i) - x(i) - s(i) ) / d(i) + if ( amax2nx .gt. amax2n ) then + amax2n = amax2nx + rbdnegaind = i + rbdnegatype = 1 + end if +C end if + else if ( d(i) .lt. 0.0d0 ) then +C if (l(i).gt.-infrel) then + amax2x = ( l(i) - x(i) - s(i) ) / d(i) + if ( amax2x .lt. amax2 ) then + amax2 = amax2x + rbdposaind = i + rbdposatype = 1 + end if +C end if +C if (u(i).lt.infrel) then + amax2nx = ( u(i) - x(i) - s(i) ) / d(i) + if ( amax2nx .gt. amax2n ) then + amax2n = amax2nx + rbdnegaind = i + rbdnegatype = 2 + end if +C end if + end if + end do + +C Compute amax as the minimum among amax1 and amax2, and amaxn as +C the minimum among amax1n and amax2n. Moreover change amaxn by +C - amaxn to have amax and amaxn as maximum steps along d direction +C (and not -d in the case of amaxn) + + amax = min( amax1 , amax2 ) + amaxn = max( amax1n, amax2n ) + +C ================================================================== +C Compute the step (and the quadratic functional value at the new +C point) +C ================================================================== + + qprev = q + +C If d^T H d > 0 then take the conjugate gradients step + + if ( dtw .gt. 0.0d0 ) then + + alpha = min( amax, rnorm2 / dtw ) + + q = q + 0.5d0 * alpha ** 2 * dtw + alpha * dtr + +C If d^T H d <= 0 and function f is nearly quadratic then take the +C point with the minimum functional value (q) among the current one +C and the ones which are at the boundary, i.e., the best one between +C q(s), q(s + amax*d) and q(s + amaxn*d). + + else + + qamax = q + 0.5d0 * amax ** 2 * dtw + amax * dtr + +C If we are at iteration zero then take the maximum positive +C step in the minus gradient direction + + if ( iter .eq. 0 ) then + + alpha = amax + q = qamax + +C If we are not in the first iteration then if function f is +C nearly quadratic and q(s + amax * d) or q(s + amaxn * d) is +C smaller than q(s), go to the best point in the boundary + + else + + qamaxn = q + 0.5d0 * amaxn ** 2 * dtw + amaxn * dtr + + if ( nearlyq .and. + + ( qamax .lt. q .or. qamaxn .lt. q ) ) then + + if ( qamax .lt. qamaxn ) then + alpha = amax + q = qamax + else + alpha = amaxn + q = qamaxn + end if + +C Else, stop at the current point + + else + + inform = 7 + + if ( iprint .ge. 4 ) then + write(*, 997) inform + write(10,997) inform + end if + + go to 500 + + end if + + end if + end if + +C ================================================================== +C Compute new s +C ================================================================== + + do i = 1,nind + sprev(i) = s(i) + s(i) = s(i) + alpha * d(i) + end do + + snorm2prev = snorm2 + snorm2 = snorm2 + alpha ** 2 * dnorm2 + 2.0d0 * alpha * dts + +C ================================================================== +C Compute the residual r = H s + g +C ================================================================== + + rnorm2prev = rnorm2 + + do i = 1,nind + r(i) = r(i) + alpha * w(i) + end do + + rnorm2 = norm2s(nind,r) + +C ================================================================== +C Increment number of iterations +C ================================================================== + + iter = iter + 1 + +C ================================================================== +C Print information of this iteration +C ================================================================== + + if ( iprint .ge. 4 ) then + write(*, 984) iter,sqrt(rnorm2),sqrt(snorm2),q + write(10,984) iter,sqrt(rnorm2),sqrt(snorm2),q + end if + +C ================================================================== +C Test other stopping criteria +C ================================================================== + +C Test angle condition + + gts = 0.0d0 + do i = 1,nind + gts = gts + g(i) * s(i) + end do + + if ( gts .gt. 0.0d0 .or. + + gts ** 2 .lt. theta ** 2 * gnorm2 * snorm2 ) then + + do i = 1,nind + s(i) = sprev(i) + end do + + snorm2 = snorm2prev + + q = qprev + + inform = 3 + + if ( iprint .ge. 4 ) then + write(*, 993) inform + write(10,993) inform + end if + + go to 500 + + end if + +C If we are in the boundary of the box also stop + + if ( alpha .eq. amax2 .or. alpha .eq. amax2n ) then + + if ( alpha .eq. amax2 ) then + rbdind = rbdposaind + rbdtype = rbdposatype + else ! if (alpha.eq.amax2n) then + rbdind = rbdnegaind + rbdtype = rbdnegatype + end if + + if ( rbdtype .eq. 1 ) then + rbdtypea = 'lower' + else ! if (rbdtype.eq.2) then + rbdtypea = 'upper' + end if + + inform = 2 + + if ( iprint .ge. 4 ) then + write(*, 992) inform,ind(rbdind),rbdtypea + write(10,992) inform,ind(rbdind),rbdtypea + end if + + go to 500 + + end if + +C If we are in the boundary of the trust region then stop + + if ( alpha .eq. amax1 .or. alpha .eq. amax1n ) then + + inform = 1 + + if ( iprint .ge. 4 ) then + write(*, 991) inform + write(10,991) inform + end if + + go to 500 + + end if + +C If two consecutive iterates are much close then stop + + samep = .true. + do i = 1,nind + if ( abs( alpha * d(i) ) .gt. + + max( epsrel * abs( s(i) ), epsabs ) ) then + samep = .false. + end if + end do + + if ( samep ) then + + inform = 6 + + if ( iprint .ge. 4 ) then + write(*, 996) inform + write(10,996) inform + end if + + go to 500 + + end if + +C Test whether we performed many iterations without good progress of +C the quadratic model + +C if (abs( q - qprev ) .le. max( epsrel * abs( qprev ), epsabs ) ) +C +then + +C itnqmp = itnqmp + 1 + +C if ( itnqmp .ge. maxitnqmp ) then + +C inform = 4 + +C if ( iprint .ge. 4 ) then +C write(*,994) inform,itnqmp +C write(10,994) inform,itnqmp +C end if + +C go to 500 + +C endif + +C else +C itnqmp= 0 +C endif + +C Test whether we performed many iterations without good progress of +C the quadratic model + + currprog = qprev - q + bestprog = max( currprog, bestprog ) + + if ( currprog .le. epsnqmp * bestprog ) then + + itnqmp = itnqmp + 1 + + if ( itnqmp .ge. maxitnqmp ) then + inform = 4 + + if ( iprint .ge. 4 ) then + write(*, 994) inform,itnqmp,epsnqmp,bestprog + write(10,994) inform,itnqmp,epsnqmp,bestprog + end if + + go to 500 + endif + + else + itnqmp = 0 + endif + +C ================================================================== +C Iterate +C ================================================================== + + go to 100 + +C ================================================================== +C End of main loop +C ================================================================== + +C ================================================================== +C Return +C ================================================================== + + 500 continue + +C Print final information + + if ( iprint .ge. 4 ) then + write(*, 985) min0(nind,ncomp),(s(i),i=1,min0(nind,ncomp)) + write(10,985) min0(nind,ncomp),(s(i),i=1,min0(nind,ncomp)) + end if + + return + +C Non-executable statements + + 980 format(/,6x,'Conjugate gradients (maxit= ',I7,' acc= ',1PD11.4, + *')') + 981 format(6x,'Using Euclidian trust region (delta= ',1PD11.4, + *')') + 982 format(6x,'Using sup-norm trust region (delta= ',1PD11.4,')') + 983 format(6x,'Unknown trust-region type') + 984 format(6x,'CG iter= ',I5,' rnorm: ',1PD11.4,' snorm= ',1PD11.4, + *' q= ',1PD11.4) + 985 format(/,6x,'Truncated Newton direction (first ',I6, + *' components): ',/,1(6x,6(1PD11.4,1x))) + 990 format(6x,'Flag of CG = ',I3,' (Convergence with small residual)') + 991 format(6x,'Flag of CG = ',I3, + *' (Convergence to the trust region boundary)') + 992 format(6x,'Flag of CG = ',I3, + *' (Convergence to the boundary of the box constraints,',/,6x, + *'taking step >= 1, variable ',I6,' will reaches its ',A5, + *' bound)') + 993 format(6x,'Flag of CG = ',I3, + *' (The next CG iterate will not satisfy the angle condition)') + 994 format(6x,'Flag of CG = ',I3, + *' (Not enough progress in the quadratic model. This means',/,6x, + *'that the progress of the last ',I7,' iterations was smaller ', + *'than ',/,6x,1PD11.4,' times the best progress (',1PD11.4,')') + 996 format(6x,'Flag of CG = ',I3, + *' (Very near consecutive iterates)') + 997 format(6x,'Flag of CG= ',I3, + *' (d such that d^T H d = 0 and g^T d = 0 was found)') + 998 format(6x,'Flag of CG = ',I3,' (Too many GC iterations)') + 1000 format(6x,'Flag of CG = ',I3,' Fatal Error') + + end + +C ***************************************************************** +C ***************************************************************** + subroutine tnls(nind,ind,n,x,m,lambda,rho,l,u,f,g,d,amax,rbdtype, + +rbdind,nint,next,mininterp,maxextrap,fmin,maxfc,gtype,iprint,fcnt, + +gcnt,intcnt,exgcnt,exbcnt,inform,xplus,xtmp,xbext,gamma,beta, + +sigma1,sigma2,sterel,steabs,epsrel,epsabs,infrel,infabs) + + implicit none + +C SCALAR ARGUMENTS + integer exbcnt,exgcnt,fcnt,gcnt,gtype,inform,intcnt,iprint,m, + + maxextrap,maxfc,mininterp,n,nind,rbdind,rbdtype + double precision amax,beta,epsabs,epsrel,f,fmin,gamma,infabs, + + infrel,next,nint,sigma1,sigma2,steabs,sterel + +C ARRAY ARGUMENTS + integer ind(nind) + double precision d(n),g(n),l(n),lambda(m),rho(m),u(n),x(n), + + xbext(n),xplus(n),xtmp(n) + +C This subroutine implements the line search used in the Truncated +C Newton direction. +C +C On Entry +C +C nind integer +C number of free variables (this is thee dimension in +C which this subroutine will work) +C +C ind integer ind(n) +C array which contains, in the first nind positions, the +C identifiers of the free variables +C +C n integer +C dimension of the full space +C +C x double precision x(n) +C current point +C +C The first nind positions of x contains the free variables +C x_ind(1), x_ind(2), ..., x_ind(nind). +C +C m integer +C lambda double precision lambda(m) +C rho double precision rho(m) +C These three parameters are not used nor modified by +C GENCAN and they are passed as arguments to the user- +C defined subroutines evalal and evalnal to compute the +C objective function and its gradient, respectively. +C Clearly, in an Augmented Lagrangian context, if GENCAN is +C being used to solve the bound-constrainted subproblems, m +C would be the number of constraints, lambda the Lagrange +C multipliers approximation and rho the penalty parameters +C +C l double precision l(nind) +C lower bounds on x. It components are ordered in the +C same way as x and g. +C +C u double precision u(nind) +C upper bounds on x. It components are ordered in the +C same way as x, g and l. +C +C f double precision +C functional value at x +C +C g double precision g(n) +C gradient vector at x +C +C It also contains in the first nind positions the +C components g_ind(1), g_ind(2), ..., g_ind(nind). +C +C IMPORTANT: the linear algebra of this subroutine lies in +C a space of dimension nind. The value of the full +C dimension n, the non-free variables (which are at the end +C of array x) and its gradient components (which are at the +C end of array g) are also used and updated any time the +C gradient is being computed. +C +C d double precision d(nind) +C descent direction +C +C amax double precision +C +C rbdtype integer +C +C rbdind integer +C +C nint double precision +C constant for the interpolation. See the description of +C sigma1 and sigma2 above. Sometimes we take as a new +C trial step the previous one divided by nint +C +C RECOMMENDED: nint = 2.0 +C +C next double precision +C constant for the extrapolation +C when extrapolating we try alpha_new = alpha * next +C +C RECOMMENDED: next = 2.0 +C +C mininterp integer +C constant for testing if, after having made at least +C mininterp interpolations, the steplength is so small. +C In that case failure of the line search is declared (may +C be the direction is not a descent direction due to an +C error in the gradient calculations) +C +C RECOMMENDED: mininterp = 4 +C +C maxextrap integer +C constant to limit the number of extrapolations +C +C RECOMMENDED: maxextrap = 1000 (a big number) +C +C fmin double precision +C functional value for the stopping criteria f <= fmin +C +C maxfc integer +C maximum number of functional evaluations +C +C gtype integer +C type of gradient calculation +C gtype = 0 means user suplied evalg subroutine, +C gtype = 1 means central difference approximation. +C +C RECOMMENDED: gtype = 0 +C +C (provided you have the evalg subroutine) +C +C iprint integer +C Commands printing. Nothing is printed if iprint is +C smaller than 2. If iprint is greater than or equal to +C 2, GENCAN iterations information is printed. If iprint +C is greater than or equal to 3, line searches and +C Conjugate Gradients information is printed. +C +C RECOMMENDED: iprint = 2 +C +C CONSTRAINTS: allowed values are just 2 or 3. +C +C xplus double precision xplus(nind) +C xtmp double precision xtmp(nind) +C xbext double precision xbext(nind) +C working vectors +C +C gamma double precision +C constant for the Armijo criterion +C f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d> +C +C RECOMMENDED: gamma = 10^{-4} +C +C beta double precision +C constant for the beta condition < beta +C * . If (xk + dk) satisfies the Armijo condition +C but does not satisfy the beta condition then the point is +C accepted, but if it satisfied the Armijo condition and +C also satisfies the beta condition then we know that there +C is the possibility for a successful extrapolation +C +C RECOMMENDED: beta = 0.5 +C +C sigma1 double precision +C sigma2 double precision +C constant for the safeguarded interpolation +C if alpha_new \notin [sigma1, sigma*alpha] then we take +C alpha_new = alpha / nint +C +C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 +C +C sterel double precision +C steabs double precision +C this constants mean a ``relative small number'' and ``an +C absolute small number'' for the increments in finite +C difference approximations of derivatives +C +C RECOMMENDED: epsrel = 10^{-7}, epsabs = 10^{-10} +C +C epsrel double precision +C epsabs double precision +C infrel double precision +C infabs double precision +C this constants mean a ``relative small number'', ``an +C absolute small number'', and ``infinite or a very big +C number''. Basically, a quantity A is considered +C negligible with respect to another quantity B if +C |A| < max ( epsrel * |B|, epsabs ) +C +C RECOMMENDED: epsrel = 10^{-10}, epsabs = 10^{-20}, +C infrel = 10^{+20}, infabs = 10^{+99} +C +C On Return +C +C x double precision x(n) +C new current point +C +C f double precision +C functional value at x +C +C g double precision g(n) +C gradient vector at x +C +C fcnt integer +C number of functional evaluations used in this line search +C +C gcnt integer +C number of gradient evaluations used in this line search +C +C intcnt integer +C number of interpolations +C +C exgcnt integer +C number of good extrapolations +C +C exbcnt integer +C number of bad extrapolations +C +C inform integer +C This output parameter tells what happened in this +C subroutine, according to the following conventions: +C +C 0 = convergence with an Armijo-like criterion +C (f(xnew) <= f(x) + 1.0d-4 * alpha * ); +C +C 4 = the algorithm stopped because the functional value +C is very small (f <= fmin); +C +C 6 = so small step in the line search. After having made +C at least mininterp interpolations, the steplength +C becames small. ``small steplength'' means that we are +C at point x with direction d and step alpha, and, for +C all i, +C +C |alpha * d(i)| .le. max ( epsrel * |x(i)|, epsabs ). +C +C In that case failure of the line search is declared +C (may be the direction is not a descent direction +C due to an error in the gradient calculations). Use +C mininterp > maxfc for inhibit this criterion; +C +C 8 = it was achieved the maximum allowed number of +C function evaluations (maxfc); +C +C < 0 = error in evalf or evalg subroutines. + +C LOCAL SCALARS + logical samep + integer extrap,i,interp + double precision alpha,atmp,fbext,fplus,ftmp,gptd,gtd + +C ================================================================== +C Initialization +C ================================================================== + +C ================================================================== +C Compute directional derivative +C ================================================================== + + gtd = 0.0d0 + do i = 1,nind + gtd = gtd + g(i) * d(i) + end do + +C ================================================================== +C Compute first trial +C ================================================================== + + alpha = min( 1.0d0, amax ) + + do i = 1,nind + xplus(i) = x(i) + alpha * d(i) + end do + + if ( alpha .eq. amax ) then + if ( rbdtype .eq. 1 ) then + xplus(rbdind) = l(rbdind) + else ! if (rbdtype.eq.2) then + xplus(rbdind) = u(rbdind) + end if + end if + + call calcf(nind,ind,xplus,n,x,m,lambda,rho,fplus,inform) + fcnt = fcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + +C Print initial information + + if ( iprint .ge. 4 ) then + write(*, 980) amax + write(*, 999) alpha,fplus,fcnt + + write(10,980) amax + write(10,999) alpha,fplus,fcnt + end if + +C ================================================================== +C Test Armijo and beta-condition and decide for accepting the trial +C point, interpolate or extrapolate. +C ================================================================== + + if ( amax .gt. 1.0d0 ) then + +C x + d belongs to the interior of the feasible set + if ( iprint .ge. 4 ) then + write(*, *) ' x+d belongs to int of the feasible set' + write(10,*) ' x+d belongs to int of the feasible set' + end if + +C Verify Armijo + + if ( fplus .le. f + gamma * alpha * gtd ) then + +C Armijo condition holds + if ( iprint .ge. 4 ) then + write(*, *) ' Armijo condition holds' + write(10,*) ' Armijo condition holds' + end if + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,xplus,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,xplus,n,x,m,lambda,rho,g, + + sterel,steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + gptd = 0.0d0 + do i = 1,nind + gptd = gptd + g(i) * d(i) + end do + +C Verify directional derivative (beta condition) + + if ( gptd .lt. beta * gtd ) then + +C Extrapolate + if ( iprint .ge. 4 ) then + write(*, *)' The beta-condition does not hold' + write(*, *)' We will extrapolate' + write(10,*)' The beta-condition does not hold' + write(10,*)' We will extrapolate' + end if + +C f and x before extrapolation + fbext = fplus + + do i = 1,nind + xbext(i) = xplus(i) + end do + + go to 100 + + else + +C Step = 1 was ok, finish the line search + if ( iprint .ge. 4 ) then + write(*, *) ' The beta condition is also true' + write(*, *) ' Line search is over' + write(10,*) ' The beta condition is also true' + write(10,*) ' Line search is over' + end if + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + + inform = 0 + + if ( iprint .ge. 4 ) then + write(*, 990) inform + write(10,990) inform + end if + + go to 500 + + end if + + else + +C Interpolate + if ( iprint .ge. 4 ) then + write(*, *) ' Armijo does not hold' + write(*, *) ' We will interpolate' + write(10,*) ' Armijo does not hold' + write(10,*) ' We will interpolate' + end if + + go to 200 + + end if + + else + +C x + d does not belong to the feasible set (amax <= 1) + if ( iprint .ge. 4 ) then + write(*, *) ' x+d does not belong to box-interior' + write(10,*) ' x+d does not belong to box-interior' + end if + + if ( fplus .lt. f ) then + +C Extrapolate + if ( iprint .ge. 4 ) then + write(*, *) ' f(x+d) < f(x)' + write(*, *) ' We will extrapolate' + write(10,*) ' f(x+d) < f(x)' + write(10,*) ' We will extrapolate' + end if + +C f and x before extrapolation + fbext = fplus + + do i = 1,nind + xbext(i) = xplus(i) + end do + + go to 100 + + else + +C Interpolate + if ( iprint .ge. 4 ) then + write(*, *) ' f(x+d) >= f(x)' + write(*, *) ' We will interpolate' + write(10,*) ' f(x+d) >= f(x)' + write(10,*) ' We will interpolate' + end if + + go to 200 + + end if + + end if + + +C ================================================================== +C Extrapolation +C ================================================================== + + 100 continue + + extrap = 0 + +C Test f going to -inf + + 120 if ( fplus .le. fmin ) then + +C Finish the extrapolation with the current point + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + + if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + if ( f .lt. fbext ) then + exgcnt = exgcnt + 1 + else + exbcnt = exbcnt + 1 + end if + + end if + + inform = 4 + + if ( iprint .ge.3 ) then + write(*, 994) inform + write(10,994) inform + end if + + go to 500 + + end if + +C Test maximum number of functional evaluations + + if ( fcnt .ge. maxfc ) then + +C Finish the extrapolation with the current point + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + +C If extrap=0 and amax>1 the gradient was computed for testing +C the beta condition and it is not necessary to compute it again + if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + if ( f .lt. fbext ) then + exgcnt = exgcnt + 1 + else + exbcnt = exbcnt + 1 + end if + + end if + + inform = 8 + + if ( iprint .ge. 4 ) then + write(*, 998) inform + write(10,998) inform + end if + + go to 500 + + end if + +C Test if the maximum number of extrapolations was exceeded + + if ( extrap .ge. maxextrap ) then + +C Finish the extrapolation with the current point + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + +C If extrap=0 and amax>1 the gradient was computed for testing +C the beta condition and it is not necessary to compute it again + if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + if ( f .lt. fbext ) then + exgcnt = exgcnt + 1 + else + exbcnt = exbcnt + 1 + end if + + end if + + inform = 7 + + if ( iprint .ge. 4 ) then + write(*, 997) inform + write(10,997) inform + end if + + go to 500 + + end if + +C Chose new step + + if ( alpha .lt. amax .and. next * alpha .gt. amax ) then + atmp = amax + else + atmp = next * alpha + end if + +C Compute new trial point + + do i = 1,nind + xtmp(i) = x(i) + atmp * d(i) + end do + + if ( atmp .eq. amax ) then + if ( rbdtype .eq. 1 ) then + xtmp(rbdind) = l(rbdind) + else ! if ( rbdtype .eq. 2 ) then + xtmp(rbdind) = u(rbdind) + end if + end if + +C Project + + if ( atmp .gt. amax ) then + do i = 1,nind + xtmp(i) = max( l(i), min( xtmp(i), u(i) ) ) + end do + end if + +C Test if this is not the same point as the previous one. +C This test is performed only when alpha > amax. + + if( alpha .gt. amax ) then + + samep = .true. + do i = 1,nind + if ( abs( xtmp(i) - xplus(i) ) .gt. + + max( epsrel * abs( xplus(i) ), epsabs ) ) then + samep = .false. + end if + end do + + if ( samep ) then + +C Finish the extrapolation with the current point + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + +C If extrap=0 and amax>1 the gradient was computed for +C testing the beta condition and it is not necessary to +C compute it again + if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g, + + sterel,steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + if ( f .lt. fbext ) then + exgcnt = exgcnt + 1 + else + exbcnt = exbcnt + 1 + end if + + end if + + inform = 0 + + if ( iprint .ge. 4 ) then + write(*, 990) inform + write(10,990) inform + end if + + go to 500 + + end if + + end if + +C Evaluate function + + call calcf(nind,ind,xtmp,n,x,m,lambda,rho,ftmp,inform) + fcnt = fcnt + 1 + + if ( inform .lt. 0 ) then + +C if ( iprint .ge. 4 ) then +C write(*, 1000) inform +C write(10,1000) inform +C end if + +C return + +C If the objective function is not well defined in an +C extrapolated point, we discard all the extrapolated points +C and return to a safe region (where the point before +C starting the extrapolations is) + + f = fbext + + do i = 1,nind + x(i) = xbext(i) + end do + +C If extrap=0 and amax>1 the gradient was computed for testing +C the beta condition and it is not necessary to compute it again + if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + exbcnt = exbcnt + 1 + + end if + + inform = 0 + + if ( iprint .ge. 4 ) then + write(*, 1010) inform + write(10,1010) inform + end if + + go to 500 + + end if + +C Print information of this iteration + + if ( iprint .ge. 4 ) then + write(*, 999) atmp,ftmp,fcnt + write(10,999) atmp,ftmp,fcnt + end if + +C If the functional value decreases then set the current point and +C continue the extrapolation + + if ( ftmp .lt. fplus ) then + + alpha = atmp + + fplus = ftmp + + do i = 1,nind + xplus(i) = xtmp(i) + end do + + extrap = extrap + 1 + + go to 120 + +C If the functional value does not decrease then discard the last +C trial and finish the extrapolation with the previous point + + else + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + +C If extrap=0 and amax>1 the gradient was computed for testing +C the beta condition and it is not necessary to compute it again + if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + if ( f .lt. fbext ) then + exgcnt = exgcnt + 1 + else + exbcnt = exbcnt + 1 + end if + + end if + + inform = 0 + + if ( iprint .ge.3 ) then + write(*, 990) inform + write(10,990) inform + end if + + go to 500 + + end if +C ================================================================== +C End of extrapolation +C ================================================================== + +C ================================================================== +C Interpolation +C ================================================================== + + 200 continue + + intcnt = intcnt + 1 + + interp = 0 + + 210 continue + +C Test f going to -inf + + if ( fplus .le. fmin ) then + +C Finish the interpolation with the current point + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + inform = 4 + + if ( iprint .ge. 4 ) then + write(*, 994) inform + write(10,994) inform + end if + + go to 500 + + end if + +C Test maximum number of functional evaluations + + if ( fcnt .ge. maxfc ) then + +C As this is an abrupt termination then the current point of the +C interpolation may be worst than the initial one + +C If the current point is better than the initial one then +C finish the interpolation with the current point else discard +C all we did inside this line search and finish with the initial +C point + + if ( fplus .lt. f ) then + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + end if + + inform = 8 + + if ( iprint .ge. 4 ) then + write(*, 998) inform + write(10,998) inform + end if + + go to 500 + + end if + +C Test Armijo condition + + if ( fplus .le. f + gamma * alpha * gtd ) then + +C Finish the line search + + f = fplus + + do i = 1,nind + x(i) = xplus(i) + end do + + if ( gtype .eq. 0 ) then + call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) + else if ( gtype .eq. 1 ) then + call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, + + steabs,inform) + end if + gcnt = gcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + + inform = 0 + + if ( iprint .ge. 4 ) then + write(*, 990) inform + write(10,990) inform + end if + + go to 500 + + end if + +C Compute new step + + interp = interp + 1 + + if ( alpha .lt. sigma1 ) then + alpha = alpha / nint + + else + atmp = ( - gtd * alpha **2 ) / + + (2.0d0 * ( fplus - f - alpha * gtd ) ) + + if ( atmp .lt. sigma1 .or. atmp .gt. sigma2 * alpha ) then + alpha = alpha / nint + + else + alpha = atmp + end if + end if + +C Compute new trial point + + do i = 1,nind + xplus(i) = x(i) + alpha * d(i) + end do + + call calcf(nind,ind,xplus,n,x,m,lambda,rho,fplus,inform) + fcnt = fcnt + 1 + + if ( inform .lt. 0 ) then + + if ( iprint .ge. 4 ) then + write(*, 1000) inform + write(10,1000) inform + end if + + return + + end if + +C Print information of this iteration + + if ( iprint .ge. 4 ) then + write(*, 999) alpha,fplus,fcnt + write(10,999) alpha,fplus,fcnt + end if + +C Test whether at least mininterp interpolations were made and two +C consecutive iterates are much close + + samep = .true. + do i = 1,nind + if ( abs( alpha * d(i) ) .gt. + + max( epsrel * abs( x(i) ), epsabs ) ) then + samep = .false. + end if + end do + + if ( interp .ge. mininterp .and. samep ) then + +C As this is an abrupt termination then the current point of the +C interpolation may be worst than the initial one + +C If the current point is better than the initial one then +C finish the interpolation with the current point else discard +C all we did inside this line search and finish with the initial +C point + +C if ( fplus .lt. f ) then + +C f = fplus + +C do i = 1,nind +C x(i) = xplus(i) +C end do + +C if ( gtype .eq. 0 ) then +C call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) +C else if ( gtype .eq. 1 ) then +C call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g, +c + sterel,steabs,inform) +C end if +C gcnt = gcnt + 1 + +C if ( inform .lt. 0 ) then + +C if ( iprint .ge. 4 ) then +C write(*, 1000) inform +C write(10,1000) inform +C end if + +C return + +C end if + +C end if + +C The previous lines were commented because, as it is been used, +C this subroutine must return with the initial point in case of +C finding a very small interpolation step. From that initial +C point, something different will be tried. + + inform = 6 + + if ( iprint .ge. 4 ) then + write(*, 996) inform + write(10,996) inform + end if + + go to 500 + + end if + +C Else, iterate + + go to 210 +C ================================================================== +C End of interpolation +C ================================================================== + + 500 continue + +C ================================================================== +C Return +C ================================================================== + + return + +C Non-executable statements + + 980 format(/,6X,'TN Line search (alphamax= ',1PD11.4,')') + 999 format(6X,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I5) + 990 format(6X,'Flag of TN Line search= ',I3, + + ' (Convergence with an Armijo-like criterion)') + 994 format(6X,'Flag of TN Line search= ',I3, + + ' (Small functional value, smaller than ',/, + + 6X,'parameter fmin)') + 996 format(6X,'Flag of TN Line search= ',I3, + + ' (Too small step in the interpolation)') + 997 format(6X,'Flag of TN Line search= ',I3, + + ' (Too many extrapolations)') + 998 format(6X,'Flag of TN Line search= ',I3, + + ' (Too many functional evaluations)') + 1000 format(6X,'Flag of TN Line search = ',I3,' Fatal Error') + 1010 format(6X,'Flag of TN Line search= ',I3, + + ' (Fatal Error in an extrapolated point)') + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine calcf(nind,ind,x,n,xc,m,lambda,rho,f,inform) + + implicit none + +C SCALAR ARGUMENTS + integer nind,n,m,inform + double precision f + +C ARRAY ARGUMENTS + integer ind(nind) + double precision x(n),xc(n),lambda(m),rho(m) + +C This subroutines computes the objective function. +C +C It is called from the reduced space (dimension nind), expands the +C point x where the function will be evaluated and call the +C subroutine evalf to compute the objective function Finally, +C shrinks vector x to the reduced space. +C +C About subroutines named calc[something]. The subroutines whos +C names start with ``calc'' work in (are called from) the reduced +C space. Their tasks are (i) expand the arguments to the full space, +C (ii) call the corresponding ``eval'' subroutine (which works in +C the full space), and (iii) shrink the parameters again and also +C shrink a possible output of the ``eval'' subroutine. Subroutines +C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. +C The corresponding subroutines in the full space are the user +C defined subroutines evalf, evalg and evalhd. + +C LOCAL SCALARS + integer i + +C Complete x + + do i = nind + 1,n + x(i) = xc(i) + end do + +C Expand x to the full space + + call expand(nind,ind,n,x) + +C Compute f calling the user supplied subroutine evalf + + call evalal(n,x,m,lambda,rho,f,inform) + +C Shrink x to the reduced space + + call shrink(nind,ind,n,x) + + return + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine calcg(nind,ind,x,n,xc,m,lambda,rho,g,inform) + + implicit none + +C SCALAR ARGUMENTS + integer nind,n,m,inform + +C ARRAY ARGUMENTS + integer ind(nind) + double precision x(n),xc(n),lambda(m),rho(m),g(n) + +C This subroutine computes the gradient vector g of the objective +C function. +C +C It is called from the reduced space (dimension nind), expands the +C point x where the gradient will be evaluated and calls the user +C supplied subroutine evalg to compute the gradient vector. Finally, +C shrinks vectors x and g to the reduced space. +C +C About subroutines named calc[something]. The subroutines whos +C names start with ``calc'' work in (are called from) the reduced +C space. Their tasks are (i) expand the arguments to the full space, +C (ii) call the corresponding ``eval'' subroutine (which works in +C the full space), and (iii) shrink the parameters again and also +C shrink a possible output of the ``eval'' subroutine. Subroutines +C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. +C The corresponding subroutines in the full space are the user +C defined subroutines evalf, evalg and evalhd. + +C LOCAL SCALARS + integer i + +C Complete x + + do i = nind + 1,n + x(i) = xc(i) + end do + +C Expand x to the full space + + call expand(nind,ind,n,x) + +C Compute the gradient vector calling the user supplied subroutine +C evalg + + call evalnal(n,x,m,lambda,rho,g,inform) + +C Shrink x and g to the reduced space + + call shrink(nind,ind,n,x) + call shrink(nind,ind,n,g) + + return + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine calcgdiff(nind,ind,x,n,xc,m,lambda,rho,g,sterel,steabs, + +inform) + + implicit none + +C SCALAR ARGUMENTS + integer nind,n,m,inform + double precision sterel,steabs + +C ARRAY ARGUMENTS + integer ind(nind) + double precision x(n),xc(n),lambda(m),rho(m),g(n) + +C This subroutine approximates the gradient vector g of the +C objective function in the reduced space using central finite +C differences. +C +C It is called from the reduced space (dimension nind), expands the +C point x where the gradient will be estimated and calls evalf +C subroutine (to evaluate the objective function) 2 * nind times. +C Finally, shrinks vectors x and g to the reduced space. +C +C About subroutines named calc[something]. The subroutines whos +C names start with ``calc'' work in (are called from) the reduced +C space. Their tasks are (i) expand the arguments to the full space, +C (ii) call the corresponding ``eval'' subroutine (which works in +C the full space), and (iii) shrink the parameters again and also +C shrink a possible output of the ``eval'' subroutine. Subroutines +C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. +C The corresponding subroutines in the full space are the user +C defined subroutines evalf, evalg and evalhd. + +C LOCAL SCALARS + integer i,indi + double precision fminus,fplus,step,tmp + +C Complete x + + do i = nind + 1,n + x(i) = xc(i) + end do + +C Expand x to the full space + + call expand(nind,ind,n,x) + +C Approximate the gradient vector by central finite differences + + do i = 1,nind + indi = ind(i) + + tmp = x(indi) + step = max( steabs, sterel * abs( tmp ) ) + + x(indi) = tmp + step + call evalal(n,x,m,lambda,rho,fplus,inform) + if ( inform .lt. 0 ) then + return + end if + + x(indi) = tmp - step + call evalal(n,x,m,lambda,rho,fminus,inform) + if ( inform .lt. 0 ) then + return + end if + + g(indi) = ( fplus - fminus ) / ( 2.0d0 * step ) + x(indi) = tmp + end do + +C Shrink x and g to the reduced space + + call shrink(nind,ind,n,x) + call shrink(nind,ind,n,g) + + return + + end + + +C ****************************************************************** +C ****************************************************************** + + subroutine calchd(nind,ind,x,d,g,n,xc,m,lambda,rho,hd,xtmp,sterel, + +steabs,inform) + + implicit none + +C SCALAR ARGUMENTS + integer inform,m,n,nind + double precision steabs,sterel + +C ARRAY ARGUMENTS + integer ind(nind) + double precision d(n),g(n),hd(n),lambda(m),rho(m),x(n),xc(n), + + xtmp(n) + +C This subroutine computes the product Hessian times vector d. As it +C is called from the reduced space, it expands vectors x and d, +C calls the user supplied subroutine evalhd to compute the Hessian +C times vector d product, and shrinks vectors x, d and hd. +C +C About subroutines named calc[something]. The subroutines whos +C names start with ``calc'' work in (are called from) the reduced +C space. Their tasks are (i) expand the arguments to the full space, +C (ii) call the corresponding ``eval'' subroutine (which works in +C the full space), and (iii) shrink the parameters again and also +C shrink a possible output of the ``eval'' subroutine. Subroutines +C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. +C The corresponding subroutines in the full space are the user +C defined subroutines evalf, evalg and evalhd. + +C LOCAL SCALARS + integer i + +C Complete d with zeroes + + do i = nind + 1,n + d(i) = 0.0d0 + end do + +C Complete x + + do i = nind + 1,n + x(i) = xc(i) + end do + +C Expand x and d to the full space + + call expand(nind,ind,n,x) + call expand(nind,ind,n,d) + call expand(nind,ind,n,g) + +C Compute the Hessian times vector d product calling the user +C supplied subroutine evalhd + + call evalhd(n) + +C Shrink x, d and hd to the reduced space + + call shrink(nind,ind,n,x) + call shrink(nind,ind,n,d) + call shrink(nind,ind,n,g) + call shrink(nind,ind,n,hd) + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine calchddiff(nind,ind,x,d,g,n,xc,m,lambda,rho,gtype,hd, + +xtmp,sterel,steabs,inform) + + implicit none + +C SCALAR ARGUMENTS + integer gtype,inform,m,n,nind + double precision steabs,sterel + +C ARRAY ARGUMENTS + integer ind(nind) + double precision d(n),g(n),hd(n),lambda(m),rho(m),x(n),xc(n), + + xtmp(n) + +C This subroutine computes the Hessian times vector d product by +C means of a ``directional finite difference''. The idea is that, at +C the current point x, the product H d is the limit of +C +C [ Gradient(x + t d) - Gradient(x) ] / t +C +C In this implementation we use +C +C t = max(steabs, sterel ||x||_\infty) / ||d||_\infty +C +C provided that d is not equal 0, of course. +C +C So, we evaluate the Gradient at the auxiliary point x + t d and +C use the quotient above to approximate H d. To compute the gradient +C vector at the auxiliary point it is used evalg or evalgdiff +C depending on gtype parameter. +C +C About subroutines named calc[something]. The subroutines whos +C names start with ``calc'' work in (are called from) the reduced +C space. Their tasks are (i) expand the arguments to the full space, +C (ii) call the corresponding ``eval'' subroutine (which works in +C the full space), and (iii) shrink the parameters again and also +C shrink a possible output of the ``eval'' subroutine. Subroutines +C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. +C The corresponding subroutines in the full space are the user +C defined subroutines evalf, evalg and evalhd. + +C On Entry +C +C n integer +C order of the x +C +C x double precision x(n) +C point for which Hessian(x) times d will be approximated +C +C d double precision d(n) +C vector for which the Hessian times vetor product will +C be approximated +C +C g double precision g(n) +C gradient at x +C +C xtmp double precision xtmp(n) +C working vector +C +C sterel double precision +C steabs double precision +C these constants mean a ``relative small number'' and +C ``an absolute small number'' +C +C On Return +C +C hd double precision hd(n) +C approximation of H d + +C LOCAL SCALARS + integer flag,i,indi + double precision dsupn,step,tmp,xsupn + + inform = 0 + +C Compute incremental quotients step + + xsupn = 0.0d0 + dsupn = 0.0d0 + do i = 1,nind + xsupn = max( xsupn, abs( x(i) ) ) + dsupn = max( dsupn, abs( d(i) ) ) + end do + +c Safeguard added by LM + if(dsupn.lt.1.d-20) dsupn = 1.d-20 + + step = max( sterel * xsupn, steabs ) / dsupn + +C Set the point at which the gradient will be evaluated + + do i = 1,nind + xtmp(i) = x(i) + step * d(i) + end do + +C Evaluate the gradient at xtmp = x + step * d + + if ( gtype .eq. 0 ) then + +C Complete xtmp + + do i = nind + 1,n + xtmp(i) = xc(i) + end do + +C Expand xtmp to the full space + + do i = nind,1,-1 + indi = ind(i) + if ( i .ne. indi ) then + tmp = xtmp(indi) + xtmp(indi) = xtmp(i) + xtmp(i) = tmp + end if + end do + +c Compute the gradient at xtmp = x + step * d + + call evalnal(n,xtmp,m,lambda,rho,hd,flag) + +C Shrink hd to the reduced space + + do i= 1, nind + indi= ind(i) + if (i.ne.indi) then + tmp = hd(indi) + hd(indi) = hd(i) + hd(i) = tmp + end if + end do + + else if ( gtype .eq. 1 ) then + + call calcgdiff(nind,ind,xtmp,n,xc,m,lambda,rho,hd,sterel, + + steabs,inform) + + end if + +C Compute incremental quotients + + do i = 1,nind + hd(i) = ( hd(i) - g(i) ) / step + end do + + return + + end + + +C ****************************************************************** +C ****************************************************************** + + subroutine shrink(nind,ind,n,v) + + implicit none + +C SCALAR ARGUMENTS + integer n,nind + +C ARRAY ARGUMENTS + integer ind(nind) + double precision v(n) + +C This subroutine shrinks vector v from the full dimension space +C (dimension n) to the reduced space (dimension nind). +C +C On entry: +C +C nind integer +C dimension of the reduced space +C +C ind integer ind(nind) +C components ind(1)-th, ..., ind(nind)-th are the +C components that belong to the reduced space +C +C n integer +C dimension of the full space +C +C v double precision v(n) +C vector to be shrinked +C +C On Return +C +C v double precision v(n) +C shrinked vector + +C LOCAL SCALARS + integer i,indi + double precision tmp + + do i = 1,nind + indi = ind(i) + if ( i .ne. indi ) then + tmp = v(indi) + v(indi) = v(i) + v(i) = tmp + end if + end do + + return + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine expand(nind,ind,n,v) + + implicit none + +C SCALAR ARGUMENTS + integer n, nind + +C ARRAY ARGUMENTS + integer ind(nind) + double precision v(n) + +C This subroutine expands vector v from the reduced space +C (dimension nind) to the full space (dimension n). +C +C On entry: +C +C nind integer +C dimension of the reduced space +C +C ind integer ind(nind) +C components ind(1)-th, ..., ind(nind)-th are the +C components that belong to the reduced space +C +C n integer +C dimension of the full space +C +C v double precision v(n) +C vector to be expanded +C +C On Return +C +C v double precision v(n) +C expanded vector + +C LOCAL SCALARS + integer i,indi + double precision tmp + + do i = nind,1,- 1 + indi = ind(i) + if ( i .ne. indi ) then + tmp = v(indi) + v(indi) = v(i) + v(i) = tmp + end if + end do + + return + + end + +C ****************************************************************** +C ****************************************************************** + + subroutine evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs,inform) + + implicit none + +C SCALAR ARGUMENTS + integer n,m,inform + double precision sterel,steabs + +C ARRAY ARGUMENTS + double precision x(n),lambda(m),rho(m),g(n) + +C Approximates the gradient vector g(x) of the objective function by +C central finite differences. This subroutine, which works in the +C full space, is prepared to replace the subroutine evalnal (to +C evaluate the gradient vector) in the case of the lastest have not +C being provided by the user. +C +C On entry: +C +C n integer +C number of variables +C +C x double precision x(n) +C current point +C +C m integer +C lambda double precision lambda(m) +C rho double precision rho(m) +C These three parameters are not used nor modified by +C GENCAN and they are passed as arguments to the user- +C defined subroutines evalal and evalnal to compute the +C objective function and its gradient, respectively. +C Clearly, in an Augmented Lagrangian context, if GENCAN is +C being used to solve the bound-constrainted subproblems, m +C would be the number of constraints, lambda the Lagrange +C multipliers approximation and rho the penalty parameters +C +C sterel double precision +C See below +C +C steabs double precision +C This constants mean a ''relative small number'' and ''an +C absolute small number'' for the increments in finite +C difference approximations of derivatives +C +C RECOMMENDED: epsrel = 1.0d-07 and epsabs = 1.0d-10 +C +C CONSTRAINTS: sterel >= steabs > 0 +C +C On Return +C +C g double precision g(n) +C approximation of the gradient vector at x +C +C inform integer +C 0 = no errors, +C < 0 = there was an error in the gradient calculation. + +C LOCAL SCALARS + integer j + double precision tmp,step,fplus,fminus + + inform = 0 + + do j = 1,n + tmp = x(j) + step = max( steabs, sterel * abs( tmp ) ) + + x(j) = tmp + step + call evalal(n,x,m,lambda,rho,fplus,inform) + if ( inform .lt. 0 ) then + return + end if + + x(j) = tmp - step + call evalal(n,x,m,lambda,rho,fminus,inform) + if ( inform .lt. 0 ) then + return + end if + + g(j) = ( fplus - fminus ) / ( 2.0d0 * step ) + x(j) = tmp + end do + + return + + end + +C ***************************************************************** +C ***************************************************************** + + double precision function norm2s(n,x) + + implicit none + +C SCALAR ARGUMENTS + integer n + +C ARRAY ARGUMENTS + double precision x(n) + +C This subroutine computes the squared Euclidian norm of an +C n-dimensional vector. +C +C On entry: +C +C n integer +C dimension +C +C x double precision x(n) +C vector +C +C On return: +C +C The function return the squared Euclidian norm of the +C n-dimensional vector x. + + external hsldnrm2 + double precision hsldnrm2 + + norm2s = hsldnrm2(n,x,1) ** 2 + + return + + end + +C ****************************************************************** +C ****************************************************************** + + DOUBLE PRECISION FUNCTION HSLDNRM2(N,DX,INCX) + DOUBLE PRECISION ZERO,ONE + PARAMETER (ZERO=0.0D0,ONE=1.0D0) + DOUBLE PRECISION CUTLO,CUTHI + PARAMETER (CUTLO=8.232D-11,CUTHI=1.304D19) + INTEGER INCX,N + DOUBLE PRECISION DX(*) + DOUBLE PRECISION HITEST,SUM,XMAX + INTEGER I,J,NN + INTRINSIC DABS,DSQRT,FLOAT + IF (N.GT.0) GO TO 10 + HSLDNRM2 = ZERO + GO TO 300 + 10 CONTINUE + SUM = ZERO + NN = N*INCX + I = 1 + 20 CONTINUE + 30 IF (DABS(DX(I)).GT.CUTLO) GO TO 85 + XMAX = ZERO + 50 IF (DX(I).EQ.ZERO) GO TO 200 + IF (DABS(DX(I)).GT.CUTLO) GO TO 85 + GO TO 105 + 100 I = J + SUM = (SUM/DX(I))/DX(I) + 105 XMAX = DABS(DX(I)) + GO TO 115 + 70 IF (DABS(DX(I)).GT.CUTLO) GO TO 75 + 110 IF (DABS(DX(I)).LE.XMAX) GO TO 115 + SUM = ONE + SUM* (XMAX/DX(I))**2 + XMAX = DABS(DX(I)) + GO TO 200 + 115 SUM = SUM + (DX(I)/XMAX)**2 + GO TO 200 + 75 SUM = (SUM*XMAX)*XMAX + 85 HITEST = CUTHI/DFLOAT(N) + DO 95 J = I,NN,INCX + IF (DABS(DX(J)).GE.HITEST) GO TO 100 + SUM = SUM + DX(J)**2 + 95 END DO + HSLDNRM2 = DSQRT(SUM) + GO TO 300 + 200 CONTINUE + I = I + INCX + IF (I.LE.NN) GO TO 20 + HSLDNRM2 = XMAX*DSQRT(SUM) + 300 CONTINUE + RETURN + END + +C ****************************************************************** +C ****************************************************************** +C +C Report of modifications. +C +C February 18th, 2005. +C +C 1) An unsed format statement, previously used to automaticaly +C generates some tables, was deleted. +C +C 2) An unmateched parenthesis was corrected in the format +C statement used to stop GENCAN due to a small step in a line search. +C +C February 16th, 2005. +C +C 1) The evalhd subroutine used by default in GENCAN is now the one +C implemented in calchddiff, which approximates the Hessian-vector +C product by incremental quotients. The implementation used to +C overcome the non twice continuously differentiability of the +C classical (PHR) Augmented Lagrangian function is now part of +C ALGENCAN (and not GENCAN). So, to use GENCAN inside ALGENCAN, +C htvtype argument must be set equal to 0 (ZERO). +C +C 2) The commented version of the empty function evalhd that must +C be added when GENCAN is beinf used stand-alone was wrong. The +C arguments declarations had been copied from evalnal. It was +C corrected. +C +C November 10th, 2004. +C +C 1) After several test, all references to nonmontone line search +C schemes were deleted. +C +C September 28th, 2004. +C +C 1) Subroutines were checked an some absent arguments explanations +C were added +C +C 2) Some calling sequences were modified to group related arguments +C +C 3) Arguments and local variables declarations were reordered in +C alphabetical order. +C +C 3) Shrink and expand subroutines were modified to deal with just +C one vector at a time. In this way, they are now being called from +C calc* subroutines. +C +C September 27th, 2004. +C +C 1) All comments were arranged to fit into the 72-columns format +C +C 2) Unused variable goth, which was prepared to indicate whether +C the Hessian matrix have been evaluated at the current point, was +C deleted from CG subroutine. +C +C 3) A spell check was used to correct the comments +C +C September 21th, 2004. +C +C 1) In the stopping criterion where the progress in the objective +C function is verified, ''itnfp .ge. maxitnfp'' was changed for +C ''itnfp .gt. maxitnfp'', to make the choice maxitnfp equal to 1 +C sounds reasonable. +C +C 2) Moreover, the previous chance came from the addition in the +C comments of GENCAN of the ''constraints'' information which makes +C clear to the user the values each argument may assume. +C +C 3) In the calculations of the first ''trust-radius'' for Conjugate +C Gradients, ''if( udelta0 .lt. 0.d0 ) then'' was changed by ''if +C ( udelta0 .le. 0.0d0 ) then'' to also make the default GENCAN +C choice of this initial trust-radius in the case of the user have +C been setted udelta = 0 by mistake. +C +C 4) The same for ucgmaxit. +C +C 5) In the line search subroutines spgls and tnls, ''if ( interp +C .gt. mininterp .and. samep ) then'' was changes by ''.ge.''. +C +C 6) Some comments of GENCAN arguments were re-written. +C +C September 16th, 2004. +C +C 1) With the reconfiguration of the calc* subroutines (see (1) +C below) there were a number of redundant parameters in calchd and +C evalhd subroutines. These parameters were eliminated. +C +C September 13th, 2004. +C +C 1) Subroutines named calc* that work in the reduced space always +C call the corresponding eval* subroutine. As it was, calcg (that +C computes the gradient in the reduced space) called evalg or +C evalgdiff depending on gtype parameter. The same was for calchd. +C Now, calcg calls evalg, calchd calls evalhd, and calchddiff (new) +C approximates the Hessian times vector product by incremental +C quotients calling calcg or calcgdiff depending on gtype parameter. +C An improvement of this modification is that calcg does not call +C evalg or evalgdiff (both work in the full space) any more but it +C approximates the gradient vector in the reduced space (by central +C finite differences) calling 2 * nind times evalf subroutine. +C +C 2) Some comments were added inside evalg and evalhd user supplied +C subroutines alerting about the relation of these subroutines and +C the parameters gtype and htvtype, respectively. +C +C 3) Description of tnls subroutine was slightly modified. +C +C 4) The description of htvtype parameter in gencan was again +C slightly modified. +C +C 5) With the introduction of the parameter lambda (that in the +C context of Augmented Lagrangians is used to store the +C approximation of the Lagrange multipliers) the name of the +C variable used for spectral steplength was changed from lambda to +C lamspg. In addition, lammax was changed to lspgma and lammin to +C lspgmi. +C +C 6) Modifications introduced in June 15th, 2004 and May 5th, 2004 +C were, in fact, made in this version on September 13th, 2004. +C +C June 15th, 2004. +C +C 1) The fmin stopping criterion and the maximum number of +C functional evaluation stopping criterion were erroneously being +C tested before the main loop. It was just redundant and, for this +C reason, deleted. +C +C May 5th, 2004. +C +C 1) Incorporated into an Augmented Lagrangian framework. +C +C a) evalf and evalg were renamed as evalal and evalnal, +C respectively. +C +C b) m,lambda,rho were added as parameters of the subroutines evalal +C and evalnal, and, as a consequence, as parameters of almost all +C the other subroutines. +C +C 2) The comment of htvtype parameter of gencan was in portuguese +C and it was translated into english. +C +C 3) A nonmonotone version of gencan is starting to be studied. +C Parameters p and lastfv(0:p-1) were added to gencan, spgls, and +C tnls to allow a nonmonotone line search. Array lastfv is now +C been updated for saving the last p functional values and the +C nonmonotone line searches are been done in a SPG or a +C Truncated Newton direction. p = 1 means monotone line search +C and is recommended until this study finish. +C +C April 13th, 2004. +C +C 1) The modifications introduced in the occasion of the IRLOC +C development and re-development (October 21th, 2003 and February +C 19th, 2003, respectively) were in fact made in this version on +C April 13th, 2004. The motivation to do this was to unify two +C parallel and different version of GENCAN (created, obviously, by +C mistake). +C +C 2) The complete reference of the GENCAN paper was finally added. +C +C May 14th, 2003. +c +C 1) The way amax2 and amax2n were being computing may caused a +C segmentation fault. Its initialization was changed from infty and +C -infty to 1.0d+99 and -1.0d+99, respectively. Using infty, when +C combined with a big trust region radius, the final value of amax2 +C or amax2n may cause the impression that a bound is being attained, +C when it is not. "Redundant" ifs inside the amax2 and anax2n +C calculation were deleted. It should considered the possibility of +C using two constants, namely, bignum = 1.0d+20 and infty = 1.0d+99, +C instead of just infty. +C +C Modification introduced in October 21, 2003 in occasion of the +C IRLOC re-development: +C +C 1) The stooping criteria related to functional value smaller than +C fmin and exhaustion of maximum allowed number of functional +C evaluations have been done after the line search. And the +C questions were done as "if line search flag is equal to 4" or "if +C line search flag is equal to 8". But it was wrong in the case, for +C example, inside the line search, a functional value such that f <= +C fmin and the Armijo criterion was satisfied. In such case, the +C line search flag was being setted to 0 and not to 4. And gencan +C did not stop by the fmin criterion. Now, both stooping criteria +C are tested at the begining of the main gencan loop and just the +C stooping criteria by small line search step is tested after the +C line search. +C +C Modification introduced in February 19, 2003 in occasion of the +C IRLOC development: +C +C 1) The description of epsnfp parameter of GENCAN was modified. It +C was written that to inhibit the related stopping criterion (lack +C of function progress) it was necessary just set epsnfp = 0 when +C it is also necessary to set maxitnfp = maxit. it was added in the +C explanation. +C +C 2) In the explanation at the beginning of GENCAN it was written +C that cgscre parameter should be double precision. This comment was +C wrong. The correct type for cgscre parameter is integer. +C +C Modifications introduced near April 1st 2003 in occasion of the +C PHR and inequality-constraints Augmented Lagrangian methods +C development: +C +C 1) The use of iprint was redefined and iprint2 was deleted. +C +C 2) The way to detect no progress in the log of the projected +C gradient norm was changed. As it was, ''no progress'' means no +C reduction in the projected gradient norm over M iterations. +C But this criterion implicitly assumed that the projected +C gradient norm must decrease monotonously. Is it is clearly not +C true, the criterion was changed by a non-monotone decrease +C criterion. Now, progress means that the projected gradient +C norm is, at each iteration, smaller than the maximum over the +C last M iterations. And "no progress" means the it does not +C occurs during not smaller than the +C +C 3 ) The computation of qamaxn inside cg subroutine was in the +C wrong place (it was being used before computed) and it may was +C the reason for which the option nearlyq = .true. never worked +C properly. With this correction this option should be tested again. +C +C On September 29th, 2004, we did a new test using the 41 bound +C constrained problems with quadratic objective function from the +C CUTE collection. The behaviour of GENCAN setting nearly equal +C to true or false was indistinguishable. The test did not +C include the different choices for the maximum number of CG +C iterations being restricted to evaluate the different +C alternatives for the case of finding a direction d such that +C d^t H d <= 0. As a conclusion of this experiment we continue +C recommending as a default choice to set nearlyq equal to false. +C +C Modifications introduced from March 1st to March 21th of 2002 +C in occasion of the ISPG development: +C +C 1) Comments of some new parameters introduced in the previous +C modification +C +C 2) As it was, in the first iteration of GENCAN (when kappa takes +C value equal 1) and for one-dimensional faces, cgmaxit(the maximum +C number of Conjugate Gradient iterations to compute the internal to +C the face truncated-Newton direction) was being 0. As it is +C obviously wrong, we add a max between what was being computed and +C one to allow at least one CG iteration. +C +C 3) Parameter inform in subroutines evalf, evalg and evalhd +C supplied by the user was added +C +C Modifications introduced from May 31th to November 2nd of 2001 +C in occasion of the ALGENCAN development: +C +C Fixed bugs: +C +C 1) The first spectral steplength was not been projected in the +C [lspgmi,lspgma] interval. +C +C 2) The conjugate gradients accuracy (cgeps) which is linearly +C dependent of the Euclidian norm of the projected gradient, was +C also not been projected in the interval [cgepsi,cgepsf]. +C +C 3) Conjugate gradients said that it was being used an Euclidian +C norm trust region when it has really being used an infinite norm +C trust region and viceversa. +C +C 4) Sometimes, the analytic gradient has been used although the +C user choose the finite differences option. +C +C Modifications: +C +C 1) To avoid roundoff errors, an explicit detection of at least one +C variable reaching its bound when a maximum step is being made was +C added. +C +C 2) The way in which two points were considered very similar in, +C for example, the interpolations and the extrapolations (which was +C dependent of the infinity norm of the points) showed to be very +C scale dependent. A new version which test the difference +C coordinate to coordinate was done. In this was the calculus of the +C current point x and the descent direction sup-norm is not done any +C more. +C +C 3) The same constants epsrel and epsabs were used as small +C relative and absolute values for, for example, detecting similar +C points and for finite differences. Now, epsrel and epsabs are used +C for detecting similar points (and the recommended values are +C 10^{-10} and 10^{-20}, respectively) and new constants sterel and +C steabs were introduced for finite differences (and the recommended +C values are 10^{-7} and 10^{-10}, respectively). +C +C 4) Two new stopping criteria for CG were added: (i) we stop if +C two consecutive iterates are too close; and (ii) we also +C stop if there is no enough quadratic model progress during +C maxitnqmp iterations. +C +C 5) The linear relation between the conjugate gradient accuracy +C and the norm of the projected gradient can be computed using +C the Euclidian- and the sup-norm of the projected gradient (only +C Euclidian norm version was present in the previous version. The +C linear relation is such that the CG accuracy is cgepsi when the +C projected gradient norm value is equal to the value corresponding +C to the initial guess and the CG accuracy is cgepsf when the +C projected gradient norm value is cgrelf). +C +C 6) Inside Conjugate Gradients, the Euclidian-norm is been computed +C using an algorithm developed by C.L.LAWSON, 1978 JAN 08. Numerical +C experiments showed that the performance of GENCAN depends +C basically on the conjugate gradients performance and stopping +C criteria and that the conjugate gradients depends on the way the +C Euclidian-norm is been computed. These things deserve further +C research. +C +C 7) In the Augmented Lagrangian algorithm ALGENCAN, which uses +C GENCAN to solve the bounded constrained subproblems, the maximum +C number of Conjugate Gradients iterations (cgmaxit), which in this +C version is linearly dependent of the projected gradient norm, was +C set to 2 * (# of free variables). As CG is not using restarts we +C do not know very well what this means. On the other hand, the +C accuracy (given by cgeps) continues being more strict when we are +C near to the solution and less strict when we ar far from the +C solution. +c +C 8) Many things in the output were changed. diff --git a/src/getinp.f90 b/src/getinp.f90 new file mode 100644 index 0000000..0873376 --- /dev/null +++ b/src/getinp.f90 @@ -0,0 +1,1115 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine getinp: subroutine that reads the input file +! + +subroutine getinp() + + use exit_codes + use sizes + use compute_data, only : ntype, natoms, idfirst, nmols, ityperest, coor, restpars + use input + use usegencan + + implicit none + integer :: i, k, ii, iarg, iline, idatom, iatom, in, lixo, irest, itype, itest,& + imark, ioerr, nloop0, iread, idfirstatom + double precision :: clen + character(len=strl) :: record, blank + logical :: inside_structure + + ! Clearing the blank character arrays + + do i = 1, strl + blank(i:i) = ' ' + end do + + ! Getting random seed and optional optimization parameters if set + + seed = 1234567 + randini = .false. + check = .false. + chkgrad = .false. + iprint1 = 2 + iprint2 = 2 + discale = 1.1d0 + writeout = 10 + maxit = 20 + nloop = 0 + nloop0 = 0 + movefrac = 0.05 + movebadrandom = .false. + precision = 1.d-2 + writebad = .false. + add_amber_ter = .false. + amber_ter_preserve = .false. + add_box_sides = .false. + add_sides_fix = 0.d0 + sidemax = 1000.d0 + ioerr = 0 + avoidoverlap = .true. + packall = .false. + use_short_tol = .false. + crd = .false. + + inside_structure = .false. + + do i = 1, nlines + + if ( keyword(i,1).eq.'structure') inside_structure = .true. + if ( keyword(i,1).eq.'end' .and. & + keyword(i,2).eq.'structure') inside_structure = .false. + + if(keyword(i,1).eq.'seed') then + read(keyword(i,2),*,iostat=ioerr) seed + if ( ioerr /= 0 ) exit + if ( seed == -1 ) call seed_from_time(seed) + else if(keyword(i,1).eq.'randominitialpoint') then + randini = .true. + else if(keyword(i,1).eq.'check') then + check = .true. + else if(keyword(i,1).eq.'writebad') then + writebad = .true. + else if(keyword(i,1).eq.'precision') then + read(keyword(i,2),*,iostat=ioerr) precision + if ( ioerr /= 0 ) exit + write(*,*) ' Optional precision set: ', precision + else if(keyword(i,1).eq.'movefrac') then + read(keyword(i,2),*,iostat=ioerr) movefrac + if ( ioerr /= 0 ) exit + write(*,*) ' Optional movefrac set: ', movefrac + else if(keyword(i,1).eq.'movebadrandom') then + movebadrandom = .true. + write(*,*) ' Will move randomly bad molecues (movebadrandom) ' + else if(keyword(i,1).eq.'chkgrad') then + chkgrad = .true. + else if(keyword(i,1).eq.'writeout') then + read(keyword(i,2),*,iostat=ioerr) writeout + if ( ioerr /= 0 ) exit + write(*,*) ' Output frequency: ', writeout + else if(keyword(i,1).eq.'maxit') then + read(keyword(i,2),*,iostat=ioerr) maxit + if ( ioerr /= 0 ) exit + write(*,*) ' User defined GENCAN number of iterations: ', maxit + else if(keyword(i,1).eq.'nloop') then + if( .not. inside_structure ) then + read(keyword(i,2),*,iostat=ioerr) nloop + if ( ioerr /= 0 ) exit + end if + else if(keyword(i,1).eq.'nloop0') then + if( .not. inside_structure ) then + read(keyword(i,2),*,iostat=ioerr) nloop0 + if ( ioerr /= 0 ) exit + end if + else if(keyword(i,1).eq.'discale') then + read(keyword(i,2),*,iostat=ioerr) discale + if ( ioerr /= 0 ) exit + write(*,*) ' Optional initial tolerance scale: ', discale + else if(keyword(i,1).eq.'sidemax') then + read(keyword(i,2),*,iostat=ioerr) sidemax + if ( ioerr /= 0 ) exit + write(*,*) ' User set maximum system dimensions: ', sidemax + else if(keyword(i,1).eq.'fbins') then + read(keyword(i,2),*,iostat=ioerr) fbins + if ( ioerr /= 0 ) exit + write(*,*) ' User set linked-cell bin parameter: ', fbins + else if(keyword(i,1).eq.'add_amber_ter') then + add_amber_ter = .true. + write(*,*) ' Will add the TER flag between molecules. ' + else if(keyword(i,1).eq.'amber_ter_preserve') then + amber_ter_preserve = .true. + write(*,*) ' TER flags for fixed molecules will be kept if found. ' + else if(keyword(i,1).eq.'avoid_overlap') then + if ( keyword(i,2).eq.'yes') then + avoidoverlap = .true. + write(*,*) ' Will avoid overlap to fixed molecules at initial point. ' + else + avoidoverlap = .false. + write(*,*) ' Will NOT avoid overlap to fixed molecules at initial point. ' + end if + else if(keyword(i,1).eq.'packall') then + packall = .true. + write(*,*) ' Will pack all molecule types from the beginning. ' + else if(keyword(i,1).eq.'use_short_tol') then + use_short_tol = .true. + write(*,*) ' Will use a short distance penalty for all atoms. ' + else if(keyword(i,1).eq.'writecrd') then + crd = .true. + write(*,*) ' Will write output also in CRD format ' + read(keyword(i,2),*,iostat=ioerr) crdfile + else if(keyword(i,1).eq.'add_box_sides') then + add_box_sides = .true. + write(*,*) ' Will print BOX SIDE informations. ' + read(keyword(i,2),*,iostat=ioerr) add_sides_fix + if ( ioerr /= 0 ) then + ioerr = 0 + cycle + end if + write(*,*) ' Will sum ', add_sides_fix,' to each side length on print' + else if(keyword(i,1).eq.'iprint1') then + read(keyword(i,2),*,iostat=ioerr) iprint1 + if ( ioerr /= 0 ) exit + write(*,*) ' Optional printvalue 1 set: ', iprint1 + else if(keyword(i,1).eq.'iprint2') then + read(keyword(i,2),*,iostat=ioerr) iprint2 + if ( ioerr /= 0 ) exit + write(*,*) ' Optional printvalue 2 set: ', iprint2 + else if( keyword(i,1) /= 'tolerance' .and. & + keyword(i,1) /= 'short_tol_dist' .and. & + keyword(i,1) /= 'short_tol_scale' .and. & + keyword(i,1) /= 'structure' .and. & + keyword(i,1) /= 'end' .and. & + keyword(i,1) /= 'atoms' .and. & + keyword(i,1) /= 'output' .and. & + keyword(i,1) /= 'filetype' .and. & + keyword(i,1) /= 'number' .and. & + keyword(i,1) /= 'inside' .and. & + keyword(i,1) /= 'outside' .and. & + keyword(i,1) /= 'fixed' .and. & + keyword(i,1) /= 'center' .and. & + keyword(i,1) /= 'centerofmass' .and. & + keyword(i,1) /= 'over' .and. & + keyword(i,1) /= 'above' .and. & + keyword(i,1) /= 'below' .and. & + keyword(i,1) /= 'constrain_rotation' .and. & + keyword(i,1) /= 'radius' .and. & + keyword(i,1) /= 'fscale' .and. & + keyword(i,1) /= 'short_radius' .and. & + keyword(i,1) /= 'short_radius_scale' .and. & + keyword(i,1) /= 'resnumbers' .and. & + keyword(i,1) /= 'connect' .and. & + keyword(i,1) /= 'changechains' .and. & + keyword(i,1) /= 'chain' .and. & + keyword(i,1) /= 'discale' .and. & + keyword(i,1) /= 'maxit' .and. & + keyword(i,1) /= 'movebadrandom' .and. & + keyword(i,1) /= 'maxmove' .and. & + keyword(i,1) /= 'add_amber_ter' .and. & + keyword(i,1) /= 'amber_ter_preserve' .and. & + keyword(i,1) /= 'sidemax' .and. & + keyword(i,1) /= 'seed' .and. & + keyword(i,1) /= 'randominitialpoint' .and. & + keyword(i,1) /= 'restart_from' .and. & + keyword(i,1) /= 'restart_to' .and. & + keyword(i,1) /= 'nloop' .and. & + keyword(i,1) /= 'nloop0' .and. & + keyword(i,1) /= 'writeout' .and. & + keyword(i,1) /= 'writebad' .and. & + keyword(i,1) /= 'check' .and. & + keyword(i,1) /= 'iprint1' .and. & + keyword(i,1) /= 'iprint2' .and. & + keyword(i,1) /= 'writecrd' .and. & + keyword(i,1) /= 'segid' .and. & + keyword(i,1) /= 'chkgrad' ) then + write(*,*) ' ERROR: Keyword not recognized: ', trim(keyword(i,1)) + stop exit_code_input_error + end if + end do + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Some optional keyword was not used correctly: ', trim(keyword(i,1)) + stop exit_code_input_error + end if + write(*,*) ' Seed for random number generator: ', seed + call init_random_number(seed) + + ! Checking for the name of the output file to be created + + xyzout = '####' + do iline = 1, nlines + if(keyword(iline,1).eq.'output') then + xyzout = keyword(iline,2) + xyzout = trim(adjustl(xyzout)) + end if + end do + if(xyzout(1:4) == '####') then + write(*,*)' ERROR: Output file not (correctly?) specified. ' + stop exit_code_input_error + end if + write(*,*)' Output file: ', trim(adjustl(xyzout)) + + ! Reading structure files + + itype = 0 + do iline = 1, nlines + if(keyword(iline,1).eq.'structure') then + itype = itype + 1 + + record = keyword(iline,2) + write(*,*) ' Reading coordinate file: ', trim(adjustl(record)) + + ! Reading pdb input files + + if(pdb) then + name(itype) = trim(adjustl(record)) + record = keyword(iline,2) + pdbfile(itype) = trim(record) + idfirst(itype) = 1 + idfirstatom = 0 + do ii = itype - 1, 1, -1 + idfirst(itype) = idfirst(itype) + natoms(ii) + end do + open(10,file=keyword(iline,2),status='old',iostat=ioerr) + if ( ioerr /= 0 ) call failopen(keyword(iline,2)) + ! Read coordinates + record(1:6) = '######' + do while(record(1:4).ne.'ATOM'.and.record(1:6).ne.'HETATM') + read(10,str_format) record + end do + idatom = idfirst(itype) - 1 + do while(idatom.lt.natoms(itype)+idfirst(itype)-1) + if(record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM') then + idatom = idatom + 1 + amass(idatom) = 1.d0 + maxcon(idatom) = 0 + ! Read the index of the first atom, to adjust connectivities, if any + if(idfirstatom == 0) read(record(7:11),*,iostat=ioerr) idfirstatom + read(record,"( t31,f8.3,t39,f8.3,t47,f8.3 )",iostat=ioerr) & + (coor(idatom,k),k=1,3) + if( ioerr /= 0 ) then + record = keyword(iline,2) + write(*,*) ' ERROR: Failed to read coordinates from', & + ' file: ', trim(adjustl(record)) + write(*,*) ' Probably the coordinates are not in', & + ' standard PDB file format. ' + write(*,*) ' Standard PDB format specifications', & + ' can be found at: ' + write(*,*) ' www.rcsb.org/pdb ' + stop exit_code_input_error + end if + + ! This only tests if residue numbers can be read, they are used + ! only for output + read(record(23:26),*,iostat=ioerr) itest + if( ioerr /= 0 ) then + record = pdbfile(itype) + write(*,*) ' ERROR: Failed reading residue number',& + ' from PDB file: ', trim(adjustl(record)) + write(*,*) ' Residue numbers are integers that',& + ' must be within columns 23 and 26. ' + write(*,*) ' Other characters within these columns',& + ' will cause input/output errors. ' + write(*,*) ' Standard PDB format specifications',& + ' can be found at: ' + write(*,*) ' www.rcsb.org/pdb ' + stop exit_code_input_error + end if + end if + read(10,str_format,iostat=ioerr) record + end do + ! + ! Read connectivity, if there is any specified + ! + do while(.true.) + if ( ioerr /= 0 ) exit + if(record(1:6).eq.'CONECT') then + iread = 7 + read(record(iread:iread+4),*,iostat=ioerr) iatom + iatom = iatom - idfirstatom + 1 + idatom = idfirst(itype) - 1 + iatom + if(ioerr /= 0) then + write(*,*) " ERROR: Could not read atom index from CONECT line: " + write(*,*) trim(adjustl(record)) + stop exit_code_input_error + end if + iread = iread + 5 + read(record(iread:iread+4),*,iostat=ioerr) nconnect(idatom,1) + if(ioerr /= 0) then + write(*,*) " ERROR: Could not read any connection index from CONECT line: " + write(*,*) trim(adjustl(record)) + stop exit_code_input_error + end if + nconnect(idatom,1) = nconnect(idatom,1) - idfirstatom + 1 + maxcon(idatom) = 1 + do while(.true.) + iread = iread + 5 + read(record(iread:iread+4),*,iostat=ioerr) nconnect(idatom,maxcon(idatom)+1) + if(ioerr == 0) then + maxcon(idatom) = maxcon(idatom) + 1 + nconnect(idatom,maxcon(idatom)) = nconnect(idatom,maxcon(idatom)) - idfirstatom + 1 + else + exit + end if + end do + end if + read(10,str_format,iostat=ioerr) record + end do + close(10) + end if + + ! Reading tinker input files + + if(tinker) then + open(10,file=keyword(iline,2),status='old',iostat=ioerr) + if ( ioerr /= 0 ) call failopen(keyword(iline,2)) + idfirst(itype) = 1 + do ii = itype - 1, 1, -1 + idfirst(itype) = idfirst(itype) + natoms(ii) + end do + record = keyword(iline,2) + call setcon(record(1:64),idfirst(itype)) + open(10,file = keyword(iline,2), status = 'old') + record = blank + do while(record.le.blank) + read(10,str_format) record + end do + i = 1 + do while(record(i:i).le.' ') + i = i + 1 + if ( i > strl ) exit + end do + iarg = i + if ( i < strl ) then + do while(record(i:i).gt.' ') + i = i + 1 + if ( i > strl ) exit + end do + end if + read(record(iarg:i-1),*) natoms(itype) + if ( i < strl ) then + do while(record(i:i).le.' ') + i = i + 1 + if ( i > strl ) exit + end do + end if + iarg = i + if ( i < strl ) then + do while(record(i:i).gt.' ') + i = i + 1 + if ( i > strl ) exit + end do + end if + read(record(iarg:i-1),str_format) name(itype) + record = name(itype) + name(itype) = trim(adjustl(record)) + if(name(itype).lt.' ') name(itype) = 'Without_title' + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + record = blank + do while(record.le.blank) + read(10,str_format) record + end do + i = 1 + do while(record(i:i).le.' ') + i = i + 1 + if ( i > strl ) exit + end do + iarg = i + if ( i < strl ) then + do while(record(i:i).gt.' ') + i = i + 1 + if ( i > strl ) exit + end do + end if + read(record(iarg:i-1),*) in + if ( i < strl ) then + do while(record(i:i).le.' ') + i = i + 1 + if ( i > strl ) exit + end do + end if + iarg = i + if ( i < strl ) then + do while(record(i:i).gt.' ') + i = i + 1 + if ( i > strl ) exit + end do + end if + read(record(iarg:i-1),*) ele(idatom) + read(record(i:strl),*) (coor(idatom,k), k = 1, 3),& + (nconnect(idatom, k), k = 1, maxcon(idatom)) + amass(idatom) = 1.d0 + end do + close(10) + end if + + ! Reading xyz input files + + if(xyz) then + open(10,file=keyword(iline,2),status='old',iostat=ioerr) + if ( ioerr /= 0 ) call failopen(keyword(iline,2)) + read(10,*) natoms(itype) + read(10,str_format) name(itype) + if(name(itype).lt.' ') name(itype) = 'Without_title' + idfirst(itype) = 1 + do ii = itype - 1, 1, -1 + idfirst(itype) = idfirst(itype) + natoms(ii) + end do + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + record = blank + read(10,str_format) record + read(record,*) ele(idatom), (coor(idatom,k),k=1,3) + amass(idatom) = 1.d0 + end do + close(10) + end if + + ! Reading moldy input files + + if(moldy) then + open(10,file=keyword(iline,2), status ='old',iostat=ioerr) + if ( ioerr /= 0 ) call failopen(keyword(iline,2)) + read(10,*) name(itype), nmols(itype) + natoms(itype) = 0 + do while(.true.) + read(10,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + if(record.gt.' '.and.record(1:3).ne.'end') & + natoms(itype) = natoms(itype) + 1 + end do + close(10) + idfirst(itype) = 1 + do ii = itype - 1, 1, -1 + idfirst(itype) = idfirst(itype) + natoms(ii) + end do + open(10,file=keyword(iline,2),status='old') + read(10,str_format) record + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + read(10,str_format) record + read(record,*) lixo, (coor(idatom,k), k = 1, 3),& + amass(idatom), charge(idatom), ele(idatom) + end do + close(10) + end if + end if + + end do + ntype = itype + + write(*,*) ' Number of independent structures: ', ntype + write(*,*) ' The structures are: ' + + do itype = 1, ntype + record = name(itype) + write(*,*) ' Structure ', itype, ':', trim(adjustl(record)),& + '(',natoms(itype),' atoms)' + end do + + ! Setting the vectors for the number of GENCAN loops + + if(nloop.eq.0) then + nloop_all = 200*ntype + nloop = nloop_all + else + nloop_all = nloop + end if + write(*,*) ' Maximum number of GENCAN loops for all molecule packing: ', nloop_all + do itype = 1, ntype + if ( nloop_type(itype) == 0 ) then + nloop_type(itype) = nloop_all + else + write(*,*) ' Maximum number of GENCAN loops for type: ', itype, ': ', nloop_type(itype) + end if + end do + + ! nloop0 are the number of loops for the initial phase packing + + if(nloop0.eq.0) then + nloop0 = 20*ntype + else + write(*,*) ' Maximum number of GENCAN loops-0 for all molecule packing: ', nloop0 + end if + do itype = 1, ntype + if ( nloop0_type(itype) == 0 ) then + nloop0_type(itype) = nloop0 + else + write(*,*) ' Maximum number of GENCAN loops-0 for type: ', itype, ': ', nloop0_type(itype) + end if + end do + + ! Reading the restrictions that were set + + irest = 0 + ioerr = 0 + do iline = 1, nlines + + if(keyword(iline,1).eq.'fixed') then + irest = irest + 1 + irestline(irest) = iline + ityperest(irest) = 1 + read(keyword(iline,2),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,4) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,5) + read(keyword(iline,7),*,iostat=ioerr) restpars(irest,6) + end if + + if(keyword(iline,1).eq.'inside') then + irest = irest + 1 + irestline(irest) = iline + if(keyword(iline,2).eq.'cube') then + ityperest(irest) = 2 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + else if(keyword(iline,2).eq.'box') then + ityperest(irest) = 3 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) + read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) + else if(keyword(iline,2).eq.'sphere') then + ityperest(irest) = 4 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + else if(keyword(iline,2).eq.'ellipsoid') then + ityperest(irest) = 5 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) + read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) + read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) + else if(keyword(iline,2).eq.'cylinder') then + ityperest(irest) = 12 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) + read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) + read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) + read(keyword(iline,10),*,iostat=ioerr) restpars(irest,9) + restpars(irest,8) = restpars(irest,4)**2 + & + restpars(irest,5)**2 + & + restpars(irest,6)**2 + if(restpars(irest,8).lt.1.d-10) then + write(*,*) ' ERROR: The norm of the director vector', & + ' of the cylinder constraint cannot be zero.' + ioerr = 1 + else + clen = dsqrt(restpars(irest,8)) + restpars(irest,4) = restpars(irest,4) / clen + restpars(irest,5) = restpars(irest,5) / clen + restpars(irest,6) = restpars(irest,6) / clen + end if + else + ioerr = 1 + end if + end if + + if(keyword(iline,1).eq.'outside') then + irest = irest + 1 + irestline(irest) = iline + if(keyword(iline,2).eq.'cube') then + ityperest(irest) = 6 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + else if(keyword(iline,2).eq.'box') then + ityperest(irest) = 7 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) + read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) + else if(keyword(iline,2).eq.'sphere') then + ityperest(irest) = 8 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + else if(keyword(iline,2).eq.'ellipsoid') then + ityperest(irest) = 9 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) + read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) + read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) + else if(keyword(iline,2).eq.'cylinder') then + ityperest(irest) = 13 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) + read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) + read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) + read(keyword(iline,10),*,iostat=ioerr) restpars(irest,9) + restpars(irest,8) = restpars(irest,4)**2 + & + restpars(irest,5)**2 + & + restpars(irest,6)**2 + if(restpars(irest,8).lt.1.d-10) then + write(*,*) ' ERROR: The norm of the director vector',& + ' of the cylinder constraint cannot be zero.' + ioerr = 1 + else + clen = dsqrt(restpars(irest,8)) + restpars(irest,4) = restpars(irest,4) / clen + restpars(irest,5) = restpars(irest,5) / clen + restpars(irest,6) = restpars(irest,6) / clen + end if + else + ioerr = 1 + end if + end if + + if(keyword(iline,1).eq.'over' .or. keyword(iline,1).eq.'above') then + irest = irest + 1 + irestline(irest) = iline + ityperest(irest) = 10 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + if(keyword(iline,2).ne.'plane') ioerr = 1 + end if + + if(keyword(iline,1).eq.'below') then + irest = irest + 1 + irestline(irest) = iline + ityperest(irest) = 11 + read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) + read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) + read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) + read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) + if(keyword(iline,2).ne.'plane') ioerr = 1 + end if + + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Some restriction is not set correctly. ' + stop exit_code_input_error + end if + + end do + nrest = irest + write(*,*) ' Total number of restrictions: ', nrest + + ! Getting the tolerance + + ioerr = 1 + dism = -1.d0 + do iline = 1, nlines + if(keyword(iline,1).eq.'tolerance') then + read(keyword(iline,2),*,iostat=ioerr) dism + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Failed reading tolerance. ' + stop exit_code_input_error + end if + exit + end if + end do + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Overall tolerance not set. Use, for example: tolerance 2.0 ' + stop exit_code_input_error + end if + write(*,*) ' Distance tolerance: ', dism + + ! Reading, if defined, the short distance penalty parameters + + ioerr = 1 + short_tol_dist = dism/2.d0 + ! Reading short_tol_dist + do iline = 1, nlines + if(keyword(iline,1).eq.'short_tol_dist') then + read(keyword(iline,2),*,iostat=ioerr) short_tol_dist + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Failed reading short_tol_dist. ' + stop exit_code_input_error + end if + if ( short_tol_dist > dism ) then + write(*,*) ' ERROR: The short_tol_dist parameter must be smaller than the tolerance. ' + stop exit_code_input_error + end if + write(*,*) ' User defined short tolerance distance: ', short_tol_dist + short_tol_dist = short_tol_dist**2 + exit + end if + end do + ! Reading short_tol_scale + short_tol_scale = 3.d0 + do iline = 1, nlines + if(keyword(iline,1).eq.'short_tol_scale') then + read(keyword(iline,2),*,iostat=ioerr) short_tol_scale + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Failed reading short_tol_scale. ' + stop exit_code_input_error + end if + if ( short_tol_dist <= 0.d0 ) then + write(*,*) ' ERROR: The short_tol_scale parameter must be positive. ' + stop exit_code_input_error + end if + write(*,*) ' User defined short tolerance scale: ', short_tol_scale + exit + end if + end do + + ! Assigning the input lines that correspond to each structure + + itype = 0 + iline = 0 + do while(iline < nlines) + iline = iline + 1 + if(keyword(iline,1).eq.'structure') then + itype = itype + 1 + linestrut(itype,1) = iline + iline = iline + 1 + do while(keyword(iline,1).ne.'end'.or.& + keyword(iline,2).ne.'structure') + if(keyword(iline,1) == 'structure'.or.& + iline == nlines) then + write(*,*) ' ERROR: Structure specification not ending with "end structure"' + stop exit_code_input_error + end if + iline = iline + 1 + end do + linestrut(itype,2) = iline + end if + end do + + ! If pdb files, get the type of residue numbering output for each + ! molecule + + if(pdb) then + do itype = 1, ntype + connect(itype) = .true. + resnumbers(itype) = -1 + changechains(itype) = .false. + chain(itype) = "#" + segid(itype) = "" + maxmove(itype) = nmols(itype) + do iline = 1, nlines + if(iline.gt.linestrut(itype,1).and.& + iline.lt.linestrut(itype,2)) then + if(keyword(iline,1).eq.'changechains') then + changechains(itype) = .true. + end if + if(keyword(iline,1).eq.'maxmove') then + read(keyword(iline,2),*) maxmove(itype) + end if + if(keyword(iline,1).eq.'resnumbers') then + read(keyword(iline,2),*) resnumbers(itype) + end if + if(keyword(iline,1).eq.'connect') then + if(keyword(iline,2) == "no") then + connect(itype) = .false. + end if + end if + if(keyword(iline,1).eq.'chain') then + read(keyword(iline,2),*) chain(itype) + end if + if(keyword(iline,1).eq.'segid') then + read(keyword(iline,2),*) segid(itype) + end if + end if + end do + if (crd) then + if (itype.gt.1 .and. segid(itype)=="") then + if (segid(itype-1) /= "") then + write(*,*) ' Warning: Type of segid not defined for ', itype,'. Keeping it same as previous' + endif + segid(itype) = segid(itype-1) + endif + endif + if ( resnumbers(itype) == -1 ) then + write(*,*) ' Warning: Type of residue numbering not',& + ' set for structure ',itype + call setrnum(pdbfile(itype),imark) + if(imark.eq.1) resnumbers(itype) = 0 + if(imark.gt.1) resnumbers(itype) = 1 + end if + write(*,*) ' Residue numbering set for structure ',itype,':',& + resnumbers(itype) + write(*,*) ' Swap chains of molecules of structure ',& + itype,':', changechains(itype) + if ( chain(itype) /= "#" ) then + write(*,*) ' Specific chain identifier set for structure ',itype,':',chain(itype) + end if + if ( chain(itype) /= "#" .and. changechains(itype) ) then + write(*,*) " ERROR: 'changechains' and 'chain' input parameters are not compatible " + write(*,*) " for a single structure. " + stop exit_code_input_error + end if + end do + end if + + ! Write the number of molecules of each type + + do itype = 1, ntype + write(*,*) ' Number of molecules of type ', itype, ': ', nmols(itype) + if(pdb.and.nmols(itype).gt.9999) then + write(*,*) ' Warning: There will be more than 9999 molecules of type ',itype + if (.not. crd) write(*,*) ' Residue numbering is reset after 9999. ' + if (crd) write(*,*) ' Residue numbering is reset after 9999 in pdb but not in crd. ' + if ( chain(itype) == "#" ) then + write(*,*) ' Each set be will be assigned a different chain in the PDB output file. ' + end if + end if + if(crd.and.nmols(itype).gt.99999999) then + write(*,*) ' Warning: There will be more than 99999999 molecules of type ',itype + write(*,*) ' Residue numbering is reset after 99999999 in crd. ' + endif + end do + + ! Checking if restart files will be used for each structure or for the whole system + + restart_from(0) = "none" + restart_to(0) = "none" + do itype = 1, ntype + restart_from(itype) = "none" + restart_to(itype) = "none" + end do + lines: do iline = 1, nlines + if ( keyword(iline,1) == 'restart_from' ) then + do itype = 1, ntype + if(iline.gt.linestrut(itype,1).and.& + iline.lt.linestrut(itype,2)) then + restart_from(itype) = keyword(iline,2) + cycle lines + end if + end do + if( restart_from(0) == 'none' ) then + restart_from(0) = keyword(iline,2) + else + write(*,*) ' ERROR: More than one definition of restart_from file for all system. ' + stop exit_code_input_error + end if + end if + if ( keyword(iline,1) == 'restart_to' ) then + do itype = 1, ntype + if(iline.gt.linestrut(itype,1).and.& + iline.lt.linestrut(itype,2)) then + restart_to(itype) = keyword(iline,2) + cycle lines + end if + end do + if( restart_to(0) == 'none' ) then + restart_to(0) = keyword(iline,2) + else + write(*,*) ' ERROR: More than one definition of restart_to file for all system. ' + stop exit_code_input_error + end if + end if + end do lines + + return +end subroutine getinp + +! +! Subroutine that stops if failed to open file +! + +subroutine failopen(record) + use exit_codes + use sizes + character(len=strl) :: record + write(*,*) + write(*,*) ' ERROR: Could not open file. ' + write(*,*) ' Could not find file: ',trim(record) + write(*,*) ' Please check if all the input and structure ' + write(*,*) ' files are in the current directory or if the' + write(*,*) ' correct paths are provided.' + write(*,*) + stop exit_code_open_file +end subroutine failopen + +! +! Subroutine that checks if a pdb structure has one or more than +! one residue +! + +subroutine setrnum(file,nres) + + use sizes + implicit none + integer :: iread, ires, ireslast, nres, ioerr + character(len=strl) :: file + character(len=strl) :: record + + open(10,file=file,status='old') + iread = 0 + nres = 1 + do while(nres.eq.1) + read(10,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + if(record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM') then + read(record(23:26),*,iostat=ioerr) ires + if ( ioerr /= 0 ) cycle + iread = iread + 1 + if(iread.gt.1) then + if(ires.ne.ireslast) then + nres = 2 + close(10) + return + end if + end if + ireslast = ires + end if + end do + close(10) + + return +end subroutine setrnum + +! +! Subroutine that computes de number of connections of each atom +! for tinker xyz files +! + +subroutine setcon(xyzfile,idfirst) + + use sizes + use input, only : maxcon + implicit none + + integer :: idfirst + integer :: natoms, idatom, iatom, ic, i + character(len=64) :: xyzfile + character(len=120) :: record + + open(10, file = xyzfile, status='old') + read(10,*) natoms + idatom = idfirst - 1 + do iatom = 1, natoms + idatom = idatom + 1 + read(10,"( a120 )") record + ic = 0 + do i = 1, 119 + if(record(i:i).gt.' '.and.record(i+1:i+1).le.' ') ic = ic + 1 + end do + maxcon(idatom) = ic - 5 + end do + close(10) + + return +end subroutine setcon + +! +! Subroutine getkeywords: gets keywords and values from the input +! file in a more robust way +! + +subroutine getkeywords() + + use sizes + use input, only : keyword, nlines, inputfile, forbidden_char + implicit none + character(len=strl) :: record + integer :: iline, i, j, k, ilast, ival, ioerr + + ! Clearing keyword array + + do i = 1, nlines + do j = 1, maxkeywords + keyword(i,j) = 'none' + end do + end do + + ! Filling keyword array + do iline = 1, nlines + read(inputfile(iline),str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + i = 0 + ival = 0 + do while(i < strl) + i = i + 1 + ilast = i + do while(record(i:i) > ' '.and. i < strl) + i = i + 1 + end do + if(i.gt.ilast) then + ival = ival + 1 + keyword(iline,ival) = record(ilast:i) + end if + end do + end do + + ! Remove quotes and the forbidden_char from keywords + do i = 1, nlines + do j = 1, maxkeywords + record = keyword(i,j) + do k = 1,strl + if (record(k:k) == forbidden_char .or. record(k:k) == '"') then + record(k:k) = " " + end if + end do + keyword(i,j) = trim(adjustl(record)) + end do + end do + + return +end subroutine getkeywords + +! Subroutine that returns the chain character given an index + +subroutine chainc(i,chain) + + implicit none + integer :: i + character :: chain + + if(i.eq.0) chain = ' ' + if(i.eq.1) chain = 'A' + if(i.eq.2) chain = 'B' + if(i.eq.3) chain = 'C' + if(i.eq.4) chain = 'D' + if(i.eq.5) chain = 'E' + if(i.eq.6) chain = 'F' + if(i.eq.7) chain = 'G' + if(i.eq.8) chain = 'H' + if(i.eq.9) chain = 'I' + if(i.eq.10) chain = 'J' + if(i.eq.11) chain = 'K' + if(i.eq.12) chain = 'L' + if(i.eq.13) chain = 'M' + if(i.eq.14) chain = 'N' + if(i.eq.15) chain = 'O' + if(i.eq.16) chain = 'P' + if(i.eq.17) chain = 'Q' + if(i.eq.18) chain = 'R' + if(i.eq.19) chain = 'S' + if(i.eq.20) chain = 'T' + if(i.eq.21) chain = 'U' + if(i.eq.22) chain = 'V' + if(i.eq.23) chain = 'W' + if(i.eq.24) chain = 'X' + if(i.eq.25) chain = 'Y' + if(i.eq.26) chain = 'Z' + if(i.eq.27) chain = '1' + if(i.eq.28) chain = '2' + if(i.eq.29) chain = '3' + if(i.eq.30) chain = '4' + if(i.eq.31) chain = '5' + if(i.eq.32) chain = '6' + if(i.eq.33) chain = '7' + if(i.eq.34) chain = '8' + if(i.eq.35) chain = '9' + if(i.eq.36) chain = '0' + if(i.gt.36) chain = '#' + + return +end subroutine chainc + +! Subroutine that clears a character variable + +subroutine clear(record) + + use sizes + integer :: i + character(len=strl) :: record + + do i = 1, strl + record(i:i) = ' ' + end do + + return +end subroutine clear + diff --git a/src/gparc.f90 b/src/gparc.f90 new file mode 100644 index 0000000..a604254 --- /dev/null +++ b/src/gparc.f90 @@ -0,0 +1,87 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Compute gradient relative to atom-to-atom distances +! + +subroutine gparc(icart,firstjcart) + + use sizes + use compute_data + implicit none + + ! SCALAR ARGUMENTS + integer :: icart,firstjcart + + ! LOCAL SCALARS + integer :: jcart + double precision :: datom, dtemp, xdiff, tol, & + short_tol, short_tol_scale + + jcart = firstjcart + do while ( jcart .ne. 0 ) + ! + ! Cycle if this type is not to be computed + ! + if ( .not. comptype(ibtype(jcart))) then + jcart = latomnext(jcart) + cycle + end if + ! + ! Cycle if the atoms are from the same molecule + ! + if ( ibmol(icart) == ibmol(jcart) .and. & + ibtype(icart) == ibtype(jcart) ) then + jcart = latomnext(jcart) + cycle + end if + ! + ! Cycle if both atoms are from fixed molecules + ! + if ( fixedatom(icart) .and. fixedatom(jcart) ) then + jcart = latomnext(jcart) + cycle + end if + ! + ! Otherwise, compute distance and evaluate function for this pair + ! + tol = (radius(icart)+radius(jcart))**2 + datom = (xcart(icart, 1)-xcart(jcart, 1))**2 + & + (xcart(icart, 2)-xcart(jcart, 2))**2 + & + (xcart(icart, 3)-xcart(jcart, 3))**2 + if( datom < tol ) then + dtemp = fscale(icart)*fscale(jcart) * 4.d0 * (datom - tol) + xdiff = dtemp*(xcart(icart,1) - xcart(jcart,1)) + gxcar(icart,1)= gxcar(icart,1) + xdiff + gxcar(jcart,1)= gxcar(jcart,1) - xdiff + xdiff = dtemp*(xcart(icart,2) - xcart(jcart,2)) + gxcar(icart,2)= gxcar(icart,2) + xdiff + gxcar(jcart,2)= gxcar(jcart,2) - xdiff + xdiff = dtemp*(xcart(icart,3) - xcart(jcart,3)) + gxcar(icart,3)= gxcar(icart,3) + xdiff + gxcar(jcart,3)= gxcar(jcart,3) - xdiff + if ( use_short_radius(icart) .or. use_short_radius(jcart) ) then + short_tol = ( short_radius(icart) + short_radius(jcart) )**2 + if ( datom < short_tol ) then + short_tol_scale = dsqrt(short_radius_scale(icart)*short_radius_scale(jcart)) + short_tol_scale = short_tol_scale*( tol**2 / short_tol**2 ) + dtemp = fscale(icart)*fscale(jcart) * 4.d0 * short_tol_scale*(datom - short_tol) + xdiff = dtemp*(xcart(icart,1) - xcart(jcart,1)) + gxcar(icart,1)= gxcar(icart,1) + xdiff + gxcar(jcart,1)= gxcar(jcart,1) - xdiff + xdiff = dtemp*(xcart(icart,2) - xcart(jcart,2)) + gxcar(icart,2)= gxcar(icart,2) + xdiff + gxcar(jcart,2)= gxcar(jcart,2) - xdiff + xdiff = dtemp*(xcart(icart,3) - xcart(jcart,3)) + gxcar(icart,3)= gxcar(icart,3) + xdiff + gxcar(jcart,3)= gxcar(jcart,3) - xdiff + end if + end if + end if + jcart = latomnext(jcart) + end do + return +end subroutine gparc + diff --git a/src/gwalls.f90 b/src/gwalls.f90 new file mode 100644 index 0000000..9b632b4 --- /dev/null +++ b/src/gwalls.f90 @@ -0,0 +1,264 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Gradient relative to restraints +! + +subroutine gwalls(icart,irest) + + use sizes + use compute_data + + implicit none + integer :: icart, irest + double precision :: a1, a2, a3, a4, a5, a6, xmin, ymin, zmin, & + xmax, ymax, zmax, & + clength, b1, b2, b3, c1, c2, w, d, rg(3), & + vnorm, vv1, vv2, vv3, frab, frac, frbc, & + dfra(3), dfrb(3), dfrc(3) + + if(ityperest(irest).eq.2) then + clength = restpars(irest,4) + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,1) + clength + ymax = restpars(irest,2) + clength + zmax = restpars(irest,3) + clength + a1 = xcart(icart,1) - xmin + a2 = xcart(icart,2) - ymin + a3 = xcart(icart,3) - zmin + if(a1.lt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 + if(a2.lt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 + if(a3.lt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 + a1 = xcart(icart,1) - xmax + a2 = xcart(icart,2) - ymax + a3 = xcart(icart,3) - zmax + if(a1.gt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 + if(a2.gt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 + if(a3.gt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 + else if(ityperest(irest).eq.3) then + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,4) + ymax = restpars(irest,5) + zmax = restpars(irest,6) + a1 = xcart(icart,1) - xmin + a2 = xcart(icart,2) - ymin + a3 = xcart(icart,3) - zmin + if(a1.lt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 + if(a2.lt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 + if(a3.lt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 + a1 = xcart(icart,1) - xmax + a2 = xcart(icart,2) - ymax + a3 = xcart(icart,3) - zmax + if(a1.gt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 + if(a2.gt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 + if(a3.gt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 + else if(ityperest(irest).eq.4) then + d = (xcart(icart,1)-restpars(irest,1))**2 + & + (xcart(icart,2)-restpars(irest,2))**2 + & + (xcart(icart,3)-restpars(irest,3))**2 - & + restpars(irest,4)**2 + if(d.gt.0.d0) then + gxcar(icart,1) = gxcar(icart,1) + 4.d0 * scale2 * & + (xcart(icart,1)-restpars(irest,1))*d + gxcar(icart,2) = gxcar(icart,2) + 4.d0 * scale2 * & + (xcart(icart,2)-restpars(irest,2))*d + gxcar(icart,3) = gxcar(icart,3) + 4.d0 * scale2 * & + (xcart(icart,3)-restpars(irest,3))*d + end if + else if(ityperest(irest).eq.5) then + a1 = xcart(icart,1)-restpars(irest,1) + b1 = xcart(icart,2)-restpars(irest,2) + c1 = xcart(icart,3)-restpars(irest,3) + a2 = restpars(irest,4)**2 + b2 = restpars(irest,5)**2 + c2 = restpars(irest,6)**2 + d = a1**2/a2+b1**2/b2+c1**2/c2-restpars(irest,7)**2 + if(d.gt.0) then + gxcar(icart,1) = gxcar(icart,1) + scale2*4.d0*d*a1/a2 + gxcar(icart,2) = gxcar(icart,2) + scale2*4.d0*d*b1/b2 + gxcar(icart,3) = gxcar(icart,3) + scale2*4.d0*d*c1/c2 + end if + else if(ityperest(irest).eq.6) then + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,1) + restpars(irest,4) + ymax = restpars(irest,2) + restpars(irest,4) + zmax = restpars(irest,3) + restpars(irest,4) + a1 = dmax1(xcart(icart,1) - xmin,0.d0) + a2 = dmax1(xcart(icart,2) - ymin,0.d0) + a3 = dmax1(xcart(icart,3) - zmin,0.d0) + a4 = dmax1(xmax - xcart(icart,1),0.d0) + a5 = dmax1(ymax - xcart(icart,2),0.d0) + a6 = dmax1(zmax - xcart(icart,3),0.d0) + w = a1*a2*a3*a4*a5*a6 + if(w.gt.0.d0) then + gxcar(icart,1) = gxcar(icart,1) + a2*a3*a5*a6*(a4-a1) + gxcar(icart,2) = gxcar(icart,2) + a1*a3*a4*a6*(a5-a2) + gxcar(icart,3) = gxcar(icart,3) + a1*a2*a4*a5*(a6-a3) + end if + else if(ityperest(irest).eq.7) then + xmin = restpars(irest,1) + ymin = restpars(irest,2) + zmin = restpars(irest,3) + xmax = restpars(irest,4) + ymax = restpars(irest,5) + zmax = restpars(irest,6) + a1 = dmax1(xcart(icart,1) - xmin,0.d0) + a2 = dmax1(xcart(icart,2) - ymin,0.d0) + a3 = dmax1(xcart(icart,3) - zmin,0.d0) + a4 = dmax1(xmax - xcart(icart,1),0.d0) + a5 = dmax1(ymax - xcart(icart,2),0.d0) + a6 = dmax1(zmax - xcart(icart,3),0.d0) + w = a1*a2*a3*a4*a5*a6 + if(w.gt.0.d0) then + gxcar(icart,1) = gxcar(icart,1) + a2*a3*a5*a6*(a4-a1) + gxcar(icart,2) = gxcar(icart,2) + a1*a3*a4*a6*(a5-a2) + gxcar(icart,3) = gxcar(icart,3) + a1*a2*a4*a5*(a6-a3) + end if + else if(ityperest(irest).eq.8) then + d = (xcart(icart,1)-restpars(irest,1))**2 + & + (xcart(icart,2)-restpars(irest,2))**2 + & + (xcart(icart,3)-restpars(irest,3))**2 - & + restpars(irest,4)**2 + if(d.lt.0.d0) then + gxcar(icart,1) = gxcar(icart,1) + 4.d0 * scale2 * & + (xcart(icart,1)-restpars(irest,1))*d + gxcar(icart,2) = gxcar(icart,2) + 4.d0 * scale2 * & + (xcart(icart,2)-restpars(irest,2))*d + gxcar(icart,3) = gxcar(icart,3) + 4.d0 * scale2 * & + (xcart(icart,3)-restpars(irest,3))*d + end if + else if(ityperest(irest).eq.9) then + a1 = xcart(icart,1)-restpars(irest,1) + b1 = xcart(icart,2)-restpars(irest,2) + c1 = xcart(icart,3)-restpars(irest,3) + a2 = restpars(irest,4)**2 + b2 = restpars(irest,5)**2 + c2 = restpars(irest,6)**2 + d = a1**2/a2+b1**2/b2+c1**2/c2-restpars(irest,7)**2 + if(d.lt.0) then + d = scale2 * d + gxcar(icart,1) = gxcar(icart,1) + 4.d0*d*a1/a2 + gxcar(icart,2) = gxcar(icart,2) + 4.d0*d*b1/b2 + gxcar(icart,3) = gxcar(icart,3) + 4.d0*d*c1/c2 + end if + else if(ityperest(irest).eq.10) then + d = restpars(irest,1)*xcart(icart,1) + & + restpars(irest,2)*xcart(icart,2) + & + restpars(irest,3)*xcart(icart,3) - & + restpars(irest,4) + if(d.lt.0.d0) then + d = scale * d + gxcar(icart,1) = gxcar(icart,1) + 2.d0*restpars(irest,1)*d + gxcar(icart,2) = gxcar(icart,2) + 2.d0*restpars(irest,2)*d + gxcar(icart,3) = gxcar(icart,3) + 2.d0*restpars(irest,3)*d + end if + else if(ityperest(irest).eq.11) then + d = restpars(irest,1)*xcart(icart,1) + & + restpars(irest,2)*xcart(icart,2) + & + restpars(irest,3)*xcart(icart,3) - & + restpars(irest,4) + if(d.gt.0.d0) then + d = scale * d + gxcar(icart,1) = gxcar(icart,1) + 2.d0*restpars(irest,1)*d + gxcar(icart,2) = gxcar(icart,2) + 2.d0*restpars(irest,2)*d + gxcar(icart,3) = gxcar(icart,3) + 2.d0*restpars(irest,3)*d + end if + else if(ityperest(irest).eq.12) then + rg(1) = 0.0d0 + rg(2) = 0.0d0 + rg(3) = 0.0d0 + a1 = xcart(icart,1) - restpars(irest,1) + a2 = xcart(icart,2) - restpars(irest,2) + a3 = xcart(icart,3) - restpars(irest,3) + vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 & + + restpars(irest,6)**2) + vv1 = restpars(irest,4)/vnorm + vv2 = restpars(irest,5)/vnorm + vv3 = restpars(irest,6)/vnorm + b1 = vv1 * a1 + b2 = vv2 * a2 + b3 = vv3 * a3 + w = b1 + b2 + b3 + d = (a1 - vv1*w)**2 + (a2 - vv2*w)**2 + (a3 - vv3*w)**2 + rg(1) = scale2 * ( & + -2*dmax1(-w , 0.d0) * vv1 + & + 2*dmax1(w - restpars(irest,9), 0.d0) * vv1 + & + 2*dmax1(d - restpars(irest,7)**2 , 0.d0) * & + (2*(a1 - vv1*w)*(1 - vv1**2)+ & + 2*(a2 - vv2*w)*(-vv2*vv1)+ & + 2*(a3 - vv3*w)*(-vv3*vv1) )) + rg(2) = scale2 * ( & + -2*dmax1(-w , 0.d0) * vv2 + & + 2*dmax1(w - restpars(irest,9), 0.d0) * vv2 + & + 2*dmax1(d - restpars(irest,7)**2 , 0.d0) * & + (2*(a1 - vv1*w)*(-vv1*vv2)+ & + 2*(a2 - vv2*w)*(1 - vv2**2)+ & + 2*(a3 - vv3*w)*(-vv3*vv2) )) + rg(3) = scale2 * ( & + -2*dmax1(-w , 0.d0) * vv3 + & + 2*dmax1(w - restpars(irest,9), 0.d0) * vv3 + & + 2*dmax1(d - restpars(irest,7)**2 , 0.d0) * & + (2*(a1 - vv1*w)*(-vv1*vv3)+ & + 2*(a2 - vv2*w)*(-vv2*vv3)+ & + 2*(a3 - vv3*w)*(1 - vv3**2) )) + gxcar(icart,1) = gxcar(icart,1) + rg(1) + gxcar(icart,2) = gxcar(icart,2) + rg(2) + gxcar(icart,3) = gxcar(icart,3) + rg(3) + else if(ityperest(irest).eq.13) then + rg(1) = 0.0d0 + rg(2) = 0.0d0 + rg(3) = 0.0d0 + a1 = xcart(icart,1) - restpars(irest,1) + a2 = xcart(icart,2) - restpars(irest,2) + a3 = xcart(icart,3) - restpars(irest,3) + vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 & + + restpars(irest,6)**2) + vv1 = restpars(irest,4)/vnorm + vv2 = restpars(irest,5)/vnorm + vv3 = restpars(irest,6)/vnorm + b1 = vv1 * a1 + b2 = vv2 * a2 + b3 = vv3 * a3 + w = b1 + b2 + b3 + d = (a1 - vv1*w)**2 + (a2 - vv2*w)**2 + (a3 - vv3*w)**2 + frab = dmin1(-w , 0.d0)**2 * dmin1(w - restpars(irest,9), 0.d0)**2 + frac = dmin1(-w , 0.d0)**2 * dmin1(d - restpars(irest,7)**2 , 0.d0 )**2 + frbc = dmin1(w - restpars(irest,9), 0.d0)**2 * & + dmin1(d - restpars(irest,7)**2 , 0.d0 )**2 + dfra(1) = -2*dmin1(-w , 0.d0) * vv1 + dfrb(1) = 2*dmin1(w - restpars(irest,9), 0.d0) * vv1 + dfrc(1) = 2*dmin1(d - restpars(irest,7)**2 , 0.d0) * & + (2*(a1 - vv1*w)*(1 - vv1**2)+ & + 2*(a2 - vv2*w)*(-vv2*vv1)+ & + 2*(a3 - vv3*w)*(-vv3*vv1) ) + dfra(2) = -2*dmin1(-w , 0.d0) * vv2 + dfrb(2) = 2*dmin1(w - restpars(irest,9), 0.d0) * vv2 + dfrc(2) = 2*dmin1(d - restpars(irest,7)**2 , 0.d0) * & + (2*(a1 - vv1*w)*(-vv1*vv2)+ & + 2*(a2 - vv2*w)*(1 - vv2**2)+ & + 2*(a3 - vv3*w)*(-vv3*vv2) ) + dfra(3) = -2*dmin1(-w , 0.d0) * vv3 + dfrb(3) = 2*dmin1(w - restpars(irest,9), 0.d0) * vv3 + dfrc(3) = 2*dmin1(d - restpars(irest,7)**2 , 0.d0) * & + (2*(a1 - vv1*w)*(-vv1*vv3)+ & + 2*(a2 - vv2*w)*(-vv2*vv3)+ & + 2*(a3 - vv3*w)*(1 - vv3**2) ) + rg(1) = scale2 * ( dfra(1)*frbc + dfrb(1)*frac + dfrc(1)*frab) + rg(2) = scale2 * ( dfra(2)*frbc + dfrb(2)*frac + dfrc(2)*frab) + rg(3) = scale2 * ( dfra(3)*frbc + dfrb(3)*frac + dfrc(3)*frab) + gxcar(icart,1) = gxcar(icart,1) + rg(1) + gxcar(icart,2) = gxcar(icart,2) + rg(2) + gxcar(icart,3) = gxcar(icart,3) + rg(3) + end if + + return +end subroutine gwalls + diff --git a/src/heuristics.f90 b/src/heuristics.f90 new file mode 100644 index 0000000..02d2280 --- /dev/null +++ b/src/heuristics.f90 @@ -0,0 +1,151 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! subroutine movebad: Move the worse molecules to new positions +! + +subroutine movebad(n,x,fx,movebadprint) + + use sizes + use compute_data + use input, only : movefrac, movebadrandom, precision, maxmove + use usegencan + use flashsort + use ahestetic + implicit none + + ! Internal variables + integer :: n, i, j, icart, itype, iatom, imol, ilubar, ilugan, & + ilubar2, ilugan2, nbad, igood, ibad, nmove + double precision :: x(n), fx, rnd, frac + double precision :: fdist_mol, frest_mol + logical :: movebadprint, hasbad + + if(movebadprint) write(*,*) ' Moving worst molecules ... ' + + icart = 0 + do itype = 1, ntype + if(.not.comptype(itype)) then + icart = icart + nmols(itype)*natoms(itype) + else + do imol = 1, nmols(itype) + do iatom = 1, natoms(itype) + icart = icart + 1 + fdist_atom(icart) = 0.d0 + frest_atom(icart) = 0.d0 + end do + end do + end if + end do + + move = .true. + if(movebadprint) write(*,*) ' Function value before moving molecules:',fx + do i = 1, ntotat + radiuswork(i) = radius(i) + radius(i) = radius_ini(i) + end do + call computef(n,x,fx) + move = .false. + + ! Moving the worst molecules + + hasbad = .false. + icart = 0 + do itype = 1, ntype + if(.not.comptype(itype)) then + icart = icart + nmols(itype)*natoms(itype) + else + + ! Checking the function value for each molecule + + nbad = 0 + do imol = 1, nmols(itype) + fdist_mol = 0.d0 + frest_mol = 0.d0 + do iatom = 1, natoms(itype) + icart = icart + 1 + fdist_mol = dmax1(fdist_mol,fdist_atom(icart)) + frest_mol = dmax1(frest_mol,frest_atom(icart)) + end do + if(fdist_mol > precision .or. & + frest_mol > precision ) then + hasbad = .true. + nbad = nbad + 1 + fmol(imol) = fdist_mol + frest_mol + else + fmol(imol) = 0.d0 + end if + end do + frac = dfloat(nbad)/dfloat(nmols(itype)) + if(movebadprint) write(*,"( a,i9,a,f8.2,a )") & + ' Type ',itype,' molecules with non-zero contributions:', & + 100.d0*frac,'%' + + if(nbad.gt.0) then + + frac = dmin1(movefrac,frac) + + ! Ordering molecules from best to worst + + mflash = 1 + nmols(itype)/10 + call flash1(fmol,nmols(itype),lflash,mflash,indflash) + + ! Moving molecules + + nmove = min0(maxmove(itype),max0(int(nmols(itype)*frac),1)) + if(movebadprint) then + write(*,"( a,i9,a,i9 )") ' Moving ',nmove,' molecules of type ',itype + if ( movebadrandom ) then + write(*,*) ' New positions will be aleatory (movebadrandom is set) ' + else + write(*,*) ' New positions will be based on good molecules (movebadrandom is not set) ' + end if + end if + imol = 0 + do i = 1, itype - 1 + if(comptype(i)) imol = imol + nmols(i) + end do + write(*,prog2_line) + write(*,"( ' |',$)") + j = 0 + do i = 1, nmove + ibad = nmols(itype) - i + 1 + igood = int(rnd()*nmols(itype)*frac) + 1 + ilubar = 3*(indflash(ibad)+imol-1) + ilugan = 3*(indflash(ibad)+imol-1)+3*ntotmol + ilubar2 = 3*(indflash(igood)+imol-1) + ilugan2 = 3*(indflash(igood)+imol-1)+3*ntotmol + if ( movebadrandom ) then + x(ilubar+1) = sizemin(1) + rnd()*(sizemax(1)-sizemin(1)) + x(ilubar+2) = sizemin(2) + rnd()*(sizemax(2)-sizemin(2)) + x(ilubar+3) = sizemin(3) + rnd()*(sizemax(3)-sizemin(3)) + else + x(ilubar+1) = x(ilubar2+1) - 0.3*dmax(itype)+0.6*rnd()*dmax(itype) + x(ilubar+2) = x(ilubar2+2) - 0.3*dmax(itype)+0.6*rnd()*dmax(itype) + x(ilubar+3) = x(ilubar2+3) - 0.3*dmax(itype)+0.6*rnd()*dmax(itype) + end if + x(ilugan+1) = x(ilugan2+1) + x(ilugan+2) = x(ilugan2+2) + x(ilugan+3) = x(ilugan2+3) + call restmol(itype,ilubar,n,x,fx,.true.) + do while( j <= 65.d0*i/nmove ) + write(*,"('*',$)") + j = j + 1 + end do + end do + write(*,"('|')") + end if + end if + end do + + call computef(n,x,fx) + if(movebadprint) write(*,*) ' Function value after moving molecules:', fx + do i = 1, ntotat + radius(i) = radiuswork(i) + end do + + return +end subroutine movebad + diff --git a/src/initial.f90 b/src/initial.f90 new file mode 100644 index 0000000..5fc29da --- /dev/null +++ b/src/initial.f90 @@ -0,0 +1,592 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine initial: Subroutine that reset parameters and +! builds the initial point +! + +subroutine initial(n,x) + + use exit_codes + use sizes + use compute_data + use input, only : randini, ntfix, fix, moldy, chkgrad, avoidoverlap,& + discale, precision, sidemax, restart_from, input_itype,& + nloop0_type + use usegencan + use ahestetic + implicit none + integer :: n, i, j, k, idatom, iatom, ilubar, ilugan, icart, itype, & + imol, ntry, nb, iboxx, iboxy, iboxz, ifatom, & + idfatom, iftype, jatom, ioerr + + double precision :: x(n), cmx, cmy, beta, gamma, theta, & + cmz, fx, xlength, dbox, rnd, & + radmax, v1(3), v2(3), v3(3), xbar, ybar, zbar + double precision, parameter :: twopi = 8.d0*datan(1.d0) + + logical :: overlap, movebadprint, hasbad + logical, allocatable :: hasfixed(:,:,:) + + character(len=strl) :: record + + ! Allocate hasfixed array + + allocate(hasfixed(0:nbp+1,0:nbp+1,0:nbp+1)) + + ! We need to initialize the move logical variable + + move = .false. + + ! Default status of the function evaluation + + init1 = .false. + lboxfirst = 0 + + ! Initialize the comptype logical array + + do i = 1, ntfix + comptype(i) = .true. + end do + + ! Penalty factors for the objective function relative to restrictions + ! Default values: scale = 1.d2, scale2 = 1.d1 + + scale = 1.d0 + scale2 = 1.d-2 + + ! Move molecules to their center of mass (not for moldy) + if(.not.moldy) call tobar() + + ! Compute maximum internal distance within each type of molecule + + do itype = 1, ntype + dmax(itype) = 0.d0 + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) - 1 + do jatom = iatom + 1, natoms(itype) + dmax(itype) = dmax1 ( dmax(itype),& + (coor(idatom+iatom,1)-coor(idatom+jatom,1))**2+& + (coor(idatom+iatom,2)-coor(idatom+jatom,2))**2+& + (coor(idatom+iatom,3)-coor(idatom+jatom,3))**2 ) + end do + end do + dmax(itype) = dsqrt(dmax(itype)) + write(*,*) ' Maximum internal distance of type ',itype,': ',& + dmax(itype) + if(dmax(itype).eq.0.) dmax(itype) = 1.d0 + end do + + ! Maximum size of the system: if you system is very large (about + ! 80 nm wide), increase the sidemax parameter. + ! Otherwise, the packing can be slow and unsucesful + + cmxmin(1) = -sidemax + cmymin(1) = -sidemax + cmzmin(1) = -sidemax + cmxmax(1) = sidemax + cmymax(1) = sidemax + cmzmax(1) = sidemax + do i = 1, 3 + x(i) = 0.d0 + x(i+ntotmol*3) = 0.d0 + end do + call restmol(1,0,n,x,fx,.true.) + sizemin(1) = x(1) - sidemax + sizemax(1) = x(1) + sidemax + sizemin(2) = x(2) - sidemax + sizemax(2) = x(2) + sidemax + sizemin(3) = x(3) - sidemax + sizemax(3) = x(3) + sidemax + write(*,*) ' All atoms must be within these coordinates: ' + write(*,*) ' x: [ ', sizemin(1),', ', sizemax(1), ' ] ' + write(*,*) ' y: [ ', sizemin(2),', ', sizemax(2), ' ] ' + write(*,*) ' z: [ ', sizemin(3),', ', sizemax(3), ' ] ' + write(*,*) ' If the system is larger than this, increase the sidemax parameter. ' + + ! Create first aleatory guess + + i = 0 + j = ntotmol*3 + do itype = 1, ntype + do imol = 1, nmols(itype) + x(i+1) = sizemin(1) + rnd()*(sizemax(1)-sizemin(1)) + x(i+2) = sizemin(2) + rnd()*(sizemax(2)-sizemin(2)) + x(i+3) = sizemin(3) + rnd()*(sizemax(3)-sizemin(3)) + if ( constrain_rot(itype,1) ) then + x(j+1) = ( rot_bound(itype,1,1) - dabs(rot_bound(itype,1,2)) ) + & + 2.d0*rnd()*dabs(rot_bound(itype,1,2)) + else + x(j+1) = twopi*rnd() + end if + if ( constrain_rot(itype,2) ) then + x(j+2) = ( rot_bound(itype,2,1) - dabs(rot_bound(itype,2,2)) ) + & + 2.d0*rnd()*dabs(rot_bound(itype,2,2)) + else + x(j+2) = twopi*rnd() + end if + if ( constrain_rot(itype,3) ) then + x(j+3) = ( rot_bound(itype,3,1) - dabs(rot_bound(itype,3,2)) ) + & + 2.d0*rnd()*dabs(rot_bound(itype,3,2)) + else + x(j+3) = twopi*rnd() + end if + i = i + 3 + j = j + 3 + end do + end do + + ! Initialize cartesian coordinate array for the first time + + ilubar = 0 + ilugan = ntotmol*3 + icart = 0 + do itype = 1, ntype + do imol = 1, nmols(itype) + xbar = x(ilubar+1) + ybar = x(ilubar+2) + zbar = x(ilubar+3) + beta = x(ilugan+1) + gamma = x(ilugan+2) + theta = x(ilugan+3) + call eulerrmat(beta,gamma,theta,v1,v2,v3) + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + icart = icart + 1 + idatom = idatom + 1 + call compcart(icart,xbar,ybar,zbar,& + coor(idatom,1),coor(idatom,2),coor(idatom,3),& + v1,v2,v3) + fixedatom(icart) = .false. + end do + end do + end do + if(fix) then + icart = ntotat - natfix + do iftype = ntype + 1, ntfix + idfatom = idfirst(iftype) - 1 + do ifatom = 1, natoms(iftype) + idfatom = idfatom + 1 + icart = icart + 1 + xcart(icart,1) = coor(idfatom,1) + xcart(icart,2) = coor(idfatom,2) + xcart(icart,3) = coor(idfatom,3) + fixedatom(icart) = .true. + end do + end do + end if + + ! Use the largest radius as the reference for binning the box + + radmax = 0.d0 + do i = 1, ntotat + radmax = dmax1(radmax,2.d0*radius(i)) + end do + + ! Performing some steps of optimization for the restrictions only + + write(*,hash3_line) + write(*,"(' Building initial approximation ... ' )") + write(*,hash3_line) + write(*,"(' Adjusting initial point to fit the constraints ')") + write(*,dash2_line) + init1 = .true. + call swaptype(n,x,itype,0) ! Initialize swap arrays + itype = 0 + do while( itype <= ntype ) + itype = itype + 1 + if ( itype <= ntype ) then + call swaptype(n,x,itype,1) ! Set arrays for this type + else + call swaptype(n,x,itype,3) ! Restore arrays if itype = ntype + 1 + exit + end if + write(*,dash3_line) + write(*,*) ' Molecules of type: ', input_itype(itype) + write(*,*) + i = 0 + hasbad = .true. + call computef(n,x,fx) + do while( frest > precision .and. i.le. nloop0_type(itype)-1 .and. hasbad) + i = i + 1 + write(*,prog1_line) + call pgencan(n,x,fx) + call computef(n,x,fx) + if(frest > precision) then + write(*,"( a,i6,a,i6 )")' Fixing bad orientations ... ', i,' of ', nloop0_type(itype) + movebadprint = .true. + call movebad(n,x,fx,movebadprint) + end if + end do + write(*,*) + write(*,*) ' Restraint-only function value: ', fx + write(*,*) ' Maximum violation of the restraints: ', frest + call swaptype(n,x,itype,2) ! Save current type results + + if( hasbad .and. frest > precision ) then + write(*,*) ' ERROR: Packmol was unable to put the molecules' + write(*,*) ' in the desired regions even without' + write(*,*) ' considering distance tolerances. ' + write(*,*) ' Probably there is something wrong with' + write(*,*) ' the constraints, since it seems that' + write(*,*) ' the molecules cannot satisfy them at' + write(*,*) ' at all. ' + write(*,*) ' Please check the spatial constraints and' + write(*,*) ' try again.' + if ( i .ge. nloop0_type(itype)-1 ) then + end if + write(*,*) ' >The maximum number of cycles (',nloop0_type(itype),') was achieved.' + write(*,*) ' You may try increasing it with the',' nloop0 keyword, as in: nloop0 1000 ' + stop exit_code_failed_to_converge + end if + end do + init1 = .false. + + ! Rescaling sizemin and sizemax in order to build the patch of boxes + + write(*,dash3_line) + write(*,*) ' Rescaling maximum and minimum coordinates... ' + do i = 1, 3 + sizemin(i) = 1.d20 + sizemax(i) = -1.d20 + end do + + icart = 0 + do itype = 1, ntfix + do imol = 1, nmols(itype) + do iatom = 1, natoms(itype) + icart = icart + 1 + sizemin(1) = dmin1(sizemin(1),xcart(icart,1)) + sizemin(2) = dmin1(sizemin(2),xcart(icart,2)) + sizemin(3) = dmin1(sizemin(3),xcart(icart,3)) + sizemax(1) = dmax1(sizemax(1),xcart(icart,1)) + sizemax(2) = dmax1(sizemax(2),xcart(icart,2)) + sizemax(3) = dmax1(sizemax(3),xcart(icart,3)) + end do + end do + end do + + ! Computing the size of the patches + + write(*,*) ' Computing size of patches... ' + dbox = discale * radmax + 0.01d0 * radmax + do i = 1, 3 + xlength = sizemax(i) - sizemin(i) + nb = int(xlength/dbox + 1.d0) + if(nb.gt.nbp) nb = nbp + boxl(i) = dmax1(xlength/dfloat(nb),dbox) + nboxes(i) = nb + nb2(i) = nboxes(i) + 2 + end do + + ! Reseting latomfix array + + do i = 0, nbp + 1 + do j = 0, nbp + 1 + do k = 0, nbp + 1 + latomfix(i,j,k) = 0 + latomfirst(i,j,k) = 0 + hasfixed(i,j,k) = .false. + hasfree(i,j,k) = .false. + end do + end do + end do + + ! If there are fixed molecules, add them permanently to the latomfix array + + write(*,*) ' Add fixed molecules to permanent arrays... ' + if(fix) then + icart = ntotat - natfix + do iftype = ntype + 1, ntfix + idfatom = idfirst(iftype) - 1 + do ifatom = 1, natoms(iftype) + idfatom = idfatom + 1 + icart = icart + 1 + call setibox(xcart(icart,1),xcart(icart,2),xcart(icart,3),& + sizemin,boxl,nboxes,iboxx,iboxy,iboxz) + latomnext(icart) = latomfix(iboxx,iboxy,iboxz) + latomfix(iboxx,iboxy,iboxz) = icart + latomfirst(iboxx,iboxy,iboxz) = icart + ibtype(icart) = iftype + ibmol(icart) = 1 + hasfixed(iboxx,iboxy,iboxz) = .true. + end do + end do + end if + + ! Reseting mass centers to be within the regions + + write(*,*) ' Reseting center of mass... ' + do itype = 1, ntype + cmxmin(itype) = 1.d20 + cmymin(itype) = 1.d20 + cmzmin(itype) = 1.d20 + cmxmax(itype) = -1.d20 + cmymax(itype) = -1.d20 + cmzmax(itype) = -1.d20 + end do + + icart = 0 + do itype = 1, ntype + do imol = 1, nmols(itype) + cmx = 0.d0 + cmy = 0.d0 + cmz = 0.d0 + do iatom = 1, natoms(itype) + icart = icart + 1 + cmx = cmx + xcart(icart,1) + cmy = cmy + xcart(icart,2) + cmz = cmz + xcart(icart,3) + end do + cmx = cmx / dfloat(natoms(itype)) + cmy = cmy / dfloat(natoms(itype)) + cmz = cmz / dfloat(natoms(itype)) + cmxmin(itype) = dmin1(cmxmin(itype),cmx) + cmymin(itype) = dmin1(cmymin(itype),cmy) + cmzmin(itype) = dmin1(cmzmin(itype),cmz) + cmxmax(itype) = dmax1(cmxmax(itype),cmx) + cmymax(itype) = dmax1(cmymax(itype),cmy) + cmzmax(itype) = dmax1(cmzmax(itype),cmz) + end do + end do + + ! If there is a restart file for all system, read it + + if ( restart_from(0) /= 'none' ) then + record = restart_from(0) + write(*,*) ' Restarting all system from file: ', trim(adjustl(record)) + open(10,file=restart_from(0),status='old',action='read',iostat=ioerr) + ilubar = 0 + ilugan = ntotmol*3 + do i = 1, ntotmol + read(10,*,iostat=ioerr) x(ilubar+1), x(ilubar+2), x(ilubar+3), & + x(ilugan+1), x(ilugan+2), x(ilugan+3) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read restart file: ', trim(adjustl(record)) + stop exit_code_open_file + end if + ilubar = ilubar + 3 + ilugan = ilugan + 3 + end do + close(10) + return + end if + + ! Building random initial point + + write(*,dash3_line) + write(*,*) ' Setting initial trial coordinates ... ' + write(*,dash2_line) + + if ( chkgrad ) then + write(*,*) ' For checking gradient, will set avoidoverlap to false. ' + avoidoverlap = .false. + end if + + ! Setting random center of mass coordinates, within size limits + + ilubar = 0 + do itype = 1, ntype + if ( restart_from(itype) /= 'none' ) then + ilubar = ilubar + nmols(itype)*3 + cycle + end if + do imol = 1, nmols(itype) + if ( .not. avoidoverlap ) then + fx = 1.d0 + ntry = 0 + do while((fx.gt.precision).and.ntry.le.20) + ntry = ntry + 1 + x(ilubar+1) = cmxmin(itype) + rnd()*(cmxmax(itype)-cmxmin(itype)) + x(ilubar+2) = cmymin(itype) + rnd()*(cmymax(itype)-cmymin(itype)) + x(ilubar+3) = cmzmin(itype) + rnd()*(cmzmax(itype)-cmzmin(itype)) + call restmol(itype,ilubar,n,x,fx,.false.) + end do + else + fx = 1.d0 + ntry = 0 + overlap = .false. + do while((overlap.or.fx.gt.precision).and.ntry.le.20) + ntry = ntry + 1 + x(ilubar+1) = cmxmin(itype) + rnd()*(cmxmax(itype)-cmxmin(itype)) + x(ilubar+2) = cmymin(itype) + rnd()*(cmymax(itype)-cmymin(itype)) + x(ilubar+3) = cmzmin(itype) + rnd()*(cmzmax(itype)-cmzmin(itype)) + if(fix) then + call setibox(x(ilubar+1),x(ilubar+2),x(ilubar+3),& + sizemin,boxl,nboxes,iboxx,iboxy,iboxz) + if(hasfixed(iboxx, iboxy, iboxz ).or.& + hasfixed(iboxx+1,iboxy, iboxz ).or.& + hasfixed(iboxx, iboxy+1,iboxz ).or.& + hasfixed(iboxx, iboxy, iboxz+1).or.& + hasfixed(iboxx-1,iboxy, iboxz ).or.& + hasfixed(iboxx, iboxy-1,iboxz ).or.& + hasfixed(iboxx, iboxy, iboxz-1).or.& + hasfixed(iboxx+1,iboxy+1,iboxz ).or.& + hasfixed(iboxx+1,iboxy, iboxz+1).or.& + hasfixed(iboxx+1,iboxy-1,iboxz ).or.& + hasfixed(iboxx+1,iboxy, iboxz-1).or.& + hasfixed(iboxx, iboxy+1,iboxz+1).or.& + hasfixed(iboxx, iboxy+1,iboxz-1).or.& + hasfixed(iboxx, iboxy-1,iboxz+1).or.& + hasfixed(iboxx, iboxy-1,iboxz-1).or.& + hasfixed(iboxx-1,iboxy+1,iboxz ).or.& + hasfixed(iboxx-1,iboxy, iboxz+1).or.& + hasfixed(iboxx-1,iboxy-1,iboxz ).or.& + hasfixed(iboxx-1,iboxy, iboxz-1).or.& + hasfixed(iboxx+1,iboxy+1,iboxz+1).or.& + hasfixed(iboxx+1,iboxy+1,iboxz-1).or.& + hasfixed(iboxx+1,iboxy-1,iboxz+1).or.& + hasfixed(iboxx+1,iboxy-1,iboxz-1).or.& + hasfixed(iboxx-1,iboxy+1,iboxz+1).or.& + hasfixed(iboxx-1,iboxy+1,iboxz-1).or.& + hasfixed(iboxx-1,iboxy-1,iboxz+1).or.& + hasfixed(iboxx-1,iboxy-1,iboxz-1)) then + overlap = .true. + else + overlap = .false. + end if + end if + if(.not.overlap) call restmol(itype,ilubar,n,x,fx,.false.) + end do + end if + ilubar = ilubar + 3 + end do + end do + + ! Setting random angles, except if the rotations were constrained + + ilugan = ntotmol*3 + do itype = 1, ntype + if ( restart_from(itype) /= 'none' ) then + ilugan = ilugan + nmols(itype)*3 + cycle + end if + do imol = 1, nmols(itype) + if ( constrain_rot(itype,1) ) then + x(ilugan+1) = ( rot_bound(itype,1,1) - dabs(rot_bound(itype,1,2)) ) + & + 2.d0*rnd()*dabs(rot_bound(itype,1,2)) + else + x(ilugan+1) = twopi*rnd() + end if + if ( constrain_rot(itype,2) ) then + x(ilugan+2) = ( rot_bound(itype,2,1) - dabs(rot_bound(itype,2,2)) ) + & + 2.d0*rnd()*dabs(rot_bound(itype,2,2)) + else + x(ilugan+2) = twopi*rnd() + end if + if ( constrain_rot(itype,3) ) then + x(ilugan+3) = ( rot_bound(itype,3,1) - dabs(rot_bound(itype,3,2)) ) + & + 2.d0*rnd()*dabs(rot_bound(itype,3,2)) + else + x(ilugan+3) = twopi*rnd() + end if + ilugan = ilugan + 3 + end do + end do + + ! Compare analytical and finite-difference gradients + + if(chkgrad) then + dbox = discale * radmax + 0.01d0 * radmax + do i = 1, 3 + xlength = sizemax(i) - sizemin(i) + nb = int(xlength/dbox + 1.d0) + if(nb.gt.nbp) nb = nbp + boxl(i) = dmax1(xlength/dfloat(nb),dbox) + nboxes(i) = nb + nb2(i) = nboxes(i) + 2 + end do + call comparegrad(n,x) + stop + end if + + ! + ! Reading restart files of specific molecule types, if available + ! + + ilubar = 0 + ilugan = ntotmol*3 + do itype = 1, ntype + if ( restart_from(itype) /= 'none' ) then + record = restart_from(itype) + write(*,dash3_line) + write(*,*) ' Molecules of type: ', input_itype(itype) + write(*,*) ' Will restart coordinates from: ', trim(adjustl(record)) + open(10,file=record,status='old',action='read',iostat=ioerr) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not open restart file: ', trim(adjustl(record)) + stop exit_code_open_file + end if + do i = 1, nmols(itype) + read(10,*,iostat=ioerr) x(ilubar+1), x(ilubar+2), x(ilubar+3), & + x(ilugan+1), x(ilugan+2), x(ilugan+3) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not read restart file: ', trim(adjustl(record)) + stop exit_code_open_file + end if + ilubar = ilubar + 3 + ilugan = ilugan + 3 + end do + close(10) + call swaptype(n,x,itype,0) ! Initialize swap arrays + call swaptype(n,x,itype,1) ! Set arrays for this type + call computef(n,x,fx) + write(*,*) ' Maximum violation of the restraints: ', frest + write(*,*) ' Maximum violation of minimum atom distances: ', fdist + call swaptype(n,x,itype,3) ! Restore all-molecule arrays + else + ilubar = ilubar + nmols(itype)*3 + ilugan = ilugan + nmols(itype)*3 + end if + end do + + ! Return with current random point (not default) + + if(randini) return + + ! Adjusting current point to fit the constraints + + init1 = .true. + call swaptype(n,x,itype,0) ! Initialize swap arrays + itype = 0 + do while( itype <= ntype ) + itype = itype + 1 + if ( itype == ntype + 1 ) then + call swaptype(n,x,itype,3) ! Restore arrays for all molecules + exit + end if + if ( restart_from(itype) /= 'none' ) cycle + call swaptype(n,x,itype,1) ! Set arrays for this type + write(*,dash3_line) + write(*,*) ' Molecules of type: ', input_itype(itype) + write(*,*) ' Adjusting random positions to fit the constraints. ' + i = 0 + call computef(n,x,fx) + hasbad = .true. + do while( frest > precision .and. i <= nloop0_type(itype)-1 .and. hasbad) + i = i + 1 + write(*,prog1_line) + call pgencan(n,x,fx) + call computef(n,x,fx) + if(frest > precision) then + write(*,"( a,i6,a,i6 )")' Fixing bad orientations ... ', i,' of ', nloop0_type(itype) + movebadprint = .true. + call movebad(n,x,fx,movebadprint) + end if + end do + write(*,*) ' Restraint-only function value: ', fx + write(*,*) ' Maximum violation of the restraints: ', frest + call swaptype(n,x,itype,2) ! Save results for this type + end do + init1 = .false. + write(*,hash3_line) + + ! Deallocate hasfixed array + + deallocate(hasfixed) + + return +end subroutine initial + diff --git a/src/input.f90 b/src/input.f90 new file mode 100644 index 0000000..0008d6a --- /dev/null +++ b/src/input.f90 @@ -0,0 +1,80 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Module that carries the input parameters read from the input file +! + +module input + + use sizes + implicit none + + integer :: nlines + integer :: nrest + integer :: seed + integer :: nloop, nloop_all + integer :: writeout + integer :: ntfix + integer :: ntcon(9) + + integer, allocatable :: nconnect(:,:) ! (ntotat,9) + integer, allocatable :: irestline(:) ! (maxrest) + integer, allocatable :: linestrut(:,:) ! (ntype,2) + integer, allocatable :: resnumbers(:) ! (ntype) + integer, allocatable :: maxcon(:) ! (ntotat) + integer, allocatable :: input_itype(:) ! (ntype) + integer, allocatable :: nloop_type(:) ! (ntype) + integer, allocatable :: nloop0_type(:) ! (ntype) + integer, allocatable :: maxmove(:) ! (ntype) + + double precision :: dism + double precision :: precison + double precision :: sidemax + double precision :: discale + double precision :: movefrac + double precision :: add_sides_fix + double precision :: precision + double precision :: fbins + double precision :: short_tol_dist + double precision :: short_tol_scale + + double precision, allocatable :: amass(:) ! (ntotat) + double precision, allocatable :: charge(:) ! (ntotat) + + logical :: writebad + logical :: tinker + logical :: pdb + logical :: crd + logical :: xyz + logical :: moldy + logical :: check + logical :: chkgrad + logical :: randini + logical :: movebadrandom + logical :: add_amber_ter, amber_ter_preserve + logical :: add_box_sides + logical :: fix + logical :: avoidoverlap + logical :: packall + logical :: use_short_tol + + logical, allocatable :: changechains(:) ! (ntype) + logical, allocatable :: fixedoninput(:) ! (ntype) + logical, allocatable :: connect(:) ! (ntype) + + character(len=1), parameter :: forbidden_char = '~' + character(len=strl) :: xyzout + character(len=strl) :: crdfile + + character(len=1), allocatable :: chain(:) ! (ntype) + character(len=3), allocatable :: ele(:) ! (ntotat) + character(len=8), allocatable :: segid(:) ! (segment identifier) + character(len=strl), allocatable :: pdbfile(:) ! (ntype) + character(len=strl), allocatable :: name(:) ! (ntype) + character(len=strl), allocatable :: keyword(:,:) ! (nlines,maxkeywords) + character(len=strl), allocatable :: inputfile(:) ! (nlines) + character(len=strl), allocatable :: restart_from(:), restart_to(:) ! (0:ntype) + +end module input diff --git a/src/jacobi.f90 b/src/jacobi.f90 new file mode 100644 index 0000000..04ef83f --- /dev/null +++ b/src/jacobi.f90 @@ -0,0 +1,106 @@ +! +! JACOBI +! Jacobi diagonalizer with sorted output. Same calling sequence as +! EISPACK routine, but must specify nrot! +! + SUBROUTINE jacobi (a, n, np, d, v, nrot) + IMPLICIT CHARACTER (A-Z) +! + INTEGER n, np, nrot + DOUBLEPRECISION a (np, n) + DOUBLEPRECISION d (n) + DOUBLEPRECISION v (np, n) +! + DOUBLEPRECISION onorm, dnorm + DOUBLEPRECISION b, dma, q, t, c, s + DOUBLEPRECISION atemp, vtemp, dtemp + INTEGER i, j, k, l +! + DO 10000 j = 1, n + DO 10010 i = 1, n + v (i, j) = 0.0D0 +10010 CONTINUE + v (j, j) = 1.0D0 + d (j) = a (j, j) +10000 CONTINUE +! + DO 20000 l = 1, nrot + dnorm = 0.0D0 + onorm = 0.0D0 + DO 20100 j = 1, n + dnorm = dnorm + ABS (d (j)) + DO 20110 i = 1, j - 1 + onorm = onorm + ABS (a (i, j)) +20110 CONTINUE +20100 CONTINUE + IF (onorm / dnorm .LE. 0.0D0) GOTO 19999 + DO 21000 j = 2, n + DO 21010 i = 1, j - 1 + b = a (i, j) + IF (ABS (b) .GT. 0.0D0) THEN + dma = d (j) - d (i) + IF (ABS (dma) + ABS (b) .LE. ABS (dma)) THEN + t = b / dma + ELSE + q = 0.5D0 * dma / b + t = SIGN (1.0D0 / (ABS (q) + SQRT (1.0D0 + q * q)), q) + ENDIF + c = 1.0D0 / SQRT (t * t + 1.0D0) + s = t * c + a (i, j) = 0.0D0 + DO 21110 k = 1, i - 1 + atemp = c * a (k, i) - s * a (k, j) + a (k, j) = s * a (k, i) + c * a (k, j) + a (k, i) = atemp +21110 CONTINUE + DO 21120 k = i + 1, j - 1 + atemp = c * a (i, k) - s * a (k, j) + a (k, j) = s * a (i, k) + c * a (k, j) + a (i, k) = atemp +21120 CONTINUE + DO 21130 k = j + 1, n + atemp = c * a (i, k) - s * a (j, k) + a (j, k) = s * a (i, k) + c * a (j, k) + a (i, k) = atemp +21130 CONTINUE + DO 21140 k = 1, n + vtemp = c * v (k, i) - s * v (k, j) + v (k, j) = s * v (k, i) + c * v (k, j) + v (k, i) = vtemp +21140 CONTINUE + dtemp = c * c * d (i) + s * s * d (j) -& + 2.0D0 * c * s * b + d (j) = s * s * d (i) + c * c * d (j) +& + 2.0D0 * c * s * b + d (i) = dtemp + ENDIF +21010 CONTINUE +21000 CONTINUE +20000 CONTINUE +19999 CONTINUE + nrot = l +! + DO 30000 j = 1, n - 1 + k = j + dtemp = d (k) + DO 30100 i = j + 1, n + IF (d (i) .LT. dtemp) THEN + k = i + dtemp = d (k) + ENDIF +30100 CONTINUE + IF (k .GT. j) THEN + d (k) = d (j) + d (j) = dtemp + DO 30200 i = 1, n + dtemp = v (i, k) + v (i, k) = v (i, j) + v (i, j) = dtemp +30200 CONTINUE + ENDIF +30000 CONTINUE +! +RETURN +END subroutine jacobi + + diff --git a/src/output.f90 b/src/output.f90 new file mode 100644 index 0000000..20c0c42 --- /dev/null +++ b/src/output.f90 @@ -0,0 +1,807 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine output: Subroutine that writes the output file +! + +subroutine output(n,x) + + use exit_codes + use sizes + use compute_data + use input + + implicit none + integer :: n, k, i, ilugan, ilubar, itype, imol, idatom,& + irest, iimol, ichain, iatom, irec, ilres, ifres,& + iires, ciires, irescount,& + icart, i_ref_atom, ioerr, ifirst_mol + integer :: nr, nres, imark + integer :: i_fixed, i_not_fixed + + double precision :: x(n) + double precision :: tens(4,4), v(4,4), dv(4) + double precision :: v1(3), v2(3), v3(3) + double precision :: xbar, ybar, zbar, beta, gama, teta, xcm, ycm, zcm + double precision :: xlength, ylength, zlength + double precision :: xxyx, xxyy, xxyz, xyyz, xyyy, xzyx,& + xzyy, xzyz, xyyx, xq, yq, zq, q0, q1, q2, q3 + double precision :: xtemp, ytemp, ztemp + double precision :: sxmin, symin, szmin, sxmax, symax, szmax + + character :: write_chain, even_chain, odd_chain + character(len=64) :: title + character(len=strl) :: pdb_atom_line, tinker_atom_line, crd_format + character(len=8) :: crdires,crdresn,crdsegi,atmname + character(len=strl) :: record + character(len=5) :: i5hex, tmp_i5hex + + ! Job title + + title = ' Built with Packmol ' + + ! + ! Write restart files, if required + ! + + ! Restart file for all system + + if ( restart_to(0) /= 'none' ) then + record = restart_to(0) + open(10,file=restart_to(0),iostat=ioerr) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not open restart_to file: ', trim(adjustl(record)) + stop exit_code_open_file + end if + ilubar = 0 + ilugan = ntotmol*3 + do i = 1, ntotmol + write(10,"(6(tr1,es23.16))") x(ilubar+1), x(ilubar+2), x(ilubar+3), & + x(ilugan+1), x(ilugan+2), x(ilugan+3) + ilubar = ilubar + 3 + ilugan = ilugan + 3 + end do + close(10) + write(*,*) ' Wrote restart file for all system: ', trim(adjustl(record)) + end if + + ! Restart files for specific molecule types + + ilubar = 0 + ilugan = ntotmol*3 + do itype = 1, ntype + if ( restart_to(itype) /= 'none' ) then + record = restart_to(itype) + open(10,file=record,iostat=ioerr) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Could not open restart_to file: ', trim(adjustl(record)) + stop exit_code_open_file + end if + do i = 1, nmols(itype) + write(10,"(6(tr1,es23.16))") x(ilubar+1), x(ilubar+2), x(ilubar+3), & + x(ilugan+1), x(ilugan+2), x(ilugan+3) + ilubar = ilubar + 3 + ilugan = ilugan + 3 + end do + close(10) + write(*,*) ' Wrote restart file: ', trim(adjustl(record)) + else + ilubar = ilubar + nmols(itype)*3 + ilugan = ilugan + nmols(itype)*3 + end if + end do + + ! Write the output (xyz file) + + if(xyz) then + open(30,file=xyzout,status='unknown') + write(30,*) ntotat + write(30,*) title + ilubar = 0 + ilugan = ntotmol*3 + icart = 0 + i_not_fixed = 0 + i_fixed = ntype + do itype = 1, ntfix + if ( .not. fixedoninput(itype) ) then + i_not_fixed = i_not_fixed + 1 + do imol = 1, nmols(i_not_fixed) + xbar = x(ilubar+1) + ybar = x(ilubar+2) + zbar = x(ilubar+3) + beta = x(ilugan+1) + gama = x(ilugan+2) + teta = x(ilugan+3) + call eulerrmat(beta,gama,teta,v1,v2,v3) + idatom = idfirst(i_not_fixed) - 1 + do iatom = 1, natoms(i_not_fixed) + icart = icart + 1 + idatom = idatom + 1 + call compcart(icart,xbar,ybar,zbar,& + coor(idatom,1),coor(idatom,2),& + coor(idatom,3),& + v1,v2,v3) + write(30,"( tr2,a3,tr2,3(tr2,f14.6) )") ele(idatom), (xcart(icart, k), k = 1, 3) + end do + ilugan = ilugan + 3 + ilubar = ilubar + 3 + end do + else + i_fixed = i_fixed + 1 + idatom = idfirst(i_fixed) - 1 + do iatom = 1, natoms(i_fixed) + idatom = idatom + 1 + write(30,"( tr2,a3,tr2,3(tr2,f14.6) )") ele(idatom), (coor(idatom,k),k=1,3) + end do + end if + end do + close(30) + end if + + ! write the output as a MOLDY file + + if(moldy) then + open(30,file=xyzout,status='unknown') + ! For square moldy boxes, this must be the side dimensions of the box + sxmin = 1.d30 + symin = 1.d30 + szmin = 1.d30 + sxmax = -1.d30 + symax = -1.d30 + szmax = -1.d30 + do irest = 1, nrest + if(ityperest(irest).eq.2) then + sxmin = dmin1(restpars(irest,1),sxmin) + symin = dmin1(restpars(irest,2),symin) + szmin = dmin1(restpars(irest,3),szmin) + sxmax = dmax1(restpars(irest,4)+restpars(irest,1),sxmax) + symax = dmax1(restpars(irest,4)+restpars(irest,2),symax) + szmax = dmax1(restpars(irest,4)+restpars(irest,3),szmax) + else if(ityperest(irest).eq.3) then + sxmin = dmin1(restpars(irest,1),sxmin) + symin = dmin1(restpars(irest,2),symin) + szmin = dmin1(restpars(irest,3),szmin) + sxmax = dmax1(restpars(irest,4),sxmax) + symax = dmax1(restpars(irest,5),symax) + szmax = dmax1(restpars(irest,6),szmax) + else + write(*,*) ' WARNING: The first line of the moldy output' + write(*,*) ' file contains the size of the sides of the' + write(*,*) ' paralelogram that defines the system. ' + write(*,*) ' The numbers printed may not be correct in ' + write(*,*) ' this case because regions other than cubes ' + write(*,*) ' or boxes were used. ' + sxmin = dmin1(sxmin,sizemin(1)) + symin = dmin1(symin,sizemin(2)) + szmin = dmin1(szmin,sizemin(3)) + sxmax = dmax1(sxmax,sizemax(1)) + symax = dmax1(symax,sizemax(2)) + szmax = dmax1(szmax,sizemax(3)) + end if + end do + xlength = sxmax - sxmin + ylength = symax - symin + zlength = szmax - szmin + write(30,"( 3(tr1,f12.6),' 90 90 90 1 1 1 ' )") xlength, ylength, zlength + ilubar = 0 + ilugan = ntotmol*3 + i_not_fixed = 0 + i_fixed = ntype + do itype = 1, ntfix + if ( .not. fixedoninput(itype) ) then + i_not_fixed = i_not_fixed + 1 + record = name(i_not_fixed) + do imol = 1, nmols(i_not_fixed) + xbar = (x(ilubar+1) - sxmin) / xlength + ybar = (x(ilubar+2) - symin) / ylength + zbar = (x(ilubar+3) - szmin) / zlength + beta = x(ilugan+1) + gama = x(ilugan+2) + teta = x(ilugan+3) + call eulerrmat(beta,gama,teta,v1,v2,v3) + + ! Computing cartesian coordinates and quaternions + + xxyx = 0.d0 + xxyy = 0.d0 + xxyz = 0.d0 + xyyx = 0.d0 + xyyy = 0.d0 + xyyz = 0.d0 + xzyx = 0.d0 + xzyy = 0.d0 + xzyz = 0.d0 + idatom = idfirst(i_not_fixed) - 1 + do iatom = 1, natoms(i_not_fixed) + idatom = idatom + 1 + xq = coor(idatom, 1)*v1(1) & + + coor(idatom, 2)*v2(1) & + + coor(idatom, 3)*v3(1) + yq = coor(idatom, 1)*v1(2) & + + coor(idatom, 2)*v2(2) & + + coor(idatom, 3)*v3(2) + zq = coor(idatom, 1)*v1(3) & + + coor(idatom, 2)*v2(3) & + + coor(idatom, 3)*v3(3) + + ! Recovering quaternions for molecule imol + + xxyx = xxyx + xq * coor(idatom,1) * amass(idatom) + xxyy = xxyy + xq * coor(idatom,2) * amass(idatom) + xxyz = xxyz + xq * coor(idatom,3) * amass(idatom) + xyyx = xyyx + yq * coor(idatom,1) * amass(idatom) + xyyy = xyyy + yq * coor(idatom,2) * amass(idatom) + xyyz = xyyz + yq * coor(idatom,3) * amass(idatom) + xzyx = xzyx + zq * coor(idatom,1) * amass(idatom) + xzyy = xzyy + zq * coor(idatom,2) * amass(idatom) + xzyz = xzyz + zq * coor(idatom,3) * amass(idatom) + end do + + tens(1,1) = xxyx + xyyy + xzyz + tens(1,2) = xzyy - xyyz + tens(2,2) = xxyx - xyyy - xzyz + tens(1,3) = xxyz - xzyx + tens(2,3) = xxyy + xyyx + tens(3,3) = xyyy - xzyz - xxyx + tens(1,4) = xyyx - xxyy + tens(2,4) = xzyx + xxyz + tens(3,4) = xyyz + xzyy + tens(4,4) = xzyz - xxyx - xyyy + nr = 16 + call jacobi (tens, 4, 4, dv, v, nr) + q0 = v(1,4) + q1 = v(2,4) + q2 = v(3,4) + q3 = v(4,4) + record = name(i_not_fixed) + xbar = dmin1(0.999999d0,xbar) + ybar = dmin1(0.999999d0,ybar) + zbar = dmin1(0.999999d0,zbar) + write(30,"( a10,tr1,7(f12.6) )") trim(adjustl(record)), xbar, ybar, zbar, & + q0, q1, q2, q3 + ilugan = ilugan + 3 + ilubar = ilubar + 3 + end do + else + i_fixed = i_fixed + 1 + idatom = idfirst(i_fixed) - 1 + + ! Getting the specified position of the molecule + + do irest = 1, nrest + if(irestline(irest).gt.linestrut(i_fixed,1).and.& + irestline(irest).lt.linestrut(i_fixed,2)) then + xcm = restpars(irest,1) - sxmin + ycm = restpars(irest,2) - symin + zcm = restpars(irest,3) - szmin + beta = -restpars(irest,4) + gama = -restpars(irest,5) + teta = -restpars(irest,6) + end if + end do + call eulerrmat(beta,gama,teta,v1,v2,v3) + + ! Computing cartesian coordinates and quaternions + + xxyx = 0.d0 + xxyy = 0.d0 + xxyz = 0.d0 + xyyx = 0.d0 + xyyy = 0.d0 + xyyz = 0.d0 + xzyx = 0.d0 + xzyy = 0.d0 + xzyz = 0.d0 + idatom = idfirst(i_fixed) - 1 + do iatom = 1, natoms(i_fixed) + idatom = idatom + 1 + xtemp = coor(idatom,1) - xcm + ytemp = coor(idatom,2) - ycm + ztemp = coor(idatom,3) - zcm + xq = xtemp*v1(1) + ytemp*v2(1) + ztemp*v3(1) + yq = xtemp*v1(2) + ytemp*v2(2) + ztemp*v3(2) + zq = xtemp*v1(3) + ytemp*v2(3) + ztemp*v3(3) + xxyx = xxyx + xtemp * xq * amass(idatom) + xxyy = xxyy + xtemp * yq * amass(idatom) + xxyz = xxyz + xtemp * zq * amass(idatom) + xyyx = xyyx + ytemp * xq * amass(idatom) + xyyy = xyyy + ytemp * yq * amass(idatom) + xyyz = xyyz + ytemp * zq * amass(idatom) + xzyx = xzyx + ztemp * xq * amass(idatom) + xzyy = xzyy + ztemp * yq * amass(idatom) + xzyz = xzyz + ztemp * zq * amass(idatom) + end do + tens(1,1) = xxyx + xyyy + xzyz + tens(1,2) = xzyy - xyyz + tens(2,2) = xxyx - xyyy - xzyz + tens(1,3) = xxyz - xzyx + tens(2,3) = xxyy + xyyx + tens(3,3) = xyyy - xzyz - xxyx + tens(1,4) = xyyx - xxyy + tens(2,4) = xzyx + xxyz + tens(3,4) = xyyz + xzyy + tens(4,4) = xzyz - xxyx - xyyy + nr = 16 + call jacobi (tens, 4, 4, dv, v, nr) + q0 = v(1,4) + q1 = v(2,4) + q2 = v(3,4) + q3 = v(4,4) + xcm = xcm / xlength + ycm = ycm / ylength + zcm = zcm / zlength + record = name(itype) + xcm = dmin1(0.999999d0,xcm) + ycm = dmin1(0.999999d0,ycm) + zcm = dmin1(0.999999d0,zcm) + write(30,"( a10,tr1,7(f12.6) )") trim(adjustl(record)),& + xcm, ycm, zcm, q0, q1, q2, q3 + end if + end do + close(30) + end if + + ! write the output as pdb file + + if(pdb) then + pdb_atom_line = "( t1,a6,t7,a5,t12,a10,t22,a1,t23,& + &i4,t27,a1,t31,f8.3,t39,f8.3,t47,& + &f8.3,t55,a26 )" + crd_format='(2I10,2X,A8,2X,A8,3F20.10,2X,A8,2X,A8,F20.10)' + + open(30,file=xyzout,status='unknown') + if ( crd ) then + open(40,file=crdfile,status='unknown') + write(40,'("* TITLE ", a64,/& + &"* Packmol generated CHARMM CRD File",/& + &"* Home-Page:",/& + &"* http://m3g.iqm.unicamp.br/packmol",/& + &"* ")') title + write(40,'(i10,2x,a)') ntotat,'EXT' + end if + + write(30,"( & + &'HEADER ',/& + &'TITLE ', a64,/& + &'REMARK Packmol generated pdb file ',/& + &'REMARK Home-Page: ',& + &'http://m3g.iqm.unicamp.br/packmol',/,& + &'REMARK' )" ) title + + if(add_box_sides) then + write(30,"( 'CRYST1',t7,f9.2,t16,f9.2,t25,f9.2,& + &t34,f7.2,t41,f7.2,t48,f7.2,& + &t56,'P 1 1' )") & + sizemax(1)-sizemin(1) + add_sides_fix,& + sizemax(2)-sizemin(2) + add_sides_fix,& + sizemax(3)-sizemin(3) + add_sides_fix,& + 90., 90., 90. + end if + + ilubar = 0 + ilugan = ntotmol*3 + icart = 0 + i_ref_atom = 0 + iimol = 0 + ichain = 0 + i_not_fixed = 0 + i_fixed = ntype + irescount = 1 + do itype = 1, ntfix + if ( .not. fixedoninput(itype) ) then + i_not_fixed = i_not_fixed + 1 + + ! Counting the number of residues of this molecule + + open(15,file=pdbfile(i_not_fixed),status='old') + ifres = 0 + do + read(15,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + if ( record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM' ) then + read(record(23:26),*,iostat=ioerr) imark + if ( ioerr /= 0 ) then + record = pdbfile(i_not_fixed) + write(*,*) ' ERROR: Failed reading residue number ',& + ' from PDB file: ', trim(adjustl(record)) + write(*,*) ' Residue numbers are integers that must',& + ' be between columns 23 and 26. ' + write(*,*) ' Other characters within these columns',& + ' will cause input/output errors. ' + write(*,*) ' Standard PDB format specifications can',& + ' be found at: ' + write(*,*) ' www.rcsb.org/pdb ' + stop exit_code_input_error + end if + if ( ifres .eq. 0 ) ifres = imark + ilres = imark + end if + end do + nres = ilres - ifres + 1 + + do irec = 1, strl + record(irec:irec) = ' ' + end do + + mol: do imol = 1, nmols(i_not_fixed) + iimol = iimol + 1 + + if( chain(i_not_fixed) == "#" ) then + if(imol.eq.1.or.mod(imol,9999).eq.1) then + ichain = ichain + 1 + if( changechains(i_not_fixed) ) then + call chainc(ichain,odd_chain) + ichain = ichain + 1 + call chainc(ichain,even_chain) + else + call chainc(ichain,even_chain) + odd_chain = even_chain + end if + end if + if ( mod(imol,2) == 0 ) write_chain = even_chain + if ( mod(imol,2) /= 0 ) write_chain = odd_chain + else + write_chain = chain(i_not_fixed) + end if + + xbar = x(ilubar+1) + ybar = x(ilubar+2) + zbar = x(ilubar+3) + beta = x(ilugan+1) + gama = x(ilugan+2) + teta = x(ilugan+3) + + call eulerrmat(beta,gama,teta,v1,v2,v3) + + rewind(15) + idatom = idfirst(i_not_fixed) - 1 + iatom = 0 + do while(iatom.lt.natoms(i_not_fixed)) + + read(15,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit mol + if(record(1:4).ne.'ATOM'.and.record(1:6).ne.'HETATM') then + cycle + end if + + iatom = iatom + 1 + icart = icart + 1 + idatom = idatom + 1 + i_ref_atom = i_ref_atom + 1 + call compcart(icart,xbar,ybar,zbar,& + coor(idatom,1),coor(idatom,2),& + coor(idatom,3),v1,v2,v3) + + ! Setting residue numbers for this molecule + + imark = 0 + read(record(23:26),*,iostat=ioerr) imark + if ( ioerr /= 0 ) imark = 1 + if(resnumbers(i_not_fixed).eq.0) then + iires = mod(imol,9999) + ciires = mod(imol,99999999) + else if(resnumbers(i_not_fixed).eq.1) then + iires = imark + ciires = imark + else if(resnumbers(i_not_fixed).eq.2) then + iires = mod(imark-ifres+irescount,9999) + ciires = mod(imark-ifres+irescount,99999999) + else if(resnumbers(i_not_fixed).eq.3) then + iires = mod(iimol,9999) + ciires = mod(iimol,99999999) + end if + if(iires.eq.0) iires = 9999 + if(ciires.eq.0) ciires = 99999999 + + ! Writing output line + + if(record(1:4).eq.'ATOM') then + tmp_i5hex = i5hex(i_ref_atom) + write(30,pdb_atom_line) "ATOM ", tmp_i5hex,& + record(12:21), write_chain, iires,& + record(27:27),& + (xcart(icart,k), k = 1, 3),& + record(55:80) + end if + if(record(1:6).eq.'HETATM') then + tmp_i5hex = i5hex(i_ref_atom) + write(30,pdb_atom_line) "HETATM", tmp_i5hex,& + record(12:21), write_chain, iires,& + record(27:27),& + (xcart(icart,k), k = 1, 3),& + record(55:80) + end if + + if ( crd ) then + write(crdires,'(I8)') ciires + crdires = adjustl(crdires) + crdresn = trim(adjustl(record(18:21))) + crdsegi = crdresn + if (len(trim(adjustl(segid(i_not_fixed))))/=0) crdsegi = trim(adjustl(segid(i_not_fixed))) + atmname = adjustl(record(13:16)) + write(40,crd_format) i_ref_atom, ciires,crdresn, atmname, & + (xcart(icart,k), k = 1, 3), crdsegi,& + crdires, 0. + end if + + end do + irescount = irescount + nres + ilugan = ilugan + 3 + ilubar = ilubar + 3 + + if(add_amber_ter) write(30,"('TER')") + end do mol + close(15) + + ! If fixed molecule on input: + else + i_fixed = i_fixed + 1 + + ! Counting the number of residues of this molecule + + open(15,file=pdbfile(i_fixed),status='old') + ifres = 0 + do + read(15,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + if ( record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM' ) then + read(record(23:26),*,iostat=ioerr) imark + if ( ioerr /= 0 ) then + record = pdbfile(i_not_fixed) + write(*,*) ' ERROR: Failed reading residue number ',& + ' from PDB file: ', trim(adjustl(record)) + write(*,*) ' Residue numbers are integers that must',& + ' be between columns 23 and 26. ' + write(*,*) ' Other characters within these columns',& + ' will cause input/output errors. ' + write(*,*) ' Standard PDB format specifications can',& + ' be found at: ' + write(*,*) ' www.rcsb.org/pdb ' + stop exit_code_input_error + end if + if ( ifres .eq. 0 ) ifres = imark + ilres = imark + end if + end do + nres = ilres - ifres + 1 + + iimol = iimol + 1 + idatom = idfirst(i_fixed) - 1 + + rewind(15) + iatom = 0 + do while(iatom.lt.natoms(i_fixed)) + + read(15,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + if(record(1:4).ne.'ATOM'.and.record(1:6).ne.'HETATM') then + if(amber_ter_preserve .and. record(1:3).eq.'TER') then + write(30,"('TER')") + end if + !write(30,"( a80 )") record(1:80) + cycle + end if + + iatom = iatom + 1 + idatom = idatom + 1 + i_ref_atom = i_ref_atom + 1 + + read(record(23:26),*) imark + if(resnumbers(i_fixed).eq.0) then + iires = 1 + ciires = 1 + else if(resnumbers(i_fixed).eq.1) then + iires = imark + ciires = imark + else if(resnumbers(i_fixed).eq.2) then + iires = mod(imark-ifres+irescount,9999) + ciires = mod(imark-ifres+irescount,99999999) + else if(resnumbers(i_fixed).eq.3) then + iires = mod(iimol,9999) + ciires = mod(iimol,99999999) + end if + + if ( chain(i_fixed) == "#" ) then + write_chain = record(22:22) + else + write_chain = chain(i_fixed) + end if + + if(record(1:4).eq.'ATOM') then + tmp_i5hex = i5hex(i_ref_atom) + write(30,pdb_atom_line) "ATOM ", tmp_i5hex,& + record(12:21), write_chain, iires,& + record(27:27),& + (coor(idatom,k), k = 1, 3),& + record(55:80) + end if + if(record(1:6).eq.'HETATM') then + tmp_i5hex = i5hex(i_ref_atom) + write(30,pdb_atom_line) "HETATM", tmp_i5hex,& + record(12:21), write_chain, iires,& + record(27:27),& + (coor(idatom,k), k = 1, 3),& + record(55:80) + end if + + if ( crd ) then + write(crdires,'(I8)') ciires + crdires = adjustl(crdires) + crdresn = trim(adjustl(record(18:21))) + crdsegi = crdresn + if (len(trim(adjustl(segid(i_fixed))))/=0) crdsegi = trim(adjustl(segid(i_fixed))) + atmname = adjustl(record(13:16)) + write(40,crd_format) i_ref_atom, iires,crdresn, atmname, & + (xcart(icart,k), k = 1, 3), crdsegi,& + crdires, 0. + end if + + end do + irescount = irescount + nres + close(15) + if(add_amber_ter) write(30,"('TER')") + end if + end do + ! + ! Write connectivity if available + ! + i_ref_atom = 0 + i_not_fixed = 0 + i_fixed = ntype + do itype = 1, ntfix + if ( .not. fixedoninput(itype) ) then + i_not_fixed = i_not_fixed + 1 + idatom = idfirst(i_not_fixed) - 1 + do imol = 1, nmols(i_not_fixed) + iatom = 0 + ifirst_mol = i_ref_atom + 1 + do while(iatom.lt.natoms(i_not_fixed)) + iatom = iatom + 1 + i_ref_atom = i_ref_atom + 1 + if(connect(itype)) then + call write_connect(30,idatom,iatom,ifirst_mol) + end if + end do + end do + close(15) + ! If fixed molecule on input: + else + i_fixed = i_fixed + 1 + idatom = idfirst(i_fixed) - 1 + iatom = 0 + ifirst_mol = i_ref_atom + 1 + idatom = idfirst(i_fixed) - 1 + do while(iatom.lt.natoms(i_fixed)) + iatom = iatom + 1 + i_ref_atom = i_ref_atom + 1 + if(connect(itype)) then + call write_connect(30,idatom,iatom,ifirst_mol) + end if + end do + end if + end do + write(30,"('END')") + close(30) + if ( crd ) close(40) + end if + + ! Write the output (tinker xyz file) + + if(tinker) then + + tinker_atom_line = "( i7,tr2,a3,3(tr2,f10.6),9(tr2,i7) )" + + open(30, file = xyzout,status='unknown') + + write(30,"( i6,tr2,a64 )") ntotat, title + + ilubar = 0 + ilugan = ntotmol*3 + icart = 0 + i_ref_atom = 0 + i_not_fixed = 0 + i_fixed = ntype + + do itype = 1, ntfix + + if ( .not. fixedoninput(itype) ) then + i_not_fixed = i_not_fixed + 1 + + do imol = 1, nmols(i_not_fixed) + + xbar = x(ilubar+1) + ybar = x(ilubar+2) + zbar = x(ilubar+3) + beta = x(ilugan+1) + gama = x(ilugan+2) + teta = x(ilugan+3) + + call eulerrmat(beta,gama,teta,v1,v2,v3) + + idatom = idfirst(i_not_fixed) - 1 + do iatom = 1, natoms(i_not_fixed) + icart = icart + 1 + idatom = idatom + 1 + call compcart(icart,xbar,ybar,zbar,& + coor(idatom,1),coor(idatom,2),& + coor(idatom,3),& + v1,v2,v3) + + ntcon(1) = nconnect(idatom,1) + do k = 2, maxcon(idatom) + ntcon(k) = nconnect(idatom,k) + i_ref_atom + end do + write(30,tinker_atom_line) i_ref_atom+iatom,& + ele(idatom), (xcart(icart, k), k = 1, 3),& + (ntcon(k), k = 1, maxcon(idatom)) + end do + i_ref_atom = i_ref_atom + natoms(i_not_fixed) + + ilugan = ilugan + 3 + ilubar = ilubar + 3 + + end do + + else + + i_fixed = i_fixed + 1 + idatom = idfirst(i_fixed) - 1 + do iatom = 1, natoms(i_fixed) + idatom = idatom + 1 + ntcon(1) = nconnect(idatom,1) + do k = 2, maxcon(idatom) + ntcon(k) = nconnect(idatom,k) + i_ref_atom + end do + write(30,tinker_atom_line) i_ref_atom+iatom, ele(idatom),& + (coor(idatom,k), k = 1, 3),& + (ntcon(k), k = 1, maxcon(idatom)) + end do + i_ref_atom = i_ref_atom + natoms(i_fixed) + + end if + + end do + close(30) + end if + + return +end subroutine output + +function i5hex(i) + implicit none + integer :: i + character(len=5) i5hex + if(i <= 99999) then + write(i5hex,"(i5)") i + else + write(i5hex,"(z5)") i + end if +end + +subroutine write_connect(iostream,idatom,iatom,ifirst) + use sizes + use input + implicit none + integer :: i, j, iostream, iatom, idatom, ifirst + character(len=5) :: i5hex, tmp_i5hex + character(len=strl) :: str + if(maxcon(iatom+idatom) == 0) return + str = "CONECT" + j=7 + tmp_i5hex = i5hex(iatom+ifirst-1) + write(str(j:j+4),"(a5)") tmp_i5hex + do i = 1, maxcon(iatom+idatom) + j = j + 5 + tmp_i5hex = i5hex(nconnect(iatom+idatom,i)+ifirst-1) + write(str(j:j+4),"(a5)") tmp_i5hex + end do + write(iostream,"(a)") trim(adjustl(str)) +end subroutine write_connect + + + + + + diff --git a/src/pgencan.f90 b/src/pgencan.f90 new file mode 100644 index 0000000..3da6df3 --- /dev/null +++ b/src/pgencan.f90 @@ -0,0 +1,98 @@ +! +! Written by Ernesto G. Birgin, 2009-2011. +! Copyright (c) 2009-2018, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine pgencan: This is only a interface to set some +! parameters. What might be important here +! is the setup of the constraint_axis constraint. +! + +subroutine pgencan(n,x,fx) + + use sizes + use compute_data + use usegencan + implicit none + + double precision :: lambda(1), rho(1) + double precision :: epsgpsn,gpsupn,delmin + double precision :: x(n), fx + integer :: m,iprint,maxfc,ncomp,iter,fcnt,gcnt,cgcnt,inform + integer :: n, i + integer :: trtype1 + integer :: itype, imol + + ! Setup upper and lower bounds for variables. Usually there are none, + ! but one might want to restrict the rotation of the molecules in one + ! or more axis + + do i = 1,n/2 + l(i) = - 1.0d+20 + u(i) = 1.0d+20 + end do + i = n/2 + do itype = 1, ntype + do imol = 1, nmols(itype) + if ( constrain_rot(itype,1) ) then + l(i+1) = rot_bound(itype,1,1) - dabs(rot_bound(itype,1,2)) + u(i+1) = rot_bound(itype,1,1) + dabs(rot_bound(itype,1,2)) + else + l(i+1) = - 1.0d+20 + u(i+1) = 1.0d+20 + end if + if ( constrain_rot(itype,2) ) then + l(i+2) = rot_bound(itype,2,1) - dabs(rot_bound(itype,2,2)) + u(i+2) = rot_bound(itype,2,1) + dabs(rot_bound(itype,2,2)) + else + l(i+2) = - 1.0d+20 + u(i+2) = 1.0d+20 + end if + if ( constrain_rot(itype,3) ) then + l(i+3) = rot_bound(itype,3,1) - dabs(rot_bound(itype,3,2)) + u(i+3) = rot_bound(itype,3,1) + dabs(rot_bound(itype,3,2)) + else + l(i+3) = - 1.0d+20 + u(i+3) = 1.0d+20 + end if + i = i + 3 + end do + end do + + m = 0 + epsgpsn = 1.0d-06 + maxfc = 10 * maxit + if(init1) iprint = iprint1 + if(.not.init1) iprint = iprint2 + ncomp = 50 + delmin = 2.d0 + trtype1 = 1 + + call easygencan(n,x,l,u,m,lambda,rho,epsgpsn,maxit,maxfc,& + trtype1,iprint,ncomp,fx,g,gpsupn,iter,fcnt,& + gcnt,cgcnt,inform,wi,wd,delmin) + if( inform.ne.7 .and.(iprint1.gt.0 .or. iprint2.gt.0) ) write(*,*) + + return +end subroutine pgencan + +! +! Function that test convergence according to Packmol precision +! + +function packmolprecision(n,x) + use input, only : precision + use compute_data, only : fdist, frest + implicit none + integer :: n + double precision :: f, x(n) + logical :: packmolprecision + + call computef(n,x,f) + + packmolprecision = .false. + if ( fdist < precision .and. frest < precision ) then + packmolprecision = .true. + end if + +end function packmolprecision diff --git a/src/polartocart.f90 b/src/polartocart.f90 new file mode 100644 index 0000000..5007ff3 --- /dev/null +++ b/src/polartocart.f90 @@ -0,0 +1,106 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine eulerrmat: Computes the rotation matrix from the +! Euler angles +! +! Note that: +! In this routine, beta is a rotation about the y-axis +! gama is a rotation about the z-axis +! teta is a rotation about the x-axis + +subroutine eulerrmat(beta,gama,teta,v1,v2,v3) + + implicit none + double precision :: beta, gama, teta + double precision :: cb, sb, cg, sg, ct, st + double precision :: v1(3), v2(3), v3(3) + + cb = dcos(beta) + sb = dsin(beta) + cg = dcos(gama) + sg = dsin(gama) + ct = dcos(teta) + st = dsin(teta) + + v1(1)=-sb * sg * ct + cb * cg + v1(2)=-sb * cg * ct - cb * sg + v1(3)= sb * st + + v2(1)= cb * sg * ct + sb * cg + v2(2)= cb * cg * ct - sb * sg + v2(3)=-cb * st + + v3(1)= sg * st + v3(2)= cg * st + v3(3)= ct + + return +end subroutine eulerrmat + +! +! Subroutine compcart: Compute cartesian coordinates using +! the center of mass, the canonical coordinates +! and the rotation matrix +! + +subroutine compcart(icart,xbar,ybar,zbar,& + xcoor,ycoor,zcoor,v1,v2,v3) + + use compute_data, only : xcart + implicit none + integer :: icart + double precision :: xbar, ybar, zbar + double precision :: xcoor, ycoor, zcoor + double precision :: v1(3), v2(3), v3(3) + + xcart(icart,1) = xbar + xcoor*v1(1) + ycoor*v2(1) + zcoor*v3(1) + xcart(icart,2) = ybar + xcoor*v1(2) + ycoor*v2(2) + zcoor*v3(2) + xcart(icart,3) = zbar + xcoor*v1(3) + ycoor*v2(3) + zcoor*v3(3) + + return +end subroutine compcart + +! +! Subroutine eulerfixed: This routine was added because it defines +! the rotation in the "human" way, an is thus used +! to set the position of the fixed molecules. +! That means: beta is a counterclockwise rotation around x axis. +! gama is a counterclockwise rotation around y axis. +! teta is a counterclockwise rotation around z axis. +! The other routine should better do this as well, but then we need to change +! all the derivative calculations, just for the sake of human interpretation +! of the rotation which, in that case, is not really important. Maybe some day. +! + +subroutine eulerfixed(beta,gama,teta,v1,v2,v3) + + implicit none + double precision :: beta, gama, teta + double precision :: c1, s1, c2, s2, c3, s3 + double precision :: v1(3), v2(3), v3(3) + + c1 = dcos(beta) + s1 = dsin(beta) + c2 = dcos(gama) + s2 = dsin(gama) + c3 = dcos(teta) + s3 = dsin(teta) + + v1(1) = c2*c3 + v1(2) = c1*s3 + c3*s1*s2 + v1(3) = s1*s3 - c1*c3*s2 + + v2(1) = -c2*s3 + v2(2) = c1*c3 - s1*s2*s3 + v2(3) = c1*s2*s3 + c3*s1 + + v3(1) = s2 + v3(2) = -c2*s1 + v3(3) = c1*c2 + + return +end subroutine eulerfixed + diff --git a/src/random.f90 b/src/random.f90 new file mode 100644 index 0000000..05beeac --- /dev/null +++ b/src/random.f90 @@ -0,0 +1,50 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! + +! +! Function that returns a real random number between 0. and 1. +! + +double precision function rnd() + + call random_number(rnd) + + return +end function rnd + +! +! Subroutine that initializes the random number generator given a seed +! + +subroutine init_random_number(iseed) + integer :: size + integer :: i, iseed + integer, allocatable :: seed(:) + call random_seed(size=size) + allocate(seed(size)) + do i = 1, size + seed(i) = i*iseed + end do + call random_seed(put=seed) + deallocate(seed) + return +end subroutine init_random_number + +! +! Subroutine that uses the date to create a random seed +! + +subroutine seed_from_time(seed) + + implicit none + integer :: seed, value(8) + character(len=10) :: b(3) + call date_and_time( b(1), b(2), b(3), value ) + seed = value(1)+value(2)+value(3)+value(4)+value(5)+value(6)+value(7)+value(8) + seed = seed + value(1)+value(2)+value(3)+value(4)+value(5)/100+value(6)*100+value(7)/10+value(8)*10 + +end subroutine seed_from_time + diff --git a/src/resetboxes.f90 b/src/resetboxes.f90 new file mode 100644 index 0000000..9598400 --- /dev/null +++ b/src/resetboxes.f90 @@ -0,0 +1,30 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine resetboxes: Subroutine that resets the occupancy of +! linked cell boxes +! + +subroutine resetboxes() + + use sizes + use compute_data, only : latomfirst, latomfix, & + lboxfirst, lboxnext, hasfree + implicit none + integer :: i, j, k, ibox + + ! Reset data for boxes that contain fixed atom + + ibox = lboxfirst + do while( ibox > 0 ) + call ibox_to_ijk(ibox,i,j,k) + latomfirst(i,j,k) = latomfix(i,j,k) + hasfree(i,j,k) = .false. + ibox = lboxnext(ibox) + end do + lboxfirst = 0 + +end subroutine resetboxes + diff --git a/src/restmol.f90 b/src/restmol.f90 new file mode 100644 index 0000000..8466cb3 --- /dev/null +++ b/src/restmol.f90 @@ -0,0 +1,86 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! subroutine restmol: either compute the restraint function +! value for a single molecule or solve +! the problem of puting this molecule +! in the restraint region +! + +subroutine restmol(itype,ilubar,n,x,fx,solve) + + use sizes + use compute_data + use usegencan + implicit none + + integer :: n, nsafe, ntotsafe, itype, i, ilubar, nmoltype, ip1, ip2 + double precision :: x(n), fx + logical :: solve, initsafe + + ! Saving global problem variables + + nsafe = n + ntotsafe = ntotmol + nmoltype = nmols(itype) + do i = 1, ntype + compsafe(i) = comptype(i) + end do + initsafe = init1 + + ! Preparing system to solve for this molecule + + n = 6 + ntotmol = 1 + nmols(itype) = 1 + xmol(1) = x(ilubar+1) + xmol(2) = x(ilubar+2) + xmol(3) = x(ilubar+3) + xmol(4) = x(ilubar+ntotsafe*3+1) + xmol(5) = x(ilubar+ntotsafe*3+2) + xmol(6) = x(ilubar+ntotsafe*3+3) + do i = 1, ntype + if(i.eq.itype) then + comptype(i) = .true. + else + comptype(i) = .false. + end if + end do + init1 = .true. + + ! If not going to solve the problem, compute energy and return + + if(.not.solve) then + call computef(n,xmol,fx) + ! Otherwise, put this molecule in its constraints + else + ip1 = iprint1 + ip2 = iprint2 + iprint1 = 0 + iprint2 = 0 + call pgencan(n,xmol,fx) + iprint1 = ip1 + iprint2 = ip2 + end if + + ! Restoring original problem data + + ntotmol = ntotsafe + n = nsafe + nmols(itype) = nmoltype + x(ilubar+1) = xmol(1) + x(ilubar+2) = xmol(2) + x(ilubar+3) = xmol(3) + x(ilubar+ntotmol*3+1) = xmol(4) + x(ilubar+ntotmol*3+2) = xmol(5) + x(ilubar+ntotmol*3+3) = xmol(6) + do i = 1, ntype + comptype(i) = compsafe(i) + end do + init1 = initsafe + + return +end subroutine restmol + diff --git a/src/setibox.f90 b/src/setibox.f90 new file mode 100644 index 0000000..36f9b94 --- /dev/null +++ b/src/setibox.f90 @@ -0,0 +1,30 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine setibox: set box index for given coordinates +! + +subroutine setibox(x,y,z,sizemin,boxl,nboxes,iboxx,iboxy,iboxz) + + implicit none + double precision :: x, y, z, sizemin(3), boxl(3), xtemp, ytemp, ztemp + integer :: nboxes(3), iboxx, iboxy, iboxz + + xtemp = x - sizemin(1) + ytemp = y - sizemin(2) + ztemp = z - sizemin(3) + iboxx = int(xtemp/boxl(1)) + 1 + iboxy = int(ytemp/boxl(2)) + 1 + iboxz = int(ztemp/boxl(3)) + 1 + if(xtemp.le.0) iboxx = 1 + if(ytemp.le.0) iboxy = 1 + if(ztemp.le.0) iboxz = 1 + if(iboxx.gt.nboxes(1)) iboxx = nboxes(1) + if(iboxy.gt.nboxes(2)) iboxy = nboxes(2) + if(iboxz.gt.nboxes(3)) iboxz = nboxes(3) + + return +end subroutine setibox + diff --git a/src/setijk.f90 b/src/setijk.f90 new file mode 100644 index 0000000..dbfc14e --- /dev/null +++ b/src/setijk.f90 @@ -0,0 +1,46 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutines that set the indexes of a three-dimensional array +! given the undimensional counter of the vector (for an array +! with dimensions (0:nboxes(1)+1,0:nboxes(2)+1,0:nboxes(3)+1), and +! vice-versa. +! + +subroutine ibox_to_ijk(ibox,i,j,k) + + use compute_data, only : nb2 + implicit none + integer :: ibox, i, j, k, iibox + + k = mod(ibox,nb2(3)) + if ( k == 0 ) k = nb2(3) + + iibox = ibox - k + iibox = iibox / nb2(3) + 1 + j = mod(iibox,nb2(2)) + if ( j == 0 ) j = nb2(2) + + iibox = iibox - j + iibox = iibox / nb2(2) + 1 + i = mod(iibox,nb2(1)) + if ( i == 0 ) i = nb2(1) + + k = k - 1 + j = j - 1 + i = i - 1 + +end subroutine ibox_to_ijk + +subroutine ijk_to_ibox(i,j,k,ibox) + + use compute_data, only : nb2 + implicit none + integer :: i, j, k, ibox + + ibox = i*nb2(2)*nb2(3) + j*nb2(3) + k + 1 + +end subroutine ijk_to_ibox + diff --git a/src/setsizes.f90 b/src/setsizes.f90 new file mode 100644 index 0000000..66c3335 --- /dev/null +++ b/src/setsizes.f90 @@ -0,0 +1,364 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine that sets the sizes of all allocatable arrays +! + +subroutine setsizes() + + use exit_codes + use sizes + use compute_data + use input + use usegencan + use flashsort + + implicit none + integer :: i, ival, ilast, iline, itype + integer :: ioerr + integer :: strlength + character(len=strl) :: record, word, blank, alltospace + logical :: inside_structure + + ! Instructions on how to run packmol + + write(*,*) ' Packmol must be run with: packmol < inputfile.inp ' + write(*,*) + write(*,*) ' Userguide at: http://m3g.iqm.unicamp.br/packmol ' + write(*,*) + + ! Getting input lines from the input file + + write(*,*) ' Reading input file... (Control-C aborts)' + + do i = 1, strl + blank(i:i) = ' ' + end do + nlines = 0 + maxkeywords = 0 + ntype = 0 + do + read(5,str_format,iostat=ioerr) record + + ! Replace any strange blank character by spaces + record = alltospace(record) + + if ( ioerr /= 0 ) exit + + ! Remove comments + i = 0 + do while( i < strl ) + i = i + 1 + if ( record(i:i) == '#' ) exit + end do + i = i - 1 + if ( i > 0 ) then + record = record(1:i)//blank(i+1:strl) + else + cycle + end if + if ( strlength(record) < 1 ) cycle + record = trim(record) + + ! + ! Convert file name paths with spaces to single strings + ! + ! check for quotes and replace spaces by @ + call parse_spaces(record) + + ! Number of lines of the input file + + nlines = nlines + 1 + + ! Check the number of keywords in this line + + i = 0 + ival = 0 + do while(i < strl) + i = i + 1 + ilast = i + do while(record(i:i) > ' ' .and. i < strl) + i = i + 1 + end do + if(i > ilast) then + ival = ival + 1 + maxkeywords = max(maxkeywords,ival) + end if + end do + end do + rewind(5) + + allocate(inputfile(nlines),keyword(nlines,maxkeywords)) + + ! Read input to inputfile array + + iline = 0 + do + read(5,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + + ! Convert all strange blank characters to spaces + + record = alltospace(record) + call parse_spaces(record) + + ! Remove comments + + i = 0 + do while( i < strl ) + i = i + 1 + if ( record(i:i) == '#' ) exit + end do + i = i - 1 + if ( i > 0 ) then + record = record(1:i)//blank(i+1:strl) + else + cycle + end if + if ( strlength(record) < 1 ) cycle + + iline = iline + 1 + inputfile(iline) = record + end do + + ! Read all keywods into keyword array + + call getkeywords() + + ! Checking the filetype of coordinate files (default is pdb) + + tinker = .false. + pdb = .false. + xyz = .false. + moldy = .false. + fbins = dsqrt(3.d0) + do i = 1, nlines + if(keyword(i,1).eq.'filetype') then + if(keyword(i,2).eq.'tinker') tinker = .true. + if(keyword(i,2).eq.'pdb') pdb = .true. + if(keyword(i,2).eq.'xyz') xyz = .true. + if(keyword(i,2).eq.'moldy') moldy = .true. + end if + if(keyword(i,1).eq.'fbins') then + record = keyword(i,2) + read(record,*,iostat=ioerr) fbins + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Invalid value for fbins. ' + stop exit_code_input_error + end if + end if + end do + if(.not.pdb.and..not.tinker.and..not.xyz.and..not.moldy) then + pdb = .true. + write(*,*) + write(*,*)' WARNING: File type not (correctly?) specified, using PDB' + end if + + ! Getting the number of different types of molecules + + ntype = 0 + do iline = 1, nlines + if ( keyword(iline,1) == "structure" ) then + ntype = ntype + 1 + if ( keyword(iline,2) == "none" ) then + write(*,*) ' ERROR: structure without filename. ' + write(*,*) ' The syntax must be, for example: structure water.pdb ' + stop exit_code_input_error + end if + end if + end do + + allocate(nmols(ntype),natoms(ntype),idfirst(ntype),constrain_rot(ntype,3),& + rot_bound(ntype,3,2),dmax(ntype),& + cmxmin(ntype),cmymin(ntype),cmzmin(ntype),& + cmxmax(ntype),cmymax(ntype),cmzmax(ntype),& + comptype(ntype),compsafe(ntype),& + restart_from(0:ntype),restart_to(0:ntype),& + nloop_type(ntype),nloop0_type(ntype)) + + ! Reading the number of molecules of each type, and the number of atoms + ! of each molecule type + + itype = 0 + inside_structure = .false. + do iline = 1, nlines + if ( keyword(iline,1) == "structure" ) then + inside_structure = .true. + itype = itype + 1 + natoms(itype) = 0 + nmols(itype) = 0 + nloop_type(itype) = 0 + nloop0_type(itype) = 0 + + ! Read the number of atoms of this type of molecule + + open(10,file=keyword(iline,2),status='old',iostat=ioerr) + if( ioerr /= 0 ) call failopen(keyword(iline,2)) + if ( pdb ) then + do + read(10,str_format,iostat=ioerr) record + if ( ioerr /= 0 ) exit + if ( record(1:4) == "ATOM" .or. record(1:6) == "HETATM" ) then + natoms(itype) = natoms(itype) + 1 + end if + end do + end if + if ( tinker ) then + do + read(10,*,iostat=ioerr) i + if ( ioerr /= 0 ) cycle + natoms(itype) = i + exit + end do + end if + if ( xyz ) then + read(10,*,iostat=ioerr) i + if ( ioerr == 0 ) natoms(itype) = i + end if + if ( moldy ) then + read(10,*,iostat=ioerr) word, i + if ( ioerr == 0 ) natoms(itype) = i + end if + close(10) + if ( natoms(itype) == 0 ) then + write(*,*) ' ERROR: Could not read any atom from file: ', & + trim(adjustl(keyword(iline,2))) + end if + + end if + + if ( keyword(iline,1) == "end" .and. & + keyword(iline,2) == "structure" ) inside_structure = .false. + + ! Read number of molecules for each type + + if ( keyword(iline,1) == "number" ) then + read(keyword(iline,2),*,iostat=ioerr) nmols(itype) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Error reading number of molecules of type ', itype + stop exit_code_input_error + end if + if ( nmols(itype) < 1 ) then + write(*,*) ' ERROR: Number of molecules of type ', itype, ' set to less than 1 ' + stop exit_code_input_error + end if + end if + + ! Read the (optional) number of gencan loops for this molecule + + if ( keyword(iline,1) == "nloop" ) then + if ( inside_structure ) then + read(keyword(iline,2),*,iostat=ioerr) nloop_type(itype) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Error reading number of loops of type ', itype + stop exit_code_input_error + end if + if ( nloop_type(itype) < 1 ) then + write(*,*) ' ERROR: Number of loops of type ', itype, ' set to less than 1 ' + stop exit_code_input_error + end if + end if + end if + + ! Read the (optional) number of gencan loops for initial setup for this molecule + + if ( keyword(iline,1) == "nloop0" ) then + if ( inside_structure ) then + read(keyword(iline,2),*,iostat=ioerr) nloop0_type(itype) + if ( ioerr /= 0 ) then + write(*,*) ' ERROR: Error reading number of loops-0 of type ', itype + stop exit_code_input_error + end if + if ( nloop0_type(itype) < 1 ) then + write(*,*) ' ERROR: Number of loops-0 of type ', itype, ' set to less than 1 ' + stop exit_code_input_error + end if + end if + end if + + end do + do itype = 1, ntype + if ( nmols(itype) == 0 ) then + write(*,*) ' Warning: Number of molecules not set for type '& + ,itype,': assuming 1 ' + nmols(itype) = 1 + end if + end do + + ! Total number of atoms and molecules + + ntotat = 0 + ntotmol = 0 + do itype = 1, ntype + ntotat = ntotat + nmols(itype)*natoms(itype) + ntotmol = ntotmol + nmols(itype) + end do + + ! The number of variables of the problem + + nn = ntotmol*6 + + ! The number of bins of the linked cell method in each direction + + nbp = int((fbins*dble(ntotat))**(1.d0/3.d0)) + 1 + + ! Allocate arrays depending on nbp parameter + + allocate(latomfirst(0:nbp+1,0:nbp+1,0:nbp+1),& + latomfix(0:nbp+1,0:nbp+1,0:nbp+1),& + hasfree(0:nbp+1,0:nbp+1,0:nbp+1),& + lboxnext((nbp+2)**3)) + + ! Checking the total number of restrictions defined + + i = 0 + do iline = 1, nlines + if ( keyword(iline,1) == 'fixed' .or. & + keyword(iline,1) == 'inside' .or. & + keyword(iline,1) == 'outside' .or. & + keyword(iline,1) == 'over' .or. & + keyword(iline,1) == 'above' .or. & + keyword(iline,1) == 'below' .or. & + keyword(iline,1) == 'constrain_rotation' ) then + i = i + 1 + end if + end do + maxrest = i + mrperatom = i + + ! Allocate arrays depending on ntotat, nn, maxrest, and mrperatom + + allocate(nratom(ntotat),iratom(ntotat,mrperatom),ibmol(ntotat),& + ibtype(ntotat),xcart(ntotat,3),coor(ntotat,3),& + radius(ntotat),radius_ini(ntotat),fscale(ntotat),& + use_short_radius(ntotat), short_radius(ntotat), short_radius_scale(ntotat),& + gxcar(ntotat,3),& + latomnext(ntotat),& + fdist_atom(ntotat), frest_atom(ntotat),& + fmol(ntotat),radiuswork(ntotat),& + fixedatom(ntotat)) + allocate(ityperest(maxrest),restpars(maxrest,9)) + allocate(xmol(nn)) + + ! Allocate other arrays used for input and output data + + allocate(nconnect(ntotat,9),maxcon(ntotat),& + amass(ntotat),charge(ntotat),ele(ntotat)) + + allocate(irestline(maxrest),linestrut(ntype,2),resnumbers(ntype),& + input_itype(ntype),changechains(ntype),chain(ntype),& + fixedoninput(ntype),pdbfile(ntype),name(ntype),& + segid(ntype),maxmove(ntype),connect(ntype)) + + ! Allocate vectors for flashsort + + allocate(indflash(ntotat),lflash(ntotat)) + + ! Allocate arrays for GENCAN + + allocate(l(nn),u(nn),wd(8*nn),wi(nn),g(nn)) + +end subroutine setsizes + diff --git a/src/sizes.f90 b/src/sizes.f90 new file mode 100644 index 0000000..640b757 --- /dev/null +++ b/src/sizes.f90 @@ -0,0 +1,31 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! +! sizes.i: Define the maximum dimensions of the problems +! +! maxrest: Maximum number of restrictions +! mrperatom: Maximum number of restrictions per atom +! maxtry: Number of tries for building the initial point +! nbp: Maximum number of boxes for fast function evaluation (nbp**3) +! nn: Maximum number of variables +! (at least the number of molecules*6) +! maxkeywords: Maximum number of keywords in input file +! + +module sizes + + integer :: maxrest + integer :: mrperatom + integer :: maxtry + integer :: nbp + integer :: nn + integer :: maxkeywords + + integer, parameter :: strl = 1000 + character(len=*), parameter :: str_format = "( a1000 )" + +end module sizes + diff --git a/src/strlength.f90 b/src/strlength.f90 new file mode 100644 index 0000000..301473c --- /dev/null +++ b/src/strlength.f90 @@ -0,0 +1,97 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Function that determines the length of a string (better than +! intrinsic "len" because considers tabs as empty characters) +! +function strlength(string) + + use sizes + implicit none + integer :: strlength + character(len=strl) :: string + logical empty_char + + strlength = strl + do while(empty_char(string(strlength:strlength))) + strlength = strlength - 1 + if ( strlength == 0 ) exit + end do + +end function strlength + +! +! Function that determines if a character is empty (empty, space, or tab) +! (nice suggestion from Ian Harvey -IanH0073- at github) +! + +function empty_char(ch) + character :: ch + logical empty_char + empty_char = .false. + if ( ch == '' .or. & + ch == achar(9) .or. & + ch == achar(32) ) then + empty_char = .true. + end if +end function empty_char + +! +! Function that replaces all non-space empty characters by spaces +! + +function alltospace(record) + + use sizes + implicit none + integer :: i + logical :: empty_char + character(len=strl) :: alltospace, record + + do i = 1, strl + if ( empty_char(record(i:i)) ) then + alltospace(i:i) = " " + else + alltospace(i:i) = record(i:i) + end if + end do + +end function alltospace + +subroutine parse_spaces(record) + use exit_codes + use input, only : forbidden_char + use sizes + implicit none + integer :: i, strlength + character(len=strl) :: record + ! Replace spaces within quotes by ~ + i = 0 + do while(i < strlength(record)) + i = i + 1 + if ( record(i:i) == '"' ) then + i = i + 1 + do while(record(i:i) /= '"') + i = i + 1 + if( i > strlength(record) ) then + write(*,*) ' ERROR: Could not find ending quotes in line: ', trim(record) + stop exit_code_input_error + end if + if(record(i:i) == " ") then + record(i:i) = forbidden_char + end if + end do + end if + end do + ! Replace spaces after \ by the forbidden_char and remove the \ + i = 0 + do while(i < strlength(record)-1) + i = i + 1 + if (record(i:i) == "\" .and. record(i+1:i+1) == " ") then + record(i:i) = forbidden_char + record = record(1:i)//record(i+2:strlength(record)) + end if + end do +end \ No newline at end of file diff --git a/src/swaptype.f90 b/src/swaptype.f90 new file mode 100644 index 0000000..8d11f70 --- /dev/null +++ b/src/swaptype.f90 @@ -0,0 +1,89 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine that swaps indexes for packing molecules one at a time +! + +subroutine swaptype(n,x,itype,action) + + use sizes, only : nn + use compute_data, only : ntype, comptype, nmols, ntotmol + use input, only : nloop, nloop_all, nloop_type + use swaptypemod + use ahestetic + implicit none + integer ::n, itype, ilubar, ilugan, i, action + double precision :: x(nn) + + ! Save original data + + if ( action == 0 ) then + do i = 1, nn + xfull(i) = x(i) + end do + ntemp = n + ntottemp = ntotmol + end if + + ! Swapping data for packing this itype + + if ( action == 1 ) then + do i = 1, ntype + if(i == itype) then + comptype(i) = .true. + else + comptype(i) = .false. + end if + end do + n = nmols(itype) * 6 + ntotmol = nmols(itype) + nloop = nloop_type(itype) + ilubar = 0 + do i = 1, itype - 1 + ilubar = ilubar + nmols(i) * 3 + end do + ilubar = ilubar + 1 + ilugan = ntemp/2 + ilubar + do i = 1, n / 2 + x(i) = xfull(ilubar) + x(i+n/2) = xfull(ilugan) + ilubar = ilubar + 1 + ilugan = ilugan + 1 + end do + end if + + ! Save results for this type + + if ( action == 2 ) then + ilubar = 0 + do i = 1, itype - 1 + ilubar = ilubar + nmols(i)*3 + end do + ilubar = ilubar + 1 + ilugan = ntemp/2 + ilubar + do i = 1, n/2 + xfull(ilubar) = x(i) + xfull(ilugan) = x(i+n/2) + ilubar = ilubar + 1 + ilugan = ilugan + 1 + end do + end if + + ! Restore all-molecule vectors + + if ( action == 3 ) then + n = ntemp + ntotmol = ntottemp + nloop = nloop_all + do i = 1, n + x(i) = xfull(i) + end do + do i = 1, ntype + comptype(i) = .true. + end do + end if + +end subroutine swaptype + diff --git a/src/swaptypemod.f90 b/src/swaptypemod.f90 new file mode 100644 index 0000000..d808659 --- /dev/null +++ b/src/swaptypemod.f90 @@ -0,0 +1,16 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Module that contains the temporary data for swap molecules +! for individual packing +! + +module swaptypemod + + integer :: ntemp, ntottemp + double precision, allocatable :: xfull(:) ! (nn) + +end module swaptypemod + diff --git a/src/title.f90 b/src/title.f90 new file mode 100644 index 0000000..5625d6c --- /dev/null +++ b/src/title.f90 @@ -0,0 +1,19 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! + +! Routine to print the title + +subroutine title() + + use ahestetic + write(*,hash3_line) + write(*,"(' PACKMOL - Packing optimization for the automated generation of', /& + &' starting configurations for molecular dynamics simulations.', /& + &' ',/& + &t62,' Version 20.11.1 ')") + write(*,hash3_line) + +end subroutine title diff --git a/src/tobar.f90 b/src/tobar.f90 new file mode 100644 index 0000000..7ec66d5 --- /dev/null +++ b/src/tobar.f90 @@ -0,0 +1,42 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! subroutine tobar: moves molecules to their baricentres +! + +subroutine tobar() + + use sizes + use compute_data, only : coor, ntype, natoms, idfirst + implicit none + integer :: idatom, itype, iatom + double precision :: xcm, ycm, zcm + + do itype = 1, ntype + idatom = idfirst(itype) - 1 + xcm = 0.d0 + ycm = 0.d0 + zcm = 0.d0 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + xcm = xcm + coor(idatom,1) + ycm = ycm + coor(idatom,2) + zcm = zcm + coor(idatom,3) + end do + xcm = xcm / natoms(itype) + ycm = ycm / natoms(itype) + zcm = zcm / natoms(itype) + idatom = idfirst(itype) - 1 + do iatom = 1, natoms(itype) + idatom = idatom + 1 + coor(idatom,1) = coor(idatom,1) - xcm + coor(idatom,2) = coor(idatom,2) - ycm + coor(idatom,3) = coor(idatom,3) - zcm + end do + end do + + return +end subroutine tobar + diff --git a/src/usegencan.f90 b/src/usegencan.f90 new file mode 100644 index 0000000..b390d8d --- /dev/null +++ b/src/usegencan.f90 @@ -0,0 +1,18 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Optimization variables passed as common go pgencan + +module usegencan + + use sizes + implicit none + + integer :: maxit, iprint1, iprint2 + integer, allocatable :: wi(:) ! (nn) + double precision, allocatable :: l(:), u(:), g(:) ! (nn) + double precision, allocatable :: wd(:) ! (8*nn) + +end module usegencan diff --git a/src/writesuccess.f90 b/src/writesuccess.f90 new file mode 100644 index 0000000..4854c7c --- /dev/null +++ b/src/writesuccess.f90 @@ -0,0 +1,46 @@ +! +! Written by Leandro Martínez, 2009-2011. +! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, +! Ernesto G. Birgin. +! +! Subroutine writesuccess +! +! Writes the success messages for good packings +! + +subroutine writesuccess(itype,fdist,frest,f) + + use input, only : input_itype + use compute_data, only : ntype + use ahestetic + implicit none + integer :: itype + double precision :: fdist, frest, f + + if(itype.le.ntype) then + write(*,dash1_line) + write(*,*)' Packing solved for molecules of type', input_itype(itype) + write(*,*)' Objective function value: ', f + write(*,*)' Maximum violation of target distance: ',fdist + write(*,*)' Max. constraint violation: ', frest + write(*,dash1_line) + else + write(*,hash3_line) + write(*,"(& + &t33, ' Success! ', /,& + &t14, ' Final objective function value: ', e10.5, /,& + &t14, ' Maximum violation of target distance: ', f10.6, /,& + &t14, ' Maximum violation of the constraints: ', e10.5 & + &)") f, fdist, frest + write(*,dash3_line) + write(*,"(& + &t14,' Please cite this work if Packmol was useful: ',/,/,& + &t11,' L. Martinez, R. Andrade, E. G. Birgin, J. M. Martinez, ',/,& + &t9,' PACKMOL: A package for building initial configurations for',/,& + &t19,' molecular dynamics simulations. ',/,& + &t10,' Journal of Computational Chemistry, 30:2157-2164,2009.' )") + write(*,hash3_line) + end if + +end subroutine writesuccess + From f23a6e353ce26fd3d8931b9377fd8e4ab1490b1a Mon Sep 17 00:00:00 2001 From: "Federico E. Benelli" Date: Wed, 21 Dec 2022 22:52:26 -0300 Subject: [PATCH 2/4] added fpm compatiblity --- ahestetic.f90 | 21 - cenmass.f90 | 103 ----- checkpoint.f90 | 116 ----- comparegrad.f90 | 98 ---- comprest.f90 | 168 ------- compute_data.f90 | 63 --- computef.f90 | 220 --------- computeg.f90 | 309 ------------- data_types.f90 | 10 - exit_codes.f90 | 18 - flashmod.f90 | 21 - flashsort.f90 | 95 ---- fparc.f90 | 77 ---- getinp.f90 | 1115 ---------------------------------------------- gparc.f90 | 87 ---- gwalls.f90 | 264 ----------- heuristics.f90 | 151 ------- initial.f90 | 592 ------------------------ input.f90 | 80 ---- jacobi.f90 | 106 ----- output.f90 | 807 --------------------------------- packmol.f90 | 954 --------------------------------------- pgencan.f90 | 98 ---- polartocart.f90 | 106 ----- random.f90 | 50 --- resetboxes.f90 | 30 -- restmol.f90 | 86 ---- setibox.f90 | 30 -- setijk.f90 | 46 -- setsizes.f90 | 364 --------------- sizes.f90 | 31 -- strlength.f90 | 97 ---- swaptype.f90 | 89 ---- swaptypemod.f90 | 16 - title.f90 | 19 - tobar.f90 | 42 -- usegencan.f90 | 18 - writesuccess.f90 | 46 -- 38 files changed, 6643 deletions(-) delete mode 100644 ahestetic.f90 delete mode 100644 cenmass.f90 delete mode 100644 checkpoint.f90 delete mode 100644 comparegrad.f90 delete mode 100644 comprest.f90 delete mode 100644 compute_data.f90 delete mode 100644 computef.f90 delete mode 100644 computeg.f90 delete mode 100644 data_types.f90 delete mode 100644 exit_codes.f90 delete mode 100644 flashmod.f90 delete mode 100644 flashsort.f90 delete mode 100644 fparc.f90 delete mode 100644 getinp.f90 delete mode 100644 gparc.f90 delete mode 100644 gwalls.f90 delete mode 100644 heuristics.f90 delete mode 100644 initial.f90 delete mode 100644 input.f90 delete mode 100644 jacobi.f90 delete mode 100644 output.f90 delete mode 100644 packmol.f90 delete mode 100644 pgencan.f90 delete mode 100644 polartocart.f90 delete mode 100644 random.f90 delete mode 100644 resetboxes.f90 delete mode 100644 restmol.f90 delete mode 100644 setibox.f90 delete mode 100644 setijk.f90 delete mode 100644 setsizes.f90 delete mode 100644 sizes.f90 delete mode 100644 strlength.f90 delete mode 100644 swaptype.f90 delete mode 100644 swaptypemod.f90 delete mode 100644 title.f90 delete mode 100644 tobar.f90 delete mode 100644 usegencan.f90 delete mode 100644 writesuccess.f90 diff --git a/ahestetic.f90 b/ahestetic.f90 deleted file mode 100644 index ed231f6..0000000 --- a/ahestetic.f90 +++ /dev/null @@ -1,21 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Module that contains some ahestetic output definitions -! -module ahestetic - - character(len=13), parameter :: dash1_line = "( 80('-') )",& - dash2_line = "(/,80('-') )",& - dash3_line = "(/,80('-'),/)" - - character(len=13), parameter :: hash1_line = "( 80('#') )",& - hash2_line = "(/,80('#') )",& - hash3_line = "(/,80('#'),/)" - - character(len=31), parameter :: prog1_line = "(' Packing:|0 ',tr60,'100%|' )",& - prog2_line = "(' Moving:|0 ',tr60,'100%|' )" - -end module ahestetic diff --git a/cenmass.f90 b/cenmass.f90 deleted file mode 100644 index 00bb730..0000000 --- a/cenmass.f90 +++ /dev/null @@ -1,103 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine cenmass -! -! Computes the center of mass of free molecules and -! for fixed molecules, if required. -! -subroutine cenmass() - - use sizes - use compute_data, only : ntype, coor, idfirst, natoms - use input, only : keyword, amass, nlines, linestrut - - implicit none - integer :: k, iline - integer :: itype, iatom, idatom - double precision, allocatable :: cm(:,:), totm(:) - logical, allocatable :: domass(:) - - ! Allocate local vectors - - allocate(cm(ntype,3),totm(ntype),domass(ntype)) - - ! Setting the molecules for which the center of mass is computed - - do itype = 1, ntype - domass(itype) = .true. - end do - - do iline = 1, nlines - if(keyword(iline,1).eq.'fixed') then - do itype = 1, ntype - if(iline.gt.linestrut(itype,1).and. & - iline.lt.linestrut(itype,2)) then - domass(itype) = .false. - end if - end do - end if - end do - - do iline = 1, nlines - if(keyword(iline,1).eq.'centerofmass'.or. & - keyword(iline,1).eq.'center') then - do itype = 1, ntype - if(iline.gt.linestrut(itype,1).and. & - iline.lt.linestrut(itype,2)) then - domass(itype) = .true. - end if - end do - end if - end do - - ! Computing the center of mass - - do itype = 1, ntype - do k = 1, 3 - cm(itype, k) = 0.d0 - end do - end do - - do itype = 1, ntype - totm(itype) = 0.d0 - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - totm(itype) = totm(itype) + amass(idatom) - end do - end do - - do itype = 1, ntype - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - do k = 1, 3 - cm(itype, k) = cm(itype, k) + coor(idatom, k)*amass(idatom) - end do - end do - do k = 1, 3 - cm(itype, k) = cm(itype, k) / totm(itype) - end do - end do - - ! Putting molecules in their center of mass - - do itype = 1, ntype - if(domass(itype)) then - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - do k = 1, 3 - coor(idatom, k) = coor(idatom, k) - cm(itype, k) - end do - end do - end if - end do - - deallocate(cm,totm,domass) - - return -end subroutine cenmass diff --git a/checkpoint.f90 b/checkpoint.f90 deleted file mode 100644 index a40b625..0000000 --- a/checkpoint.f90 +++ /dev/null @@ -1,116 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! - -! -! Subroutine that writes the last point obtained when -! a solution was not found -! - -subroutine checkpoint(n,x) - - use sizes - use compute_data - use input - use usegencan - use ahestetic - - implicit none - integer :: i - integer :: n - double precision :: x(n) - double precision :: fx - logical :: movebadprint - character(len=strl) :: xyzout_forced - - ! All molecules are important - - do i = 1, ntfix - comptype(i) = .true. - end do - - ! Call the subroutine that computes de function value - - call computef(n,x,fx) - - write(*,dash3_line) - write(*,"(& - &' Packmol was not able to find a solution to your',/,& - &' packing problem with the desired distance tolerance.',/,/,& - &' First of all, be sure if the molecules fit in the',/,& - &' regions specified and if the constraints were set',/,& - &' correctly. ',/,/,& - &' Secondly, try simply running it again with a different ',/,& - &' seed for the random number generator of the initial ',/,& - &' point. This is done by adding the keyword seed to the',/,& - &' input file, as in: ',/,/,& - &' seed 192911 ',/,/,& - &' The best configuration found has a function value of',/,& - &' f = ', e14.7,/,/,& - &' IMPORTANT: ',/,& - &' If the number of molecules and the restraints are',/,& - &' correct, it is still very likely that the current point',/,& - &' fits your needs if your purpose is to run a MD',/,& - &' simulation.',/,& - &' Therefore, we recommend to minimize the energy of the',/,& - &' solution found, equilibrate it and run with it as well.',/& - &)") fx - write(*,dash3_line) - - call output(n,x) - - write(*,*) ' The solution with the best function value was ' - write(*,*) ' written to the output file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - write(*,dash1_line) - write(*,*) ' Forcing the solution to fit the constraints...' - - ! CALL GENCAN - - init1 = .true. - do i = 1, nloop - iprint1 = 0 - iprint2 = 0 - call pgencan(n,x,fx) - movebadprint = .false. - call movebad(n,x,fx,movebadprint) - end do - init1 = .false. - - write(*,*) - write(*,dash1_line) - xyzout_forced = trim(adjustl(xyzout))//'_FORCED' - call output(n,x) - - write(*,*) ' The forced point was writen to the ' - write(*,*) ' output file: ', trim(adjustl(xyzout_forced)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - write(*,*) - write(*,*) ' If you want that the packing procedure continues' - write(*,*) ' for a longer time, add the following keyword ' - write(*,*) ' to the input file: ' - write(*,*) - write(*,*) ' nloop [integer] (ex: nloop 200) ' - write(*,*) - write(*,*) ' The default nloop value is 50 for each molecule.' - write(*,*) - - write(*,hash1_line) - write(*,*) ' ENDED WITHOUT PERFECT PACKING: ' - write(*,*) ' The output file:' - write(*,*) - write(*,*) ' ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' (... and to CRD file: ', trim(adjustl(crdfile)), ')' - write(*,*) - write(*,*) ' contains the best solution found. ' - write(*,*) - write(*,*) ' Very likely, if the input data was correct, ' - write(*,*) ' it is a reasonable starting configuration.' - write(*,*) ' Check commentaries above for more details. ' - write(*,hash1_line) - - return -end subroutine checkpoint - diff --git a/comparegrad.f90 b/comparegrad.f90 deleted file mode 100644 index 19c6fdb..0000000 --- a/comparegrad.f90 +++ /dev/null @@ -1,98 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! - -! -! Subroutine that performs finite difference and analytical gradient -! comparision. Used only for test purpouses -! - -subroutine comparegrad(n,x) - - use sizes - implicit none - - integer :: n, i, iworst - double precision :: x(n), fx, step, gcomp, gbest, eworst, & - error, steperror, stepbest - double precision, allocatable :: g(:) - real :: time0, tarray(2), etime - - ! Allocate local array - - allocate(g(nn)) - - write(*,*) - write(*,*) ' Comparing analytical and finite-difference ' - write(*,*) ' gradients... may take a while. ' - write(*,*) - write(*,*) ' Five first center of masses and angles of tested point: ' - do i = 1, 15, 3 - write(*,"( i4,6(tr2,f8.3) )") (i+2)/3, x(i), x(i+1), x(i+2), x(n/2+i),& - x(n/2+i+1),x(n/2+i+2) - end do - write(*,*) - write(*,*) ' Computing gradient ... ' - - call computef(n,x,fx) - write(*,*) ' Function value on test point: ', fx - open(98, file = 'chkgrad.log',status='unknown') - write(98, *)'Function Value = ', fx - call computeg(n,x,g) - - write(98,"( t2,'Component',t16,'Analytical',t33,'Discrete', & - &t51,'Error',t62,'Best step' )") - time0 = etime(tarray) - eworst = 0.d0 - do i = 1, n - if(etime(tarray)-time0.gt.10.) then - time0 = etime(tarray) - write(*,*) ' Computing the ',i,'th of ',n,' components. Worst error: ', eworst - end if - error = 1.d20 - step = 1.d-2 - do while(error.gt.1.d-6.and.step.ge.1.d-20) - call discret(i,n,x,gcomp,step) - if(dmin1(abs(g(i)),abs(gcomp)).gt.1.d-10) then - steperror = abs( ( gcomp - g(i) ) / g(i) ) - else - steperror = abs( gcomp - g(i) ) - end if - if( steperror .lt. error ) then - error = steperror - gbest = gcomp - stepbest = step - end if - step = step / 10.d0 - end do - write(98,"(i10,5(tr2,d13.7))") i, g(i), gbest, error, stepbest - if(error.gt.eworst) then - iworst = i - eworst = error - end if - end do - write(98,*) 'Maximum difference = ', iworst,' Error= ', eworst - write(*,*) ' Done. ' - stop - -end subroutine comparegrad - -subroutine discret(icomp,n,x,gcomp,step) - - implicit none - integer :: n, icomp - double precision :: save, step, x(n), fplus, fminus, gcomp - - save = x(icomp) - x(icomp) = save + step - call computef(n,x,fplus) - x(icomp) = save - step - call computef(n,x,fminus) - gcomp = (fplus - fminus) / (2.d0 * step) - x(icomp) = save - - return -end subroutine discret - diff --git a/comprest.f90 b/comprest.f90 deleted file mode 100644 index 72addb3..0000000 --- a/comprest.f90 +++ /dev/null @@ -1,168 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! -! Subroutine comprest: Compute the function value relative to -! to the restrictions for one atom -! - -subroutine comprest(icart,f) - - use sizes - use compute_data, only : xcart, restpars, scale, scale2, nratom, ityperest, iratom - - implicit none - integer :: iratcount, irest, icart - double precision :: xmin, ymin, zmin, clength, a1, a2, a3, a4, w, b1, b2, b3, d, a5, a6 - double precision :: f - double precision :: xmax, ymax, zmax - double precision :: v1, v2, v3 - double precision :: vnorm - - f = 0.d0 - do iratcount = 1, nratom(icart) - irest = iratom(icart,iratcount) - if(ityperest(irest).eq.2) then - clength = restpars(irest,4) - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,1) + clength - ymax = restpars(irest,2) + clength - zmax = restpars(irest,3) + clength - a1 = dmin1(xcart(icart,1) - xmin, 0.d0) - a2 = dmin1(xcart(icart,2) - ymin, 0.d0) - a3 = dmin1(xcart(icart,3) - zmin, 0.d0) - f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) - a1 = dmax1(xcart(icart,1) - xmax, 0.d0) - a2 = dmax1(xcart(icart,2) - ymax, 0.d0) - a3 = dmax1(xcart(icart,3) - zmax, 0.d0) - f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) - else if(ityperest(irest).eq.3) then - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,4) - ymax = restpars(irest,5) - zmax = restpars(irest,6) - a1 = dmin1(xcart(icart,1) - xmin, 0.d0) - a2 = dmin1(xcart(icart,2) - ymin, 0.d0) - a3 = dmin1(xcart(icart,3) - zmin, 0.d0) - f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) - a1 = dmax1(xcart(icart,1) - xmax, 0.d0) - a2 = dmax1(xcart(icart,2) - ymax, 0.d0) - a3 = dmax1(xcart(icart,3) - zmax, 0.d0) - f = f + scale*(a1 * a1 + a2 * a2 + a3 * a3) - else if(ityperest(irest).eq.4) then - w = (xcart(icart,1)-restpars(irest,1))**2 + & - (xcart(icart,2)-restpars(irest,2))**2 + & - (xcart(icart,3)-restpars(irest,3))**2 - & - restpars(irest,4)**2 - a1 = dmax1(w,0.d0) - f = f + scale2*a1*a1 - else if(ityperest(irest).eq.5) then - a1 = (xcart(icart,1)-restpars(irest,1))**2 / restpars(irest,4)**2 - a2 = (xcart(icart,2)-restpars(irest,2))**2 / restpars(irest,5)**2 - a3 = (xcart(icart,3)-restpars(irest,3))**2 / restpars(irest,6)**2 - a4 = restpars(irest,7)**2 - w = a1 + a2 + a3 - a4 - a1 = dmax1(w,0.d0) - f = f + scale2*a1*a1 - else if(ityperest(irest).eq.6) then - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,1) + restpars(irest,4) - ymax = restpars(irest,2) + restpars(irest,4) - zmax = restpars(irest,3) + restpars(irest,4) - a1 = dmax1(xcart(icart,1) - xmin,0.d0) - a2 = dmax1(xcart(icart,2) - ymin,0.d0) - a3 = dmax1(xcart(icart,3) - zmin,0.d0) - a4 = dmax1(xmax - xcart(icart,1),0.d0) - a5 = dmax1(ymax - xcart(icart,2),0.d0) - a6 = dmax1(zmax - xcart(icart,3),0.d0) - f = f + a1*a2*a3*a4*a5*a6 - else if(ityperest(irest).eq.7) then - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,4) - ymax = restpars(irest,5) - zmax = restpars(irest,6) - a1 = dmax1(xcart(icart,1) - xmin,0.d0) - a2 = dmax1(xcart(icart,2) - ymin,0.d0) - a3 = dmax1(xcart(icart,3) - zmin,0.d0) - a4 = dmax1(xmax - xcart(icart,1),0.d0) - a5 = dmax1(ymax - xcart(icart,2),0.d0) - a6 = dmax1(zmax - xcart(icart,3),0.d0) - f = f + a1*a2*a3*a4*a5*a6 - else if(ityperest(irest).eq.8) then - w = (xcart(icart,1)-restpars(irest,1))**2 + & - (xcart(icart,2)-restpars(irest,2))**2 + & - (xcart(icart,3)-restpars(irest,3))**2 - & - restpars(irest,4)**2 - a1 = dmin1(w,0.d0) - f = f + scale2*a1*a1 - else if(ityperest(irest).eq.9) then - a1 = (xcart(icart,1)-restpars(irest,1))**2 / restpars(irest,4)**2 - a2 = (xcart(icart,2)-restpars(irest,2))**2 / restpars(irest,5)**2 - a3 = (xcart(icart,3)-restpars(irest,3))**2 / restpars(irest,6)**2 - a4 = restpars(irest,7)**2 - w = a1 + a2 + a3 - a4 - a1 = dmin1(w,0.d0) - f = f + a1*a1 - else if(ityperest(irest).eq.10) then - w = restpars(irest,1)*xcart(icart,1) + & - restpars(irest,2)*xcart(icart,2) + & - restpars(irest,3)*xcart(icart,3) - & - restpars(irest,4) - a1 = dmin1(w,0.d0) - f = f + scale * a1*a1 - else if(ityperest(irest).eq.11) then - w = restpars(irest,1)*xcart(icart,1) + & - restpars(irest,2)*xcart(icart,2) + & - restpars(irest,3)*xcart(icart,3) - & - restpars(irest,4) - a1 = dmax1(w,0.d0) - f = f + scale * a1*a1 - else if(ityperest(irest).eq.12) then - a1 = xcart(icart,1) - restpars(irest,1) - a2 = xcart(icart,2) - restpars(irest,2) - a3 = xcart(icart,3) - restpars(irest,3) - vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 + restpars(irest,6)**2) - v1 = restpars(irest,4)/vnorm - v2 = restpars(irest,5)/vnorm - v3 = restpars(irest,6)/vnorm - b1 = v1 * a1 - b2 = v2 * a2 - b3 = v3 * a3 - w = b1 + b2 + b3 - d = ( a1 - v1*w )**2 + ( a2 - v2*w )**2 + ( a3 - v3*w )**2 - f = f + scale2 * ( & - dmax1(-w , 0.d0)**2 + & - dmax1(w - restpars(irest,9), 0.d0)**2 + & - dmax1(d - restpars(irest,7)**2 , 0.d0 )**2 ) - else if(ityperest(irest).eq.13) then - a1 = xcart(icart,1) - restpars(irest,1) - a2 = xcart(icart,2) - restpars(irest,2) - a3 = xcart(icart,3) - restpars(irest,3) - vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 + restpars(irest,6)**2) - v1 = restpars(irest,4)/vnorm - v2 = restpars(irest,5)/vnorm - v3 = restpars(irest,6)/vnorm - b1 = v1 * a1 - b2 = v2 * a2 - b3 = v3 * a3 - w = b1 + b2 + b3 - d = ( a1 - v1*w )**2 +( a2 - v2*w )**2 + ( a3 - v3*w )**2 - f = f + scale2 * ( & - dmin1(-w , 0.d0)**2 * & - dmin1(w - restpars(irest,9), 0.d0)**2 * & - dmin1(d - restpars(irest,7)**2 , 0.d0 )**2 ) - end if - end do - return -end subroutine comprest - diff --git a/compute_data.f90 b/compute_data.f90 deleted file mode 100644 index 655dc63..0000000 --- a/compute_data.f90 +++ /dev/null @@ -1,63 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -module compute_data - - use sizes - - integer :: ntotmol, ntype, natfix, ntotat - integer :: nboxes(3), nb2(3) - - integer, allocatable :: nmols(:) ! (ntype) - integer, allocatable :: natoms(:) ! (ntype) - integer, allocatable :: idfirst(:) ! (ntype) - integer, allocatable :: nratom(:) ! (ntotat) - integer, allocatable :: iratom(:,:) ! (ntotat,mrperatom) - integer, allocatable :: ityperest(:) ! (maxrest) - integer, allocatable :: ibmol(:) ! (ntotat) - integer, allocatable :: ibtype(:) ! (ntotat) - - double precision :: scale, scale2 - double precision :: fdist, frest - double precision :: sizemin(3), sizemax(3) - double precision :: boxl(3) - - double precision, allocatable :: xcart(:,:) ! (ntotat,3) - double precision, allocatable :: coor(:,:) ! (ntotat,3) - double precision, allocatable :: restpars(:,:) ! (maxrest,9) - double precision, allocatable :: rot_bound(:,:,:) ! (ntype,3,2) - double precision, allocatable :: radius(:), radius_ini(:), fscale(:) ! (ntotat) - double precision, allocatable :: short_radius(:), short_radius_scale(:) ! ntotat - double precision, allocatable :: gxcar(:,:) ! (ntotat,3) - - double precision, allocatable :: fdist_atom(:), frest_atom(:) ! (ntotat) - double precision, allocatable :: dmax(:) ! (ntype) - double precision, allocatable :: cmxmin(:), cmymin(:), cmzmin(:) ! (ntype) - double precision, allocatable :: cmxmax(:), cmymax(:), cmzmax(:) ! (ntype) - - logical, allocatable :: constrain_rot(:,:) ! (ntype,3) - logical, allocatable :: comptype(:) ! (ntype) - logical, allocatable :: fixedatom(:) ! (ntotat) - logical, allocatable :: use_short_radius(:) ! ntotat - logical :: init1, move - - ! For linked lists - integer, allocatable :: latomnext(:) ! (ntotat) - integer, allocatable :: latomfirst(:,:,:) ! (0:nbp+1,0:nbp+1,0:nbp+1) - integer, allocatable :: latomfix(:,:,:) ! (0:nbp+1,0:nbp+1,0:nbp+1) - - ! For movebad - double precision, allocatable :: fmol(:), radiuswork(:) ! (ntotat) - - ! For restmol - double precision, allocatable :: xmol(:) ! (nn) - logical, allocatable :: compsafe(:) ! (ntype) - - ! For boxes with atoms linked lists - integer :: lboxfirst - integer, allocatable :: lboxnext(:) ! ((nbp+2)**3) - logical, allocatable :: hasfree(:,:,:) ! (0:nbp+1,0:nbp+1,0:nbp+1) - -end module compute_data diff --git a/computef.f90 b/computef.f90 deleted file mode 100644 index e01890b..0000000 --- a/computef.f90 +++ /dev/null @@ -1,220 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine that computes the function value -! - -subroutine computef(n,x,f) - - use sizes - use compute_data - use input, only : fix - implicit none - - integer :: n, i, j, k, ibox - integer :: ilugan, ilubar, icart, itype, imol, iatom, idatom, & - iboxx, iboxy, iboxz - - double precision :: v1(3), v2(3), v3(3) - double precision :: x(n) - double precision :: f,fparc,fplus - double precision :: xtemp, ytemp, ztemp - double precision :: xbar, ybar, zbar - double precision :: beta, gama, teta - - ! Reset function value - - f = 0.d0 - frest = 0.d0 - fdist = 0.d0 - - ! Reset boxes - - if(.not.init1) call resetboxes() - - ! Transform baricenter and angles into cartesian coordinates - ! Computes cartesian coordinates from vector x and coor - - ilubar = 0 - ilugan = ntotmol*3 - icart = 0 - - do itype = 1, ntype - if(.not.comptype(itype)) then - icart = icart + nmols(itype)*natoms(itype) - else - do imol = 1, nmols(itype) - - xbar = x(ilubar+1) - ybar = x(ilubar+2) - zbar = x(ilubar+3) - - ! Computing the rotation matrix - - beta = x(ilugan+1) - gama = x(ilugan+2) - teta = x(ilugan+3) - - call eulerrmat(beta,gama,teta,v1,v2,v3) - - ! Looping over the atoms of this molecule - - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - - icart = icart + 1 - idatom = idatom + 1 - - ! Computing the cartesian coordinates for this atom - - call compcart(icart,xbar,ybar,zbar, & - coor(idatom,1),coor(idatom,2),coor(idatom,3), & - v1,v2,v3) - - ! Adding to f the value relative to constraints for this atom - - call comprest(icart,fplus) - f = f + fplus - frest = dmax1(frest,fplus) - if(move) frest_atom(icart) = frest_atom(icart) + fplus - - ! Putting atoms in their boxes - - if(.not.init1) then - - xtemp = xcart(icart,1) - sizemin(1) - ytemp = xcart(icart,2) - sizemin(2) - ztemp = xcart(icart,3) - sizemin(3) - - iboxx = int(xtemp/boxl(1)) + 1 - iboxy = int(ytemp/boxl(2)) + 1 - iboxz = int(ztemp/boxl(3)) + 1 - - if(xtemp.le.0) iboxx = 1 - if(ytemp.le.0) iboxy = 1 - if(ztemp.le.0) iboxz = 1 - if(iboxx.gt.nboxes(1)) iboxx = nboxes(1) - if(iboxy.gt.nboxes(2)) iboxy = nboxes(2) - if(iboxz.gt.nboxes(3)) iboxz = nboxes(3) - - ! Atom linked list - - latomnext(icart) = latomfirst(iboxx,iboxy,iboxz) - latomfirst(iboxx,iboxy,iboxz) = icart - - ! Box with atoms linked list - - if ( .not. hasfree(iboxx,iboxy,iboxz) ) then - hasfree(iboxx,iboxy,iboxz) = .true. - call ijk_to_ibox(iboxx,iboxy,iboxz,ibox) - lboxnext(ibox) = lboxfirst - lboxfirst = ibox - - ! Add boxes with fixed atoms which are vicinal to this box, and - ! are behind - - if ( fix ) then - - call add_box_behind(iboxx-1,iboxy,iboxz) - call add_box_behind(iboxx,iboxy-1,iboxz) - call add_box_behind(iboxx,iboxy,iboxz-1) - - call add_box_behind(iboxx,iboxy-1,iboxz+1) - call add_box_behind(iboxx,iboxy-1,iboxz-1) - call add_box_behind(iboxx-1,iboxy+1,iboxz) - call add_box_behind(iboxx-1,iboxy,iboxz+1) - call add_box_behind(iboxx-1,iboxy-1,iboxz) - call add_box_behind(iboxx-1,iboxy,iboxz-1) - - call add_box_behind(iboxx-1,iboxy+1,iboxz+1) - call add_box_behind(iboxx-1,iboxy+1,iboxz-1) - call add_box_behind(iboxx-1,iboxy-1,iboxz+1) - call add_box_behind(iboxx-1,iboxy-1,iboxz-1) - - end if - - end if - - ibtype(icart) = itype - ibmol(icart) = imol - - end if - - end do - - ilugan = ilugan + 3 - ilubar = ilubar + 3 - - end do - end if - end do - - if(init1) return - - ! Minimum distance function evaluation - - ibox = lboxfirst - do while( ibox > 0 ) - - call ibox_to_ijk(ibox,i,j,k) - - icart = latomfirst(i,j,k) - do while( icart > 0 ) - - if(comptype(ibtype(icart))) then - - ! Interactions inside box - - f = f + fparc(icart,latomnext(icart)) - - ! Interactions of boxes that share faces - - f = f + fparc(icart,latomfirst(i+1,j,k)) - f = f + fparc(icart,latomfirst(i,j+1,k)) - f = f + fparc(icart,latomfirst(i,j,k+1)) - - ! Interactions of boxes that share axes - - f = f + fparc(icart,latomfirst(i+1,j+1,k)) - f = f + fparc(icart,latomfirst(i+1,j,k+1)) - f = f + fparc(icart,latomfirst(i+1,j-1,k)) - f = f + fparc(icart,latomfirst(i+1,j,k-1)) - f = f + fparc(icart,latomfirst(i,j+1,k+1)) - f = f + fparc(icart,latomfirst(i,j+1,k-1)) - - ! Interactions of boxes that share vertices - - f = f + fparc(icart,latomfirst(i+1,j+1,k+1)) - f = f + fparc(icart,latomfirst(i+1,j+1,k-1)) - f = f + fparc(icart,latomfirst(i+1,j-1,k+1)) - f = f + fparc(icart,latomfirst(i+1,j-1,k-1)) - - end if - - icart = latomnext(icart) - end do - - ibox = lboxnext(ibox) - end do - - return -end subroutine computef - -subroutine add_box_behind(i,j,k) - - use sizes - use compute_data - implicit none - integer :: ibox, i, j, k - - if ( .not. hasfree(i,j,k) .and. latomfix(i,j,k) /= 0 ) then - hasfree(i,j,k) = .true. - call ijk_to_ibox(i,j,k,ibox) - lboxnext(ibox) = lboxfirst - lboxfirst = ibox - end if - -end subroutine add_box_behind - diff --git a/computeg.f90 b/computeg.f90 deleted file mode 100644 index 9139183..0000000 --- a/computeg.f90 +++ /dev/null @@ -1,309 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine that computes the analytical derivatives -! - -subroutine computeg(n,x,g) - - use sizes - use compute_data - use input, only : fix - implicit none - - integer :: n - integer :: idatom, iatom, irest - integer :: i, j, k, ilubar, ilugan, icart, itype, imol - integer :: ibox, iboxx, iboxy, iboxz - integer :: k1, k2 - integer :: iratcount - - double precision :: x(n), g(n) - double precision :: dv1beta(3), dv1gama(3), dv1teta(3),& - dv2beta(3), dv2gama(3), dv2teta(3),& - dv3beta(3), dv3gama(3), dv3teta(3) - double precision :: v1(3), v2(3), v3(3) - double precision :: xbar, ybar, zbar - double precision :: xtemp, ytemp, ztemp - double precision :: beta, gama, teta, cb, sb, cg, sg, ct, st - - ! Reset gradients - - do i = 1, ntotat - do j = 1, 3 - gxcar(i,j) = 0.d0 - end do - end do - - ! Reset boxes - - if(.not.init1) call resetboxes() - - ! Transform baricenter and angles into cartesian coordinates - - ! Computes cartesian coordinates from vector x and coor - - ilubar = 0 - ilugan = ntotmol*3 - icart = 0 - - do itype = 1, ntype - - if(.not.comptype(itype)) then - icart = icart + nmols(itype)*natoms(itype) - else - do imol = 1, nmols(itype) - - xbar = x(ilubar + 1) - ybar = x(ilubar + 2) - zbar = x(ilubar + 3) - - ! Compute the rotation matrix - - beta = x(ilugan + 1) - gama = x(ilugan + 2) - teta = x(ilugan + 3) - - call eulerrmat(beta,gama,teta,v1,v2,v3) - - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - - icart = icart + 1 - idatom = idatom + 1 - - call compcart(icart,xbar,ybar,zbar, & - coor(idatom,1),coor(idatom,2),coor(idatom,3), & - v1,v2,v3) - - ! Gradient relative to the wall distace - - do iratcount = 1, nratom(icart) - irest = iratom(icart,iratcount) - call gwalls(icart,irest) - end do - - if(.not.init1) then - xtemp = xcart(icart,1) - sizemin(1) - ytemp = xcart(icart,2) - sizemin(2) - ztemp = xcart(icart,3) - sizemin(3) - - iboxx = int(xtemp/boxl(1)) + 1 - iboxy = int(ytemp/boxl(2)) + 1 - iboxz = int(ztemp/boxl(3)) + 1 - - if(xtemp.le.0) iboxx = 1 - if(ytemp.le.0) iboxy = 1 - if(ztemp.le.0) iboxz = 1 - if(iboxx.gt.nboxes(1)) iboxx = nboxes(1) - if(iboxy.gt.nboxes(2)) iboxy = nboxes(2) - if(iboxz.gt.nboxes(3)) iboxz = nboxes(3) - - ! Atom linked list - - latomnext(icart) = latomfirst(iboxx,iboxy,iboxz) - latomfirst(iboxx,iboxy,iboxz) = icart - - ! Box with atoms linked list - - if ( .not. hasfree(iboxx,iboxy,iboxz) ) then - hasfree(iboxx,iboxy,iboxz) = .true. - call ijk_to_ibox(iboxx,iboxy,iboxz,ibox) - lboxnext(ibox) = lboxfirst - lboxfirst = ibox - - ! Add boxes with fixed atoms which are vicinal to this box, and - ! are behind - - if ( fix ) then - - call add_box_behind(iboxx-1,iboxy,iboxz) - call add_box_behind(iboxx,iboxy-1,iboxz) - call add_box_behind(iboxx,iboxy,iboxz-1) - - call add_box_behind(iboxx,iboxy-1,iboxz+1) - call add_box_behind(iboxx,iboxy-1,iboxz-1) - call add_box_behind(iboxx-1,iboxy+1,iboxz) - call add_box_behind(iboxx-1,iboxy,iboxz+1) - call add_box_behind(iboxx-1,iboxy-1,iboxz) - call add_box_behind(iboxx-1,iboxy,iboxz-1) - - call add_box_behind(iboxx-1,iboxy+1,iboxz+1) - call add_box_behind(iboxx-1,iboxy+1,iboxz-1) - call add_box_behind(iboxx-1,iboxy-1,iboxz+1) - call add_box_behind(iboxx-1,iboxy-1,iboxz-1) - - end if - - end if - - ibtype(icart) = itype - ibmol(icart) = imol - end if - - end do - ilugan = ilugan + 3 - ilubar = ilubar + 3 - end do - end if - end do - - if( .not. init1 ) then - - ! - ! Gradient relative to minimum distance - ! - - ibox = lboxfirst - do while( ibox > 0 ) - - call ibox_to_ijk(ibox,i,j,k) - - icart = latomfirst(i,j,k) - do while ( icart .ne. 0 ) - - if(comptype(ibtype(icart))) then - - ! Interactions inside box - - call gparc(icart,latomnext(icart)) - - ! Interactions of boxes that share faces - - call gparc(icart,latomfirst(i+1,j,k)) - call gparc(icart,latomfirst(i,j+1,k)) - call gparc(icart,latomfirst(i,j,k+1)) - - ! Interactions of boxes that share axes - - call gparc(icart,latomfirst(i+1,j+1,k)) - call gparc(icart,latomfirst(i+1,j,k+1)) - call gparc(icart,latomfirst(i+1,j-1,k)) - call gparc(icart,latomfirst(i+1,j,k-1)) - call gparc(icart,latomfirst(i,j+1,k+1)) - call gparc(icart,latomfirst(i,j+1,k-1)) - - ! Interactions of boxes that share vertices - - call gparc(icart,latomfirst(i+1,j+1,k+1)) - call gparc(icart,latomfirst(i+1,j+1,k-1)) - call gparc(icart,latomfirst(i+1,j-1,k+1)) - call gparc(icart,latomfirst(i+1,j-1,k-1)) - - end if - - icart = latomnext(icart) - end do - - ibox = lboxnext(ibox) - end do - - end if - - ! Computing the gradient using chain rule - - do i = 1, n - g(i) = 0.d0 - end do - - k1 = 0 - k2 = ntotmol * 3 - - icart = 0 - do itype = 1, ntype - - if(.not.comptype(itype)) then - icart = icart + nmols(itype)*natoms(itype) - else - do imol = 1, nmols(itype) - - beta = x(k2 + 1) - gama = x(k2 + 2) - teta = x(k2 + 3) - - cb = dcos(beta) - sb = dsin(beta) - cg = dcos(gama) - sg = dsin(gama) - ct = dcos(teta) - st = dsin(teta) - - dv1beta(1) = - cb * sg * ct - sb * cg - dv2beta(1) = - sb * sg * ct + cb * cg - dv3beta(1) = 0.d0 - - dv1gama(1) = - sb * cg * ct - cb * sg - dv2gama(1) = cb * cg * ct - sb * sg - dv3gama(1) = cg * st - - dv1teta(1) = sb * sg * st - dv2teta(1) = - cb * sg * st - dv3teta(1) = sg * ct - - dv1beta(2) = - cb * cg * ct + sb * sg - dv2beta(2) = - sb * cg * ct - cb * sg - dv3beta(2) = 0.d0 - - dv1gama(2) = sb * sg * ct - cb * cg - dv2gama(2) = - sg * cb * ct - cg * sb - dv3gama(2) = - sg * st - - dv1teta(2) = sb * cg * st - dv2teta(2) = - cb * cg * st - - dv3teta(2) = cg * ct - - dv1beta(3) = cb * st - dv2beta(3) = sb * st - dv3beta(3) = 0.d0 - - dv1gama(3) = 0.d0 - dv2gama(3) = 0.d0 - dv3gama(3) = 0.d0 - - dv1teta(3) = sb * ct - dv2teta(3) = - cb * ct - dv3teta(3) = - st - - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - - icart = icart + 1 - idatom = idatom + 1 - - do k = 1, 3 - g(k1+k) = g(k1+k) + gxcar(icart, k) - end do - - do k = 1, 3 - g(k2 + 1) = g(k2 + 1) & - + (coor(idatom,1) * dv1beta(k) & - + coor(idatom, 2) * dv2beta(k) & - + coor(idatom, 3) * dv3beta(k)) & - * gxcar(icart, k) - - g(k2 + 2) = g(k2 + 2) & - + (coor(idatom,1) * dv1gama(k) & - + coor(idatom, 2) * dv2gama(k) & - + coor(idatom, 3) * dv3gama(k)) & - * gxcar(icart, k) - - g(k2 + 3) = g(k2 + 3) & - + (coor(idatom,1) * dv1teta(k) & - + coor(idatom, 2) * dv2teta(k) & - + coor(idatom, 3) * dv3teta(k)) & - * gxcar(icart, k) - end do - - end do - k2 = k2 + 3 - k1 = k1 + 3 - end do - end if - end do - - return -end subroutine computeg - diff --git a/data_types.f90 b/data_types.f90 deleted file mode 100644 index 9c5eb19..0000000 --- a/data_types.f90 +++ /dev/null @@ -1,10 +0,0 @@ - -type input_file - - use sizes - logical :: tinker, pdb, xyz, moldy - integer :: nlines - character(len=strl), allocatable :: line(:) - character(len=strl), allocatable :: keyword(:,:) - -end type input_file diff --git a/exit_codes.f90 b/exit_codes.f90 deleted file mode 100644 index 29114d5..0000000 --- a/exit_codes.f90 +++ /dev/null @@ -1,18 +0,0 @@ -! -! Written by Alexandr Fonari, 2022. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! - -module exit_codes - - IMPLICIT NONE - - ! Codes 1, 2, 126 – 165 and 255 have special meaning - integer, parameter :: exit_code_success = 0 - integer, parameter :: exit_code_general_error = 170 - integer, parameter :: exit_code_input_error = 171 - integer, parameter :: exit_code_open_file = 172 - integer, parameter :: exit_code_failed_to_converge = 173 - -end module exit_codes diff --git a/flashmod.f90 b/flashmod.f90 deleted file mode 100644 index 84aaa74..0000000 --- a/flashmod.f90 +++ /dev/null @@ -1,21 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! - -! -! Arrays required by the flashsort package. Used only in heuristics, but -! defined here to be allocated dynamically -! - -module flashsort - - use sizes - implicit none - integer, allocatable :: indflash(:) ! (ntotat) - integer, allocatable :: lflash(:) ! (ntotat) - integer :: mflash - -end module flashsort - diff --git a/flashsort.f90 b/flashsort.f90 deleted file mode 100644 index 0112e3c..0000000 --- a/flashsort.f90 +++ /dev/null @@ -1,95 +0,0 @@ -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! c -! Subroutine Flash1 c -! SORTS ARRAY A WITH N ELEMENTS BY USE OF INDEX VECTOR L c -! OF DIMENSION M WITH M ABOUT 0.1 N. c -! Karl-Dietrich Neubert, FlashSort1 Algorithm c -! in Dr. Dobb's Journal Feb.1998,p.123 c -! c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - subroutine flash1 (A, N, L, M, ind) - - implicit none - double precision :: a(*), anmin, c1, hold, flash - integer :: L(*), ind(*), i, n, nmax, m, k, ihold, nmove, j, iflash -! ============================ CLASS FORMATION ===== - - - do i = 1, n - ind(i) = i - end do - - ANMIN=A(1) - NMAX=1 - DO I=1,N - IF( A(I).LT.ANMIN) ANMIN=A(I) - IF( A(I).GT.A(NMAX)) NMAX=I - END DO - - IF (ANMIN.EQ.A(NMAX)) RETURN - C1=(M - 1) / (A(NMAX) - ANMIN) - DO K=1,M - L(K)=0 - END DO - DO I=1,N - K=1 + INT(C1 * (A(I) - ANMIN)) - L(K)=L(K) + 1 - END DO - DO K=2,M - L(K)=L(K) + L(K - 1) - END DO - HOLD=A(NMAX) - A(NMAX)=A(1) - A(1)=HOLD - - ihold = ind(nmax) - ind(nmax) = ind(1) - ind(1) = ihold - - -! =============================== PERMUTATION ===== - NMOVE=0 - J=1 - K=M - DO WHILE (NMOVE.LT.N - 1) - DO WHILE (J.GT.L(K)) - J=J + 1 - K=1 + INT(C1 * (A(J) - ANMIN)) - END DO - FLASH=A(J) - iflash=ind(j) - - DO WHILE (.NOT.(J.EQ.L(K) + 1)) - K=1 + INT(C1 * (FLASH - ANMIN)) - HOLD=A(L(K)) - ihold = ind(L(k)) - A(L(K))=FLASH - ind(L(k)) = iflash - iflash = ihold - FLASH=HOLD - L(K)=L(K) - 1 - NMOVE=NMOVE + 1 - END DO - END DO - -! ========================= STRAIGHT INSERTION ===== - DO I=N-2,1,-1 - IF (A(I + 1).LT.A(I)) THEN - HOLD=A(I) - ihold = ind(i) - J=I - DO WHILE (A(J + 1).LT.HOLD) - A(J)=A(J + 1) - ind(j) = ind(j+1) - J=J + 1 - END DO - A(J)=HOLD - ind(j) = ihold - ENDIF - END DO - -! =========================== RETURN,END FLASH1 ===== - RETURN - END - diff --git a/fparc.f90 b/fparc.f90 deleted file mode 100644 index 2b876c3..0000000 --- a/fparc.f90 +++ /dev/null @@ -1,77 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Function that computes the atom-to-atom component of the objective -! function -! - -double precision function fparc(icart,firstjcart) - - use sizes - use compute_data - implicit none - - ! SCALAR ARGUMENTS - integer :: icart,firstjcart - - ! LOCAL SCALARS - integer :: jcart - double precision :: datom, tol, short_tol, short_tol_penalty, short_tol_scale - - fparc = 0.0d0 - jcart = firstjcart - do while ( jcart > 0 ) - ! - ! Cycle if this type is not to be computed - ! - if ( .not. comptype(ibtype(jcart))) then - jcart = latomnext(jcart) - cycle - end if - ! - ! Cycle if the atoms are from the same molecule - ! - if ( ibmol(icart) == ibmol(jcart) .and. & - ibtype(icart) == ibtype(jcart) ) then - jcart = latomnext(jcart) - cycle - end if - ! - ! Cycle if both atoms are from fixed molecules - ! - if ( fixedatom(icart) .and. fixedatom(jcart) ) then - jcart = latomnext(jcart) - cycle - end if - ! - ! Otherwise, compute distance and evaluate function for this pair - ! - datom = ( xcart(icart,1)-xcart(jcart,1) )**2 + & - ( xcart(icart,2)-xcart(jcart,2) )**2 + & - ( xcart(icart,3)-xcart(jcart,3) )**2 - tol = (radius(icart)+radius(jcart))**2 - if ( datom < tol ) then - fparc = fparc + fscale(icart)*fscale(jcart)*(datom-tol)**2 - if ( use_short_radius(icart) .or. use_short_radius(jcart) ) then - short_tol = (short_radius(icart)+short_radius(jcart))**2 - if ( datom < short_tol ) then - short_tol_penalty = datom-short_tol - short_tol_scale = dsqrt(short_radius_scale(icart)*short_radius_scale(jcart)) - short_tol_scale = short_tol_scale*(tol**2/short_tol**2) - fparc = fparc + fscale(icart)*fscale(jcart)*short_tol_scale*short_tol_penalty**2 - end if - end if - end if - tol = (radius_ini(icart)+radius_ini(jcart))**2 - fdist = dmax1(tol-datom,fdist) - if ( move ) then - fdist_atom(icart) = dmax1(tol-datom,fdist_atom(icart)) - fdist_atom(jcart) = dmax1(tol-datom,fdist_atom(jcart)) - end if - jcart = latomnext(jcart) - end do - -end function fparc - diff --git a/getinp.f90 b/getinp.f90 deleted file mode 100644 index 0873376..0000000 --- a/getinp.f90 +++ /dev/null @@ -1,1115 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine getinp: subroutine that reads the input file -! - -subroutine getinp() - - use exit_codes - use sizes - use compute_data, only : ntype, natoms, idfirst, nmols, ityperest, coor, restpars - use input - use usegencan - - implicit none - integer :: i, k, ii, iarg, iline, idatom, iatom, in, lixo, irest, itype, itest,& - imark, ioerr, nloop0, iread, idfirstatom - double precision :: clen - character(len=strl) :: record, blank - logical :: inside_structure - - ! Clearing the blank character arrays - - do i = 1, strl - blank(i:i) = ' ' - end do - - ! Getting random seed and optional optimization parameters if set - - seed = 1234567 - randini = .false. - check = .false. - chkgrad = .false. - iprint1 = 2 - iprint2 = 2 - discale = 1.1d0 - writeout = 10 - maxit = 20 - nloop = 0 - nloop0 = 0 - movefrac = 0.05 - movebadrandom = .false. - precision = 1.d-2 - writebad = .false. - add_amber_ter = .false. - amber_ter_preserve = .false. - add_box_sides = .false. - add_sides_fix = 0.d0 - sidemax = 1000.d0 - ioerr = 0 - avoidoverlap = .true. - packall = .false. - use_short_tol = .false. - crd = .false. - - inside_structure = .false. - - do i = 1, nlines - - if ( keyword(i,1).eq.'structure') inside_structure = .true. - if ( keyword(i,1).eq.'end' .and. & - keyword(i,2).eq.'structure') inside_structure = .false. - - if(keyword(i,1).eq.'seed') then - read(keyword(i,2),*,iostat=ioerr) seed - if ( ioerr /= 0 ) exit - if ( seed == -1 ) call seed_from_time(seed) - else if(keyword(i,1).eq.'randominitialpoint') then - randini = .true. - else if(keyword(i,1).eq.'check') then - check = .true. - else if(keyword(i,1).eq.'writebad') then - writebad = .true. - else if(keyword(i,1).eq.'precision') then - read(keyword(i,2),*,iostat=ioerr) precision - if ( ioerr /= 0 ) exit - write(*,*) ' Optional precision set: ', precision - else if(keyword(i,1).eq.'movefrac') then - read(keyword(i,2),*,iostat=ioerr) movefrac - if ( ioerr /= 0 ) exit - write(*,*) ' Optional movefrac set: ', movefrac - else if(keyword(i,1).eq.'movebadrandom') then - movebadrandom = .true. - write(*,*) ' Will move randomly bad molecues (movebadrandom) ' - else if(keyword(i,1).eq.'chkgrad') then - chkgrad = .true. - else if(keyword(i,1).eq.'writeout') then - read(keyword(i,2),*,iostat=ioerr) writeout - if ( ioerr /= 0 ) exit - write(*,*) ' Output frequency: ', writeout - else if(keyword(i,1).eq.'maxit') then - read(keyword(i,2),*,iostat=ioerr) maxit - if ( ioerr /= 0 ) exit - write(*,*) ' User defined GENCAN number of iterations: ', maxit - else if(keyword(i,1).eq.'nloop') then - if( .not. inside_structure ) then - read(keyword(i,2),*,iostat=ioerr) nloop - if ( ioerr /= 0 ) exit - end if - else if(keyword(i,1).eq.'nloop0') then - if( .not. inside_structure ) then - read(keyword(i,2),*,iostat=ioerr) nloop0 - if ( ioerr /= 0 ) exit - end if - else if(keyword(i,1).eq.'discale') then - read(keyword(i,2),*,iostat=ioerr) discale - if ( ioerr /= 0 ) exit - write(*,*) ' Optional initial tolerance scale: ', discale - else if(keyword(i,1).eq.'sidemax') then - read(keyword(i,2),*,iostat=ioerr) sidemax - if ( ioerr /= 0 ) exit - write(*,*) ' User set maximum system dimensions: ', sidemax - else if(keyword(i,1).eq.'fbins') then - read(keyword(i,2),*,iostat=ioerr) fbins - if ( ioerr /= 0 ) exit - write(*,*) ' User set linked-cell bin parameter: ', fbins - else if(keyword(i,1).eq.'add_amber_ter') then - add_amber_ter = .true. - write(*,*) ' Will add the TER flag between molecules. ' - else if(keyword(i,1).eq.'amber_ter_preserve') then - amber_ter_preserve = .true. - write(*,*) ' TER flags for fixed molecules will be kept if found. ' - else if(keyword(i,1).eq.'avoid_overlap') then - if ( keyword(i,2).eq.'yes') then - avoidoverlap = .true. - write(*,*) ' Will avoid overlap to fixed molecules at initial point. ' - else - avoidoverlap = .false. - write(*,*) ' Will NOT avoid overlap to fixed molecules at initial point. ' - end if - else if(keyword(i,1).eq.'packall') then - packall = .true. - write(*,*) ' Will pack all molecule types from the beginning. ' - else if(keyword(i,1).eq.'use_short_tol') then - use_short_tol = .true. - write(*,*) ' Will use a short distance penalty for all atoms. ' - else if(keyword(i,1).eq.'writecrd') then - crd = .true. - write(*,*) ' Will write output also in CRD format ' - read(keyword(i,2),*,iostat=ioerr) crdfile - else if(keyword(i,1).eq.'add_box_sides') then - add_box_sides = .true. - write(*,*) ' Will print BOX SIDE informations. ' - read(keyword(i,2),*,iostat=ioerr) add_sides_fix - if ( ioerr /= 0 ) then - ioerr = 0 - cycle - end if - write(*,*) ' Will sum ', add_sides_fix,' to each side length on print' - else if(keyword(i,1).eq.'iprint1') then - read(keyword(i,2),*,iostat=ioerr) iprint1 - if ( ioerr /= 0 ) exit - write(*,*) ' Optional printvalue 1 set: ', iprint1 - else if(keyword(i,1).eq.'iprint2') then - read(keyword(i,2),*,iostat=ioerr) iprint2 - if ( ioerr /= 0 ) exit - write(*,*) ' Optional printvalue 2 set: ', iprint2 - else if( keyword(i,1) /= 'tolerance' .and. & - keyword(i,1) /= 'short_tol_dist' .and. & - keyword(i,1) /= 'short_tol_scale' .and. & - keyword(i,1) /= 'structure' .and. & - keyword(i,1) /= 'end' .and. & - keyword(i,1) /= 'atoms' .and. & - keyword(i,1) /= 'output' .and. & - keyword(i,1) /= 'filetype' .and. & - keyword(i,1) /= 'number' .and. & - keyword(i,1) /= 'inside' .and. & - keyword(i,1) /= 'outside' .and. & - keyword(i,1) /= 'fixed' .and. & - keyword(i,1) /= 'center' .and. & - keyword(i,1) /= 'centerofmass' .and. & - keyword(i,1) /= 'over' .and. & - keyword(i,1) /= 'above' .and. & - keyword(i,1) /= 'below' .and. & - keyword(i,1) /= 'constrain_rotation' .and. & - keyword(i,1) /= 'radius' .and. & - keyword(i,1) /= 'fscale' .and. & - keyword(i,1) /= 'short_radius' .and. & - keyword(i,1) /= 'short_radius_scale' .and. & - keyword(i,1) /= 'resnumbers' .and. & - keyword(i,1) /= 'connect' .and. & - keyword(i,1) /= 'changechains' .and. & - keyword(i,1) /= 'chain' .and. & - keyword(i,1) /= 'discale' .and. & - keyword(i,1) /= 'maxit' .and. & - keyword(i,1) /= 'movebadrandom' .and. & - keyword(i,1) /= 'maxmove' .and. & - keyword(i,1) /= 'add_amber_ter' .and. & - keyword(i,1) /= 'amber_ter_preserve' .and. & - keyword(i,1) /= 'sidemax' .and. & - keyword(i,1) /= 'seed' .and. & - keyword(i,1) /= 'randominitialpoint' .and. & - keyword(i,1) /= 'restart_from' .and. & - keyword(i,1) /= 'restart_to' .and. & - keyword(i,1) /= 'nloop' .and. & - keyword(i,1) /= 'nloop0' .and. & - keyword(i,1) /= 'writeout' .and. & - keyword(i,1) /= 'writebad' .and. & - keyword(i,1) /= 'check' .and. & - keyword(i,1) /= 'iprint1' .and. & - keyword(i,1) /= 'iprint2' .and. & - keyword(i,1) /= 'writecrd' .and. & - keyword(i,1) /= 'segid' .and. & - keyword(i,1) /= 'chkgrad' ) then - write(*,*) ' ERROR: Keyword not recognized: ', trim(keyword(i,1)) - stop exit_code_input_error - end if - end do - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Some optional keyword was not used correctly: ', trim(keyword(i,1)) - stop exit_code_input_error - end if - write(*,*) ' Seed for random number generator: ', seed - call init_random_number(seed) - - ! Checking for the name of the output file to be created - - xyzout = '####' - do iline = 1, nlines - if(keyword(iline,1).eq.'output') then - xyzout = keyword(iline,2) - xyzout = trim(adjustl(xyzout)) - end if - end do - if(xyzout(1:4) == '####') then - write(*,*)' ERROR: Output file not (correctly?) specified. ' - stop exit_code_input_error - end if - write(*,*)' Output file: ', trim(adjustl(xyzout)) - - ! Reading structure files - - itype = 0 - do iline = 1, nlines - if(keyword(iline,1).eq.'structure') then - itype = itype + 1 - - record = keyword(iline,2) - write(*,*) ' Reading coordinate file: ', trim(adjustl(record)) - - ! Reading pdb input files - - if(pdb) then - name(itype) = trim(adjustl(record)) - record = keyword(iline,2) - pdbfile(itype) = trim(record) - idfirst(itype) = 1 - idfirstatom = 0 - do ii = itype - 1, 1, -1 - idfirst(itype) = idfirst(itype) + natoms(ii) - end do - open(10,file=keyword(iline,2),status='old',iostat=ioerr) - if ( ioerr /= 0 ) call failopen(keyword(iline,2)) - ! Read coordinates - record(1:6) = '######' - do while(record(1:4).ne.'ATOM'.and.record(1:6).ne.'HETATM') - read(10,str_format) record - end do - idatom = idfirst(itype) - 1 - do while(idatom.lt.natoms(itype)+idfirst(itype)-1) - if(record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM') then - idatom = idatom + 1 - amass(idatom) = 1.d0 - maxcon(idatom) = 0 - ! Read the index of the first atom, to adjust connectivities, if any - if(idfirstatom == 0) read(record(7:11),*,iostat=ioerr) idfirstatom - read(record,"( t31,f8.3,t39,f8.3,t47,f8.3 )",iostat=ioerr) & - (coor(idatom,k),k=1,3) - if( ioerr /= 0 ) then - record = keyword(iline,2) - write(*,*) ' ERROR: Failed to read coordinates from', & - ' file: ', trim(adjustl(record)) - write(*,*) ' Probably the coordinates are not in', & - ' standard PDB file format. ' - write(*,*) ' Standard PDB format specifications', & - ' can be found at: ' - write(*,*) ' www.rcsb.org/pdb ' - stop exit_code_input_error - end if - - ! This only tests if residue numbers can be read, they are used - ! only for output - read(record(23:26),*,iostat=ioerr) itest - if( ioerr /= 0 ) then - record = pdbfile(itype) - write(*,*) ' ERROR: Failed reading residue number',& - ' from PDB file: ', trim(adjustl(record)) - write(*,*) ' Residue numbers are integers that',& - ' must be within columns 23 and 26. ' - write(*,*) ' Other characters within these columns',& - ' will cause input/output errors. ' - write(*,*) ' Standard PDB format specifications',& - ' can be found at: ' - write(*,*) ' www.rcsb.org/pdb ' - stop exit_code_input_error - end if - end if - read(10,str_format,iostat=ioerr) record - end do - ! - ! Read connectivity, if there is any specified - ! - do while(.true.) - if ( ioerr /= 0 ) exit - if(record(1:6).eq.'CONECT') then - iread = 7 - read(record(iread:iread+4),*,iostat=ioerr) iatom - iatom = iatom - idfirstatom + 1 - idatom = idfirst(itype) - 1 + iatom - if(ioerr /= 0) then - write(*,*) " ERROR: Could not read atom index from CONECT line: " - write(*,*) trim(adjustl(record)) - stop exit_code_input_error - end if - iread = iread + 5 - read(record(iread:iread+4),*,iostat=ioerr) nconnect(idatom,1) - if(ioerr /= 0) then - write(*,*) " ERROR: Could not read any connection index from CONECT line: " - write(*,*) trim(adjustl(record)) - stop exit_code_input_error - end if - nconnect(idatom,1) = nconnect(idatom,1) - idfirstatom + 1 - maxcon(idatom) = 1 - do while(.true.) - iread = iread + 5 - read(record(iread:iread+4),*,iostat=ioerr) nconnect(idatom,maxcon(idatom)+1) - if(ioerr == 0) then - maxcon(idatom) = maxcon(idatom) + 1 - nconnect(idatom,maxcon(idatom)) = nconnect(idatom,maxcon(idatom)) - idfirstatom + 1 - else - exit - end if - end do - end if - read(10,str_format,iostat=ioerr) record - end do - close(10) - end if - - ! Reading tinker input files - - if(tinker) then - open(10,file=keyword(iline,2),status='old',iostat=ioerr) - if ( ioerr /= 0 ) call failopen(keyword(iline,2)) - idfirst(itype) = 1 - do ii = itype - 1, 1, -1 - idfirst(itype) = idfirst(itype) + natoms(ii) - end do - record = keyword(iline,2) - call setcon(record(1:64),idfirst(itype)) - open(10,file = keyword(iline,2), status = 'old') - record = blank - do while(record.le.blank) - read(10,str_format) record - end do - i = 1 - do while(record(i:i).le.' ') - i = i + 1 - if ( i > strl ) exit - end do - iarg = i - if ( i < strl ) then - do while(record(i:i).gt.' ') - i = i + 1 - if ( i > strl ) exit - end do - end if - read(record(iarg:i-1),*) natoms(itype) - if ( i < strl ) then - do while(record(i:i).le.' ') - i = i + 1 - if ( i > strl ) exit - end do - end if - iarg = i - if ( i < strl ) then - do while(record(i:i).gt.' ') - i = i + 1 - if ( i > strl ) exit - end do - end if - read(record(iarg:i-1),str_format) name(itype) - record = name(itype) - name(itype) = trim(adjustl(record)) - if(name(itype).lt.' ') name(itype) = 'Without_title' - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - record = blank - do while(record.le.blank) - read(10,str_format) record - end do - i = 1 - do while(record(i:i).le.' ') - i = i + 1 - if ( i > strl ) exit - end do - iarg = i - if ( i < strl ) then - do while(record(i:i).gt.' ') - i = i + 1 - if ( i > strl ) exit - end do - end if - read(record(iarg:i-1),*) in - if ( i < strl ) then - do while(record(i:i).le.' ') - i = i + 1 - if ( i > strl ) exit - end do - end if - iarg = i - if ( i < strl ) then - do while(record(i:i).gt.' ') - i = i + 1 - if ( i > strl ) exit - end do - end if - read(record(iarg:i-1),*) ele(idatom) - read(record(i:strl),*) (coor(idatom,k), k = 1, 3),& - (nconnect(idatom, k), k = 1, maxcon(idatom)) - amass(idatom) = 1.d0 - end do - close(10) - end if - - ! Reading xyz input files - - if(xyz) then - open(10,file=keyword(iline,2),status='old',iostat=ioerr) - if ( ioerr /= 0 ) call failopen(keyword(iline,2)) - read(10,*) natoms(itype) - read(10,str_format) name(itype) - if(name(itype).lt.' ') name(itype) = 'Without_title' - idfirst(itype) = 1 - do ii = itype - 1, 1, -1 - idfirst(itype) = idfirst(itype) + natoms(ii) - end do - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - record = blank - read(10,str_format) record - read(record,*) ele(idatom), (coor(idatom,k),k=1,3) - amass(idatom) = 1.d0 - end do - close(10) - end if - - ! Reading moldy input files - - if(moldy) then - open(10,file=keyword(iline,2), status ='old',iostat=ioerr) - if ( ioerr /= 0 ) call failopen(keyword(iline,2)) - read(10,*) name(itype), nmols(itype) - natoms(itype) = 0 - do while(.true.) - read(10,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - if(record.gt.' '.and.record(1:3).ne.'end') & - natoms(itype) = natoms(itype) + 1 - end do - close(10) - idfirst(itype) = 1 - do ii = itype - 1, 1, -1 - idfirst(itype) = idfirst(itype) + natoms(ii) - end do - open(10,file=keyword(iline,2),status='old') - read(10,str_format) record - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - read(10,str_format) record - read(record,*) lixo, (coor(idatom,k), k = 1, 3),& - amass(idatom), charge(idatom), ele(idatom) - end do - close(10) - end if - end if - - end do - ntype = itype - - write(*,*) ' Number of independent structures: ', ntype - write(*,*) ' The structures are: ' - - do itype = 1, ntype - record = name(itype) - write(*,*) ' Structure ', itype, ':', trim(adjustl(record)),& - '(',natoms(itype),' atoms)' - end do - - ! Setting the vectors for the number of GENCAN loops - - if(nloop.eq.0) then - nloop_all = 200*ntype - nloop = nloop_all - else - nloop_all = nloop - end if - write(*,*) ' Maximum number of GENCAN loops for all molecule packing: ', nloop_all - do itype = 1, ntype - if ( nloop_type(itype) == 0 ) then - nloop_type(itype) = nloop_all - else - write(*,*) ' Maximum number of GENCAN loops for type: ', itype, ': ', nloop_type(itype) - end if - end do - - ! nloop0 are the number of loops for the initial phase packing - - if(nloop0.eq.0) then - nloop0 = 20*ntype - else - write(*,*) ' Maximum number of GENCAN loops-0 for all molecule packing: ', nloop0 - end if - do itype = 1, ntype - if ( nloop0_type(itype) == 0 ) then - nloop0_type(itype) = nloop0 - else - write(*,*) ' Maximum number of GENCAN loops-0 for type: ', itype, ': ', nloop0_type(itype) - end if - end do - - ! Reading the restrictions that were set - - irest = 0 - ioerr = 0 - do iline = 1, nlines - - if(keyword(iline,1).eq.'fixed') then - irest = irest + 1 - irestline(irest) = iline - ityperest(irest) = 1 - read(keyword(iline,2),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,4) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,5) - read(keyword(iline,7),*,iostat=ioerr) restpars(irest,6) - end if - - if(keyword(iline,1).eq.'inside') then - irest = irest + 1 - irestline(irest) = iline - if(keyword(iline,2).eq.'cube') then - ityperest(irest) = 2 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - else if(keyword(iline,2).eq.'box') then - ityperest(irest) = 3 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) - read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) - else if(keyword(iline,2).eq.'sphere') then - ityperest(irest) = 4 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - else if(keyword(iline,2).eq.'ellipsoid') then - ityperest(irest) = 5 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) - read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) - read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) - else if(keyword(iline,2).eq.'cylinder') then - ityperest(irest) = 12 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) - read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) - read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) - read(keyword(iline,10),*,iostat=ioerr) restpars(irest,9) - restpars(irest,8) = restpars(irest,4)**2 + & - restpars(irest,5)**2 + & - restpars(irest,6)**2 - if(restpars(irest,8).lt.1.d-10) then - write(*,*) ' ERROR: The norm of the director vector', & - ' of the cylinder constraint cannot be zero.' - ioerr = 1 - else - clen = dsqrt(restpars(irest,8)) - restpars(irest,4) = restpars(irest,4) / clen - restpars(irest,5) = restpars(irest,5) / clen - restpars(irest,6) = restpars(irest,6) / clen - end if - else - ioerr = 1 - end if - end if - - if(keyword(iline,1).eq.'outside') then - irest = irest + 1 - irestline(irest) = iline - if(keyword(iline,2).eq.'cube') then - ityperest(irest) = 6 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - else if(keyword(iline,2).eq.'box') then - ityperest(irest) = 7 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) - read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) - else if(keyword(iline,2).eq.'sphere') then - ityperest(irest) = 8 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - else if(keyword(iline,2).eq.'ellipsoid') then - ityperest(irest) = 9 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) - read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) - read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) - else if(keyword(iline,2).eq.'cylinder') then - ityperest(irest) = 13 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - read(keyword(iline,7),*,iostat=ioerr) restpars(irest,5) - read(keyword(iline,8),*,iostat=ioerr) restpars(irest,6) - read(keyword(iline,9),*,iostat=ioerr) restpars(irest,7) - read(keyword(iline,10),*,iostat=ioerr) restpars(irest,9) - restpars(irest,8) = restpars(irest,4)**2 + & - restpars(irest,5)**2 + & - restpars(irest,6)**2 - if(restpars(irest,8).lt.1.d-10) then - write(*,*) ' ERROR: The norm of the director vector',& - ' of the cylinder constraint cannot be zero.' - ioerr = 1 - else - clen = dsqrt(restpars(irest,8)) - restpars(irest,4) = restpars(irest,4) / clen - restpars(irest,5) = restpars(irest,5) / clen - restpars(irest,6) = restpars(irest,6) / clen - end if - else - ioerr = 1 - end if - end if - - if(keyword(iline,1).eq.'over' .or. keyword(iline,1).eq.'above') then - irest = irest + 1 - irestline(irest) = iline - ityperest(irest) = 10 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - if(keyword(iline,2).ne.'plane') ioerr = 1 - end if - - if(keyword(iline,1).eq.'below') then - irest = irest + 1 - irestline(irest) = iline - ityperest(irest) = 11 - read(keyword(iline,3),*,iostat=ioerr) restpars(irest,1) - read(keyword(iline,4),*,iostat=ioerr) restpars(irest,2) - read(keyword(iline,5),*,iostat=ioerr) restpars(irest,3) - read(keyword(iline,6),*,iostat=ioerr) restpars(irest,4) - if(keyword(iline,2).ne.'plane') ioerr = 1 - end if - - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Some restriction is not set correctly. ' - stop exit_code_input_error - end if - - end do - nrest = irest - write(*,*) ' Total number of restrictions: ', nrest - - ! Getting the tolerance - - ioerr = 1 - dism = -1.d0 - do iline = 1, nlines - if(keyword(iline,1).eq.'tolerance') then - read(keyword(iline,2),*,iostat=ioerr) dism - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Failed reading tolerance. ' - stop exit_code_input_error - end if - exit - end if - end do - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Overall tolerance not set. Use, for example: tolerance 2.0 ' - stop exit_code_input_error - end if - write(*,*) ' Distance tolerance: ', dism - - ! Reading, if defined, the short distance penalty parameters - - ioerr = 1 - short_tol_dist = dism/2.d0 - ! Reading short_tol_dist - do iline = 1, nlines - if(keyword(iline,1).eq.'short_tol_dist') then - read(keyword(iline,2),*,iostat=ioerr) short_tol_dist - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Failed reading short_tol_dist. ' - stop exit_code_input_error - end if - if ( short_tol_dist > dism ) then - write(*,*) ' ERROR: The short_tol_dist parameter must be smaller than the tolerance. ' - stop exit_code_input_error - end if - write(*,*) ' User defined short tolerance distance: ', short_tol_dist - short_tol_dist = short_tol_dist**2 - exit - end if - end do - ! Reading short_tol_scale - short_tol_scale = 3.d0 - do iline = 1, nlines - if(keyword(iline,1).eq.'short_tol_scale') then - read(keyword(iline,2),*,iostat=ioerr) short_tol_scale - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Failed reading short_tol_scale. ' - stop exit_code_input_error - end if - if ( short_tol_dist <= 0.d0 ) then - write(*,*) ' ERROR: The short_tol_scale parameter must be positive. ' - stop exit_code_input_error - end if - write(*,*) ' User defined short tolerance scale: ', short_tol_scale - exit - end if - end do - - ! Assigning the input lines that correspond to each structure - - itype = 0 - iline = 0 - do while(iline < nlines) - iline = iline + 1 - if(keyword(iline,1).eq.'structure') then - itype = itype + 1 - linestrut(itype,1) = iline - iline = iline + 1 - do while(keyword(iline,1).ne.'end'.or.& - keyword(iline,2).ne.'structure') - if(keyword(iline,1) == 'structure'.or.& - iline == nlines) then - write(*,*) ' ERROR: Structure specification not ending with "end structure"' - stop exit_code_input_error - end if - iline = iline + 1 - end do - linestrut(itype,2) = iline - end if - end do - - ! If pdb files, get the type of residue numbering output for each - ! molecule - - if(pdb) then - do itype = 1, ntype - connect(itype) = .true. - resnumbers(itype) = -1 - changechains(itype) = .false. - chain(itype) = "#" - segid(itype) = "" - maxmove(itype) = nmols(itype) - do iline = 1, nlines - if(iline.gt.linestrut(itype,1).and.& - iline.lt.linestrut(itype,2)) then - if(keyword(iline,1).eq.'changechains') then - changechains(itype) = .true. - end if - if(keyword(iline,1).eq.'maxmove') then - read(keyword(iline,2),*) maxmove(itype) - end if - if(keyword(iline,1).eq.'resnumbers') then - read(keyword(iline,2),*) resnumbers(itype) - end if - if(keyword(iline,1).eq.'connect') then - if(keyword(iline,2) == "no") then - connect(itype) = .false. - end if - end if - if(keyword(iline,1).eq.'chain') then - read(keyword(iline,2),*) chain(itype) - end if - if(keyword(iline,1).eq.'segid') then - read(keyword(iline,2),*) segid(itype) - end if - end if - end do - if (crd) then - if (itype.gt.1 .and. segid(itype)=="") then - if (segid(itype-1) /= "") then - write(*,*) ' Warning: Type of segid not defined for ', itype,'. Keeping it same as previous' - endif - segid(itype) = segid(itype-1) - endif - endif - if ( resnumbers(itype) == -1 ) then - write(*,*) ' Warning: Type of residue numbering not',& - ' set for structure ',itype - call setrnum(pdbfile(itype),imark) - if(imark.eq.1) resnumbers(itype) = 0 - if(imark.gt.1) resnumbers(itype) = 1 - end if - write(*,*) ' Residue numbering set for structure ',itype,':',& - resnumbers(itype) - write(*,*) ' Swap chains of molecules of structure ',& - itype,':', changechains(itype) - if ( chain(itype) /= "#" ) then - write(*,*) ' Specific chain identifier set for structure ',itype,':',chain(itype) - end if - if ( chain(itype) /= "#" .and. changechains(itype) ) then - write(*,*) " ERROR: 'changechains' and 'chain' input parameters are not compatible " - write(*,*) " for a single structure. " - stop exit_code_input_error - end if - end do - end if - - ! Write the number of molecules of each type - - do itype = 1, ntype - write(*,*) ' Number of molecules of type ', itype, ': ', nmols(itype) - if(pdb.and.nmols(itype).gt.9999) then - write(*,*) ' Warning: There will be more than 9999 molecules of type ',itype - if (.not. crd) write(*,*) ' Residue numbering is reset after 9999. ' - if (crd) write(*,*) ' Residue numbering is reset after 9999 in pdb but not in crd. ' - if ( chain(itype) == "#" ) then - write(*,*) ' Each set be will be assigned a different chain in the PDB output file. ' - end if - end if - if(crd.and.nmols(itype).gt.99999999) then - write(*,*) ' Warning: There will be more than 99999999 molecules of type ',itype - write(*,*) ' Residue numbering is reset after 99999999 in crd. ' - endif - end do - - ! Checking if restart files will be used for each structure or for the whole system - - restart_from(0) = "none" - restart_to(0) = "none" - do itype = 1, ntype - restart_from(itype) = "none" - restart_to(itype) = "none" - end do - lines: do iline = 1, nlines - if ( keyword(iline,1) == 'restart_from' ) then - do itype = 1, ntype - if(iline.gt.linestrut(itype,1).and.& - iline.lt.linestrut(itype,2)) then - restart_from(itype) = keyword(iline,2) - cycle lines - end if - end do - if( restart_from(0) == 'none' ) then - restart_from(0) = keyword(iline,2) - else - write(*,*) ' ERROR: More than one definition of restart_from file for all system. ' - stop exit_code_input_error - end if - end if - if ( keyword(iline,1) == 'restart_to' ) then - do itype = 1, ntype - if(iline.gt.linestrut(itype,1).and.& - iline.lt.linestrut(itype,2)) then - restart_to(itype) = keyword(iline,2) - cycle lines - end if - end do - if( restart_to(0) == 'none' ) then - restart_to(0) = keyword(iline,2) - else - write(*,*) ' ERROR: More than one definition of restart_to file for all system. ' - stop exit_code_input_error - end if - end if - end do lines - - return -end subroutine getinp - -! -! Subroutine that stops if failed to open file -! - -subroutine failopen(record) - use exit_codes - use sizes - character(len=strl) :: record - write(*,*) - write(*,*) ' ERROR: Could not open file. ' - write(*,*) ' Could not find file: ',trim(record) - write(*,*) ' Please check if all the input and structure ' - write(*,*) ' files are in the current directory or if the' - write(*,*) ' correct paths are provided.' - write(*,*) - stop exit_code_open_file -end subroutine failopen - -! -! Subroutine that checks if a pdb structure has one or more than -! one residue -! - -subroutine setrnum(file,nres) - - use sizes - implicit none - integer :: iread, ires, ireslast, nres, ioerr - character(len=strl) :: file - character(len=strl) :: record - - open(10,file=file,status='old') - iread = 0 - nres = 1 - do while(nres.eq.1) - read(10,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - if(record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM') then - read(record(23:26),*,iostat=ioerr) ires - if ( ioerr /= 0 ) cycle - iread = iread + 1 - if(iread.gt.1) then - if(ires.ne.ireslast) then - nres = 2 - close(10) - return - end if - end if - ireslast = ires - end if - end do - close(10) - - return -end subroutine setrnum - -! -! Subroutine that computes de number of connections of each atom -! for tinker xyz files -! - -subroutine setcon(xyzfile,idfirst) - - use sizes - use input, only : maxcon - implicit none - - integer :: idfirst - integer :: natoms, idatom, iatom, ic, i - character(len=64) :: xyzfile - character(len=120) :: record - - open(10, file = xyzfile, status='old') - read(10,*) natoms - idatom = idfirst - 1 - do iatom = 1, natoms - idatom = idatom + 1 - read(10,"( a120 )") record - ic = 0 - do i = 1, 119 - if(record(i:i).gt.' '.and.record(i+1:i+1).le.' ') ic = ic + 1 - end do - maxcon(idatom) = ic - 5 - end do - close(10) - - return -end subroutine setcon - -! -! Subroutine getkeywords: gets keywords and values from the input -! file in a more robust way -! - -subroutine getkeywords() - - use sizes - use input, only : keyword, nlines, inputfile, forbidden_char - implicit none - character(len=strl) :: record - integer :: iline, i, j, k, ilast, ival, ioerr - - ! Clearing keyword array - - do i = 1, nlines - do j = 1, maxkeywords - keyword(i,j) = 'none' - end do - end do - - ! Filling keyword array - do iline = 1, nlines - read(inputfile(iline),str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - i = 0 - ival = 0 - do while(i < strl) - i = i + 1 - ilast = i - do while(record(i:i) > ' '.and. i < strl) - i = i + 1 - end do - if(i.gt.ilast) then - ival = ival + 1 - keyword(iline,ival) = record(ilast:i) - end if - end do - end do - - ! Remove quotes and the forbidden_char from keywords - do i = 1, nlines - do j = 1, maxkeywords - record = keyword(i,j) - do k = 1,strl - if (record(k:k) == forbidden_char .or. record(k:k) == '"') then - record(k:k) = " " - end if - end do - keyword(i,j) = trim(adjustl(record)) - end do - end do - - return -end subroutine getkeywords - -! Subroutine that returns the chain character given an index - -subroutine chainc(i,chain) - - implicit none - integer :: i - character :: chain - - if(i.eq.0) chain = ' ' - if(i.eq.1) chain = 'A' - if(i.eq.2) chain = 'B' - if(i.eq.3) chain = 'C' - if(i.eq.4) chain = 'D' - if(i.eq.5) chain = 'E' - if(i.eq.6) chain = 'F' - if(i.eq.7) chain = 'G' - if(i.eq.8) chain = 'H' - if(i.eq.9) chain = 'I' - if(i.eq.10) chain = 'J' - if(i.eq.11) chain = 'K' - if(i.eq.12) chain = 'L' - if(i.eq.13) chain = 'M' - if(i.eq.14) chain = 'N' - if(i.eq.15) chain = 'O' - if(i.eq.16) chain = 'P' - if(i.eq.17) chain = 'Q' - if(i.eq.18) chain = 'R' - if(i.eq.19) chain = 'S' - if(i.eq.20) chain = 'T' - if(i.eq.21) chain = 'U' - if(i.eq.22) chain = 'V' - if(i.eq.23) chain = 'W' - if(i.eq.24) chain = 'X' - if(i.eq.25) chain = 'Y' - if(i.eq.26) chain = 'Z' - if(i.eq.27) chain = '1' - if(i.eq.28) chain = '2' - if(i.eq.29) chain = '3' - if(i.eq.30) chain = '4' - if(i.eq.31) chain = '5' - if(i.eq.32) chain = '6' - if(i.eq.33) chain = '7' - if(i.eq.34) chain = '8' - if(i.eq.35) chain = '9' - if(i.eq.36) chain = '0' - if(i.gt.36) chain = '#' - - return -end subroutine chainc - -! Subroutine that clears a character variable - -subroutine clear(record) - - use sizes - integer :: i - character(len=strl) :: record - - do i = 1, strl - record(i:i) = ' ' - end do - - return -end subroutine clear - diff --git a/gparc.f90 b/gparc.f90 deleted file mode 100644 index a604254..0000000 --- a/gparc.f90 +++ /dev/null @@ -1,87 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Compute gradient relative to atom-to-atom distances -! - -subroutine gparc(icart,firstjcart) - - use sizes - use compute_data - implicit none - - ! SCALAR ARGUMENTS - integer :: icart,firstjcart - - ! LOCAL SCALARS - integer :: jcart - double precision :: datom, dtemp, xdiff, tol, & - short_tol, short_tol_scale - - jcart = firstjcart - do while ( jcart .ne. 0 ) - ! - ! Cycle if this type is not to be computed - ! - if ( .not. comptype(ibtype(jcart))) then - jcart = latomnext(jcart) - cycle - end if - ! - ! Cycle if the atoms are from the same molecule - ! - if ( ibmol(icart) == ibmol(jcart) .and. & - ibtype(icart) == ibtype(jcart) ) then - jcart = latomnext(jcart) - cycle - end if - ! - ! Cycle if both atoms are from fixed molecules - ! - if ( fixedatom(icart) .and. fixedatom(jcart) ) then - jcart = latomnext(jcart) - cycle - end if - ! - ! Otherwise, compute distance and evaluate function for this pair - ! - tol = (radius(icart)+radius(jcart))**2 - datom = (xcart(icart, 1)-xcart(jcart, 1))**2 + & - (xcart(icart, 2)-xcart(jcart, 2))**2 + & - (xcart(icart, 3)-xcart(jcart, 3))**2 - if( datom < tol ) then - dtemp = fscale(icart)*fscale(jcart) * 4.d0 * (datom - tol) - xdiff = dtemp*(xcart(icart,1) - xcart(jcart,1)) - gxcar(icart,1)= gxcar(icart,1) + xdiff - gxcar(jcart,1)= gxcar(jcart,1) - xdiff - xdiff = dtemp*(xcart(icart,2) - xcart(jcart,2)) - gxcar(icart,2)= gxcar(icart,2) + xdiff - gxcar(jcart,2)= gxcar(jcart,2) - xdiff - xdiff = dtemp*(xcart(icart,3) - xcart(jcart,3)) - gxcar(icart,3)= gxcar(icart,3) + xdiff - gxcar(jcart,3)= gxcar(jcart,3) - xdiff - if ( use_short_radius(icart) .or. use_short_radius(jcart) ) then - short_tol = ( short_radius(icart) + short_radius(jcart) )**2 - if ( datom < short_tol ) then - short_tol_scale = dsqrt(short_radius_scale(icart)*short_radius_scale(jcart)) - short_tol_scale = short_tol_scale*( tol**2 / short_tol**2 ) - dtemp = fscale(icart)*fscale(jcart) * 4.d0 * short_tol_scale*(datom - short_tol) - xdiff = dtemp*(xcart(icart,1) - xcart(jcart,1)) - gxcar(icart,1)= gxcar(icart,1) + xdiff - gxcar(jcart,1)= gxcar(jcart,1) - xdiff - xdiff = dtemp*(xcart(icart,2) - xcart(jcart,2)) - gxcar(icart,2)= gxcar(icart,2) + xdiff - gxcar(jcart,2)= gxcar(jcart,2) - xdiff - xdiff = dtemp*(xcart(icart,3) - xcart(jcart,3)) - gxcar(icart,3)= gxcar(icart,3) + xdiff - gxcar(jcart,3)= gxcar(jcart,3) - xdiff - end if - end if - end if - jcart = latomnext(jcart) - end do - return -end subroutine gparc - diff --git a/gwalls.f90 b/gwalls.f90 deleted file mode 100644 index 9b632b4..0000000 --- a/gwalls.f90 +++ /dev/null @@ -1,264 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Gradient relative to restraints -! - -subroutine gwalls(icart,irest) - - use sizes - use compute_data - - implicit none - integer :: icart, irest - double precision :: a1, a2, a3, a4, a5, a6, xmin, ymin, zmin, & - xmax, ymax, zmax, & - clength, b1, b2, b3, c1, c2, w, d, rg(3), & - vnorm, vv1, vv2, vv3, frab, frac, frbc, & - dfra(3), dfrb(3), dfrc(3) - - if(ityperest(irest).eq.2) then - clength = restpars(irest,4) - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,1) + clength - ymax = restpars(irest,2) + clength - zmax = restpars(irest,3) + clength - a1 = xcart(icart,1) - xmin - a2 = xcart(icart,2) - ymin - a3 = xcart(icart,3) - zmin - if(a1.lt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 - if(a2.lt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 - if(a3.lt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 - a1 = xcart(icart,1) - xmax - a2 = xcart(icart,2) - ymax - a3 = xcart(icart,3) - zmax - if(a1.gt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 - if(a2.gt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 - if(a3.gt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 - else if(ityperest(irest).eq.3) then - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,4) - ymax = restpars(irest,5) - zmax = restpars(irest,6) - a1 = xcart(icart,1) - xmin - a2 = xcart(icart,2) - ymin - a3 = xcart(icart,3) - zmin - if(a1.lt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 - if(a2.lt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 - if(a3.lt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 - a1 = xcart(icart,1) - xmax - a2 = xcart(icart,2) - ymax - a3 = xcart(icart,3) - zmax - if(a1.gt.0.d0) gxcar(icart,1) = gxcar(icart,1) + scale * 2.d0 * a1 - if(a2.gt.0.d0) gxcar(icart,2) = gxcar(icart,2) + scale * 2.d0 * a2 - if(a3.gt.0.d0) gxcar(icart,3) = gxcar(icart,3) + scale * 2.d0 * a3 - else if(ityperest(irest).eq.4) then - d = (xcart(icart,1)-restpars(irest,1))**2 + & - (xcart(icart,2)-restpars(irest,2))**2 + & - (xcart(icart,3)-restpars(irest,3))**2 - & - restpars(irest,4)**2 - if(d.gt.0.d0) then - gxcar(icart,1) = gxcar(icart,1) + 4.d0 * scale2 * & - (xcart(icart,1)-restpars(irest,1))*d - gxcar(icart,2) = gxcar(icart,2) + 4.d0 * scale2 * & - (xcart(icart,2)-restpars(irest,2))*d - gxcar(icart,3) = gxcar(icart,3) + 4.d0 * scale2 * & - (xcart(icart,3)-restpars(irest,3))*d - end if - else if(ityperest(irest).eq.5) then - a1 = xcart(icart,1)-restpars(irest,1) - b1 = xcart(icart,2)-restpars(irest,2) - c1 = xcart(icart,3)-restpars(irest,3) - a2 = restpars(irest,4)**2 - b2 = restpars(irest,5)**2 - c2 = restpars(irest,6)**2 - d = a1**2/a2+b1**2/b2+c1**2/c2-restpars(irest,7)**2 - if(d.gt.0) then - gxcar(icart,1) = gxcar(icart,1) + scale2*4.d0*d*a1/a2 - gxcar(icart,2) = gxcar(icart,2) + scale2*4.d0*d*b1/b2 - gxcar(icart,3) = gxcar(icart,3) + scale2*4.d0*d*c1/c2 - end if - else if(ityperest(irest).eq.6) then - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,1) + restpars(irest,4) - ymax = restpars(irest,2) + restpars(irest,4) - zmax = restpars(irest,3) + restpars(irest,4) - a1 = dmax1(xcart(icart,1) - xmin,0.d0) - a2 = dmax1(xcart(icart,2) - ymin,0.d0) - a3 = dmax1(xcart(icart,3) - zmin,0.d0) - a4 = dmax1(xmax - xcart(icart,1),0.d0) - a5 = dmax1(ymax - xcart(icart,2),0.d0) - a6 = dmax1(zmax - xcart(icart,3),0.d0) - w = a1*a2*a3*a4*a5*a6 - if(w.gt.0.d0) then - gxcar(icart,1) = gxcar(icart,1) + a2*a3*a5*a6*(a4-a1) - gxcar(icart,2) = gxcar(icart,2) + a1*a3*a4*a6*(a5-a2) - gxcar(icart,3) = gxcar(icart,3) + a1*a2*a4*a5*(a6-a3) - end if - else if(ityperest(irest).eq.7) then - xmin = restpars(irest,1) - ymin = restpars(irest,2) - zmin = restpars(irest,3) - xmax = restpars(irest,4) - ymax = restpars(irest,5) - zmax = restpars(irest,6) - a1 = dmax1(xcart(icart,1) - xmin,0.d0) - a2 = dmax1(xcart(icart,2) - ymin,0.d0) - a3 = dmax1(xcart(icart,3) - zmin,0.d0) - a4 = dmax1(xmax - xcart(icart,1),0.d0) - a5 = dmax1(ymax - xcart(icart,2),0.d0) - a6 = dmax1(zmax - xcart(icart,3),0.d0) - w = a1*a2*a3*a4*a5*a6 - if(w.gt.0.d0) then - gxcar(icart,1) = gxcar(icart,1) + a2*a3*a5*a6*(a4-a1) - gxcar(icart,2) = gxcar(icart,2) + a1*a3*a4*a6*(a5-a2) - gxcar(icart,3) = gxcar(icart,3) + a1*a2*a4*a5*(a6-a3) - end if - else if(ityperest(irest).eq.8) then - d = (xcart(icart,1)-restpars(irest,1))**2 + & - (xcart(icart,2)-restpars(irest,2))**2 + & - (xcart(icart,3)-restpars(irest,3))**2 - & - restpars(irest,4)**2 - if(d.lt.0.d0) then - gxcar(icart,1) = gxcar(icart,1) + 4.d0 * scale2 * & - (xcart(icart,1)-restpars(irest,1))*d - gxcar(icart,2) = gxcar(icart,2) + 4.d0 * scale2 * & - (xcart(icart,2)-restpars(irest,2))*d - gxcar(icart,3) = gxcar(icart,3) + 4.d0 * scale2 * & - (xcart(icart,3)-restpars(irest,3))*d - end if - else if(ityperest(irest).eq.9) then - a1 = xcart(icart,1)-restpars(irest,1) - b1 = xcart(icart,2)-restpars(irest,2) - c1 = xcart(icart,3)-restpars(irest,3) - a2 = restpars(irest,4)**2 - b2 = restpars(irest,5)**2 - c2 = restpars(irest,6)**2 - d = a1**2/a2+b1**2/b2+c1**2/c2-restpars(irest,7)**2 - if(d.lt.0) then - d = scale2 * d - gxcar(icart,1) = gxcar(icart,1) + 4.d0*d*a1/a2 - gxcar(icart,2) = gxcar(icart,2) + 4.d0*d*b1/b2 - gxcar(icart,3) = gxcar(icart,3) + 4.d0*d*c1/c2 - end if - else if(ityperest(irest).eq.10) then - d = restpars(irest,1)*xcart(icart,1) + & - restpars(irest,2)*xcart(icart,2) + & - restpars(irest,3)*xcart(icart,3) - & - restpars(irest,4) - if(d.lt.0.d0) then - d = scale * d - gxcar(icart,1) = gxcar(icart,1) + 2.d0*restpars(irest,1)*d - gxcar(icart,2) = gxcar(icart,2) + 2.d0*restpars(irest,2)*d - gxcar(icart,3) = gxcar(icart,3) + 2.d0*restpars(irest,3)*d - end if - else if(ityperest(irest).eq.11) then - d = restpars(irest,1)*xcart(icart,1) + & - restpars(irest,2)*xcart(icart,2) + & - restpars(irest,3)*xcart(icart,3) - & - restpars(irest,4) - if(d.gt.0.d0) then - d = scale * d - gxcar(icart,1) = gxcar(icart,1) + 2.d0*restpars(irest,1)*d - gxcar(icart,2) = gxcar(icart,2) + 2.d0*restpars(irest,2)*d - gxcar(icart,3) = gxcar(icart,3) + 2.d0*restpars(irest,3)*d - end if - else if(ityperest(irest).eq.12) then - rg(1) = 0.0d0 - rg(2) = 0.0d0 - rg(3) = 0.0d0 - a1 = xcart(icart,1) - restpars(irest,1) - a2 = xcart(icart,2) - restpars(irest,2) - a3 = xcart(icart,3) - restpars(irest,3) - vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 & - + restpars(irest,6)**2) - vv1 = restpars(irest,4)/vnorm - vv2 = restpars(irest,5)/vnorm - vv3 = restpars(irest,6)/vnorm - b1 = vv1 * a1 - b2 = vv2 * a2 - b3 = vv3 * a3 - w = b1 + b2 + b3 - d = (a1 - vv1*w)**2 + (a2 - vv2*w)**2 + (a3 - vv3*w)**2 - rg(1) = scale2 * ( & - -2*dmax1(-w , 0.d0) * vv1 + & - 2*dmax1(w - restpars(irest,9), 0.d0) * vv1 + & - 2*dmax1(d - restpars(irest,7)**2 , 0.d0) * & - (2*(a1 - vv1*w)*(1 - vv1**2)+ & - 2*(a2 - vv2*w)*(-vv2*vv1)+ & - 2*(a3 - vv3*w)*(-vv3*vv1) )) - rg(2) = scale2 * ( & - -2*dmax1(-w , 0.d0) * vv2 + & - 2*dmax1(w - restpars(irest,9), 0.d0) * vv2 + & - 2*dmax1(d - restpars(irest,7)**2 , 0.d0) * & - (2*(a1 - vv1*w)*(-vv1*vv2)+ & - 2*(a2 - vv2*w)*(1 - vv2**2)+ & - 2*(a3 - vv3*w)*(-vv3*vv2) )) - rg(3) = scale2 * ( & - -2*dmax1(-w , 0.d0) * vv3 + & - 2*dmax1(w - restpars(irest,9), 0.d0) * vv3 + & - 2*dmax1(d - restpars(irest,7)**2 , 0.d0) * & - (2*(a1 - vv1*w)*(-vv1*vv3)+ & - 2*(a2 - vv2*w)*(-vv2*vv3)+ & - 2*(a3 - vv3*w)*(1 - vv3**2) )) - gxcar(icart,1) = gxcar(icart,1) + rg(1) - gxcar(icart,2) = gxcar(icart,2) + rg(2) - gxcar(icart,3) = gxcar(icart,3) + rg(3) - else if(ityperest(irest).eq.13) then - rg(1) = 0.0d0 - rg(2) = 0.0d0 - rg(3) = 0.0d0 - a1 = xcart(icart,1) - restpars(irest,1) - a2 = xcart(icart,2) - restpars(irest,2) - a3 = xcart(icart,3) - restpars(irest,3) - vnorm = sqrt(restpars(irest,4)**2 + restpars(irest,5)**2 & - + restpars(irest,6)**2) - vv1 = restpars(irest,4)/vnorm - vv2 = restpars(irest,5)/vnorm - vv3 = restpars(irest,6)/vnorm - b1 = vv1 * a1 - b2 = vv2 * a2 - b3 = vv3 * a3 - w = b1 + b2 + b3 - d = (a1 - vv1*w)**2 + (a2 - vv2*w)**2 + (a3 - vv3*w)**2 - frab = dmin1(-w , 0.d0)**2 * dmin1(w - restpars(irest,9), 0.d0)**2 - frac = dmin1(-w , 0.d0)**2 * dmin1(d - restpars(irest,7)**2 , 0.d0 )**2 - frbc = dmin1(w - restpars(irest,9), 0.d0)**2 * & - dmin1(d - restpars(irest,7)**2 , 0.d0 )**2 - dfra(1) = -2*dmin1(-w , 0.d0) * vv1 - dfrb(1) = 2*dmin1(w - restpars(irest,9), 0.d0) * vv1 - dfrc(1) = 2*dmin1(d - restpars(irest,7)**2 , 0.d0) * & - (2*(a1 - vv1*w)*(1 - vv1**2)+ & - 2*(a2 - vv2*w)*(-vv2*vv1)+ & - 2*(a3 - vv3*w)*(-vv3*vv1) ) - dfra(2) = -2*dmin1(-w , 0.d0) * vv2 - dfrb(2) = 2*dmin1(w - restpars(irest,9), 0.d0) * vv2 - dfrc(2) = 2*dmin1(d - restpars(irest,7)**2 , 0.d0) * & - (2*(a1 - vv1*w)*(-vv1*vv2)+ & - 2*(a2 - vv2*w)*(1 - vv2**2)+ & - 2*(a3 - vv3*w)*(-vv3*vv2) ) - dfra(3) = -2*dmin1(-w , 0.d0) * vv3 - dfrb(3) = 2*dmin1(w - restpars(irest,9), 0.d0) * vv3 - dfrc(3) = 2*dmin1(d - restpars(irest,7)**2 , 0.d0) * & - (2*(a1 - vv1*w)*(-vv1*vv3)+ & - 2*(a2 - vv2*w)*(-vv2*vv3)+ & - 2*(a3 - vv3*w)*(1 - vv3**2) ) - rg(1) = scale2 * ( dfra(1)*frbc + dfrb(1)*frac + dfrc(1)*frab) - rg(2) = scale2 * ( dfra(2)*frbc + dfrb(2)*frac + dfrc(2)*frab) - rg(3) = scale2 * ( dfra(3)*frbc + dfrb(3)*frac + dfrc(3)*frab) - gxcar(icart,1) = gxcar(icart,1) + rg(1) - gxcar(icart,2) = gxcar(icart,2) + rg(2) - gxcar(icart,3) = gxcar(icart,3) + rg(3) - end if - - return -end subroutine gwalls - diff --git a/heuristics.f90 b/heuristics.f90 deleted file mode 100644 index 02d2280..0000000 --- a/heuristics.f90 +++ /dev/null @@ -1,151 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! subroutine movebad: Move the worse molecules to new positions -! - -subroutine movebad(n,x,fx,movebadprint) - - use sizes - use compute_data - use input, only : movefrac, movebadrandom, precision, maxmove - use usegencan - use flashsort - use ahestetic - implicit none - - ! Internal variables - integer :: n, i, j, icart, itype, iatom, imol, ilubar, ilugan, & - ilubar2, ilugan2, nbad, igood, ibad, nmove - double precision :: x(n), fx, rnd, frac - double precision :: fdist_mol, frest_mol - logical :: movebadprint, hasbad - - if(movebadprint) write(*,*) ' Moving worst molecules ... ' - - icart = 0 - do itype = 1, ntype - if(.not.comptype(itype)) then - icart = icart + nmols(itype)*natoms(itype) - else - do imol = 1, nmols(itype) - do iatom = 1, natoms(itype) - icart = icart + 1 - fdist_atom(icart) = 0.d0 - frest_atom(icart) = 0.d0 - end do - end do - end if - end do - - move = .true. - if(movebadprint) write(*,*) ' Function value before moving molecules:',fx - do i = 1, ntotat - radiuswork(i) = radius(i) - radius(i) = radius_ini(i) - end do - call computef(n,x,fx) - move = .false. - - ! Moving the worst molecules - - hasbad = .false. - icart = 0 - do itype = 1, ntype - if(.not.comptype(itype)) then - icart = icart + nmols(itype)*natoms(itype) - else - - ! Checking the function value for each molecule - - nbad = 0 - do imol = 1, nmols(itype) - fdist_mol = 0.d0 - frest_mol = 0.d0 - do iatom = 1, natoms(itype) - icart = icart + 1 - fdist_mol = dmax1(fdist_mol,fdist_atom(icart)) - frest_mol = dmax1(frest_mol,frest_atom(icart)) - end do - if(fdist_mol > precision .or. & - frest_mol > precision ) then - hasbad = .true. - nbad = nbad + 1 - fmol(imol) = fdist_mol + frest_mol - else - fmol(imol) = 0.d0 - end if - end do - frac = dfloat(nbad)/dfloat(nmols(itype)) - if(movebadprint) write(*,"( a,i9,a,f8.2,a )") & - ' Type ',itype,' molecules with non-zero contributions:', & - 100.d0*frac,'%' - - if(nbad.gt.0) then - - frac = dmin1(movefrac,frac) - - ! Ordering molecules from best to worst - - mflash = 1 + nmols(itype)/10 - call flash1(fmol,nmols(itype),lflash,mflash,indflash) - - ! Moving molecules - - nmove = min0(maxmove(itype),max0(int(nmols(itype)*frac),1)) - if(movebadprint) then - write(*,"( a,i9,a,i9 )") ' Moving ',nmove,' molecules of type ',itype - if ( movebadrandom ) then - write(*,*) ' New positions will be aleatory (movebadrandom is set) ' - else - write(*,*) ' New positions will be based on good molecules (movebadrandom is not set) ' - end if - end if - imol = 0 - do i = 1, itype - 1 - if(comptype(i)) imol = imol + nmols(i) - end do - write(*,prog2_line) - write(*,"( ' |',$)") - j = 0 - do i = 1, nmove - ibad = nmols(itype) - i + 1 - igood = int(rnd()*nmols(itype)*frac) + 1 - ilubar = 3*(indflash(ibad)+imol-1) - ilugan = 3*(indflash(ibad)+imol-1)+3*ntotmol - ilubar2 = 3*(indflash(igood)+imol-1) - ilugan2 = 3*(indflash(igood)+imol-1)+3*ntotmol - if ( movebadrandom ) then - x(ilubar+1) = sizemin(1) + rnd()*(sizemax(1)-sizemin(1)) - x(ilubar+2) = sizemin(2) + rnd()*(sizemax(2)-sizemin(2)) - x(ilubar+3) = sizemin(3) + rnd()*(sizemax(3)-sizemin(3)) - else - x(ilubar+1) = x(ilubar2+1) - 0.3*dmax(itype)+0.6*rnd()*dmax(itype) - x(ilubar+2) = x(ilubar2+2) - 0.3*dmax(itype)+0.6*rnd()*dmax(itype) - x(ilubar+3) = x(ilubar2+3) - 0.3*dmax(itype)+0.6*rnd()*dmax(itype) - end if - x(ilugan+1) = x(ilugan2+1) - x(ilugan+2) = x(ilugan2+2) - x(ilugan+3) = x(ilugan2+3) - call restmol(itype,ilubar,n,x,fx,.true.) - do while( j <= 65.d0*i/nmove ) - write(*,"('*',$)") - j = j + 1 - end do - end do - write(*,"('|')") - end if - end if - end do - - call computef(n,x,fx) - if(movebadprint) write(*,*) ' Function value after moving molecules:', fx - do i = 1, ntotat - radius(i) = radiuswork(i) - end do - - return -end subroutine movebad - diff --git a/initial.f90 b/initial.f90 deleted file mode 100644 index 5fc29da..0000000 --- a/initial.f90 +++ /dev/null @@ -1,592 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine initial: Subroutine that reset parameters and -! builds the initial point -! - -subroutine initial(n,x) - - use exit_codes - use sizes - use compute_data - use input, only : randini, ntfix, fix, moldy, chkgrad, avoidoverlap,& - discale, precision, sidemax, restart_from, input_itype,& - nloop0_type - use usegencan - use ahestetic - implicit none - integer :: n, i, j, k, idatom, iatom, ilubar, ilugan, icart, itype, & - imol, ntry, nb, iboxx, iboxy, iboxz, ifatom, & - idfatom, iftype, jatom, ioerr - - double precision :: x(n), cmx, cmy, beta, gamma, theta, & - cmz, fx, xlength, dbox, rnd, & - radmax, v1(3), v2(3), v3(3), xbar, ybar, zbar - double precision, parameter :: twopi = 8.d0*datan(1.d0) - - logical :: overlap, movebadprint, hasbad - logical, allocatable :: hasfixed(:,:,:) - - character(len=strl) :: record - - ! Allocate hasfixed array - - allocate(hasfixed(0:nbp+1,0:nbp+1,0:nbp+1)) - - ! We need to initialize the move logical variable - - move = .false. - - ! Default status of the function evaluation - - init1 = .false. - lboxfirst = 0 - - ! Initialize the comptype logical array - - do i = 1, ntfix - comptype(i) = .true. - end do - - ! Penalty factors for the objective function relative to restrictions - ! Default values: scale = 1.d2, scale2 = 1.d1 - - scale = 1.d0 - scale2 = 1.d-2 - - ! Move molecules to their center of mass (not for moldy) - if(.not.moldy) call tobar() - - ! Compute maximum internal distance within each type of molecule - - do itype = 1, ntype - dmax(itype) = 0.d0 - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - 1 - do jatom = iatom + 1, natoms(itype) - dmax(itype) = dmax1 ( dmax(itype),& - (coor(idatom+iatom,1)-coor(idatom+jatom,1))**2+& - (coor(idatom+iatom,2)-coor(idatom+jatom,2))**2+& - (coor(idatom+iatom,3)-coor(idatom+jatom,3))**2 ) - end do - end do - dmax(itype) = dsqrt(dmax(itype)) - write(*,*) ' Maximum internal distance of type ',itype,': ',& - dmax(itype) - if(dmax(itype).eq.0.) dmax(itype) = 1.d0 - end do - - ! Maximum size of the system: if you system is very large (about - ! 80 nm wide), increase the sidemax parameter. - ! Otherwise, the packing can be slow and unsucesful - - cmxmin(1) = -sidemax - cmymin(1) = -sidemax - cmzmin(1) = -sidemax - cmxmax(1) = sidemax - cmymax(1) = sidemax - cmzmax(1) = sidemax - do i = 1, 3 - x(i) = 0.d0 - x(i+ntotmol*3) = 0.d0 - end do - call restmol(1,0,n,x,fx,.true.) - sizemin(1) = x(1) - sidemax - sizemax(1) = x(1) + sidemax - sizemin(2) = x(2) - sidemax - sizemax(2) = x(2) + sidemax - sizemin(3) = x(3) - sidemax - sizemax(3) = x(3) + sidemax - write(*,*) ' All atoms must be within these coordinates: ' - write(*,*) ' x: [ ', sizemin(1),', ', sizemax(1), ' ] ' - write(*,*) ' y: [ ', sizemin(2),', ', sizemax(2), ' ] ' - write(*,*) ' z: [ ', sizemin(3),', ', sizemax(3), ' ] ' - write(*,*) ' If the system is larger than this, increase the sidemax parameter. ' - - ! Create first aleatory guess - - i = 0 - j = ntotmol*3 - do itype = 1, ntype - do imol = 1, nmols(itype) - x(i+1) = sizemin(1) + rnd()*(sizemax(1)-sizemin(1)) - x(i+2) = sizemin(2) + rnd()*(sizemax(2)-sizemin(2)) - x(i+3) = sizemin(3) + rnd()*(sizemax(3)-sizemin(3)) - if ( constrain_rot(itype,1) ) then - x(j+1) = ( rot_bound(itype,1,1) - dabs(rot_bound(itype,1,2)) ) + & - 2.d0*rnd()*dabs(rot_bound(itype,1,2)) - else - x(j+1) = twopi*rnd() - end if - if ( constrain_rot(itype,2) ) then - x(j+2) = ( rot_bound(itype,2,1) - dabs(rot_bound(itype,2,2)) ) + & - 2.d0*rnd()*dabs(rot_bound(itype,2,2)) - else - x(j+2) = twopi*rnd() - end if - if ( constrain_rot(itype,3) ) then - x(j+3) = ( rot_bound(itype,3,1) - dabs(rot_bound(itype,3,2)) ) + & - 2.d0*rnd()*dabs(rot_bound(itype,3,2)) - else - x(j+3) = twopi*rnd() - end if - i = i + 3 - j = j + 3 - end do - end do - - ! Initialize cartesian coordinate array for the first time - - ilubar = 0 - ilugan = ntotmol*3 - icart = 0 - do itype = 1, ntype - do imol = 1, nmols(itype) - xbar = x(ilubar+1) - ybar = x(ilubar+2) - zbar = x(ilubar+3) - beta = x(ilugan+1) - gamma = x(ilugan+2) - theta = x(ilugan+3) - call eulerrmat(beta,gamma,theta,v1,v2,v3) - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - icart = icart + 1 - idatom = idatom + 1 - call compcart(icart,xbar,ybar,zbar,& - coor(idatom,1),coor(idatom,2),coor(idatom,3),& - v1,v2,v3) - fixedatom(icart) = .false. - end do - end do - end do - if(fix) then - icart = ntotat - natfix - do iftype = ntype + 1, ntfix - idfatom = idfirst(iftype) - 1 - do ifatom = 1, natoms(iftype) - idfatom = idfatom + 1 - icart = icart + 1 - xcart(icart,1) = coor(idfatom,1) - xcart(icart,2) = coor(idfatom,2) - xcart(icart,3) = coor(idfatom,3) - fixedatom(icart) = .true. - end do - end do - end if - - ! Use the largest radius as the reference for binning the box - - radmax = 0.d0 - do i = 1, ntotat - radmax = dmax1(radmax,2.d0*radius(i)) - end do - - ! Performing some steps of optimization for the restrictions only - - write(*,hash3_line) - write(*,"(' Building initial approximation ... ' )") - write(*,hash3_line) - write(*,"(' Adjusting initial point to fit the constraints ')") - write(*,dash2_line) - init1 = .true. - call swaptype(n,x,itype,0) ! Initialize swap arrays - itype = 0 - do while( itype <= ntype ) - itype = itype + 1 - if ( itype <= ntype ) then - call swaptype(n,x,itype,1) ! Set arrays for this type - else - call swaptype(n,x,itype,3) ! Restore arrays if itype = ntype + 1 - exit - end if - write(*,dash3_line) - write(*,*) ' Molecules of type: ', input_itype(itype) - write(*,*) - i = 0 - hasbad = .true. - call computef(n,x,fx) - do while( frest > precision .and. i.le. nloop0_type(itype)-1 .and. hasbad) - i = i + 1 - write(*,prog1_line) - call pgencan(n,x,fx) - call computef(n,x,fx) - if(frest > precision) then - write(*,"( a,i6,a,i6 )")' Fixing bad orientations ... ', i,' of ', nloop0_type(itype) - movebadprint = .true. - call movebad(n,x,fx,movebadprint) - end if - end do - write(*,*) - write(*,*) ' Restraint-only function value: ', fx - write(*,*) ' Maximum violation of the restraints: ', frest - call swaptype(n,x,itype,2) ! Save current type results - - if( hasbad .and. frest > precision ) then - write(*,*) ' ERROR: Packmol was unable to put the molecules' - write(*,*) ' in the desired regions even without' - write(*,*) ' considering distance tolerances. ' - write(*,*) ' Probably there is something wrong with' - write(*,*) ' the constraints, since it seems that' - write(*,*) ' the molecules cannot satisfy them at' - write(*,*) ' at all. ' - write(*,*) ' Please check the spatial constraints and' - write(*,*) ' try again.' - if ( i .ge. nloop0_type(itype)-1 ) then - end if - write(*,*) ' >The maximum number of cycles (',nloop0_type(itype),') was achieved.' - write(*,*) ' You may try increasing it with the',' nloop0 keyword, as in: nloop0 1000 ' - stop exit_code_failed_to_converge - end if - end do - init1 = .false. - - ! Rescaling sizemin and sizemax in order to build the patch of boxes - - write(*,dash3_line) - write(*,*) ' Rescaling maximum and minimum coordinates... ' - do i = 1, 3 - sizemin(i) = 1.d20 - sizemax(i) = -1.d20 - end do - - icart = 0 - do itype = 1, ntfix - do imol = 1, nmols(itype) - do iatom = 1, natoms(itype) - icart = icart + 1 - sizemin(1) = dmin1(sizemin(1),xcart(icart,1)) - sizemin(2) = dmin1(sizemin(2),xcart(icart,2)) - sizemin(3) = dmin1(sizemin(3),xcart(icart,3)) - sizemax(1) = dmax1(sizemax(1),xcart(icart,1)) - sizemax(2) = dmax1(sizemax(2),xcart(icart,2)) - sizemax(3) = dmax1(sizemax(3),xcart(icart,3)) - end do - end do - end do - - ! Computing the size of the patches - - write(*,*) ' Computing size of patches... ' - dbox = discale * radmax + 0.01d0 * radmax - do i = 1, 3 - xlength = sizemax(i) - sizemin(i) - nb = int(xlength/dbox + 1.d0) - if(nb.gt.nbp) nb = nbp - boxl(i) = dmax1(xlength/dfloat(nb),dbox) - nboxes(i) = nb - nb2(i) = nboxes(i) + 2 - end do - - ! Reseting latomfix array - - do i = 0, nbp + 1 - do j = 0, nbp + 1 - do k = 0, nbp + 1 - latomfix(i,j,k) = 0 - latomfirst(i,j,k) = 0 - hasfixed(i,j,k) = .false. - hasfree(i,j,k) = .false. - end do - end do - end do - - ! If there are fixed molecules, add them permanently to the latomfix array - - write(*,*) ' Add fixed molecules to permanent arrays... ' - if(fix) then - icart = ntotat - natfix - do iftype = ntype + 1, ntfix - idfatom = idfirst(iftype) - 1 - do ifatom = 1, natoms(iftype) - idfatom = idfatom + 1 - icart = icart + 1 - call setibox(xcart(icart,1),xcart(icart,2),xcart(icart,3),& - sizemin,boxl,nboxes,iboxx,iboxy,iboxz) - latomnext(icart) = latomfix(iboxx,iboxy,iboxz) - latomfix(iboxx,iboxy,iboxz) = icart - latomfirst(iboxx,iboxy,iboxz) = icart - ibtype(icart) = iftype - ibmol(icart) = 1 - hasfixed(iboxx,iboxy,iboxz) = .true. - end do - end do - end if - - ! Reseting mass centers to be within the regions - - write(*,*) ' Reseting center of mass... ' - do itype = 1, ntype - cmxmin(itype) = 1.d20 - cmymin(itype) = 1.d20 - cmzmin(itype) = 1.d20 - cmxmax(itype) = -1.d20 - cmymax(itype) = -1.d20 - cmzmax(itype) = -1.d20 - end do - - icart = 0 - do itype = 1, ntype - do imol = 1, nmols(itype) - cmx = 0.d0 - cmy = 0.d0 - cmz = 0.d0 - do iatom = 1, natoms(itype) - icart = icart + 1 - cmx = cmx + xcart(icart,1) - cmy = cmy + xcart(icart,2) - cmz = cmz + xcart(icart,3) - end do - cmx = cmx / dfloat(natoms(itype)) - cmy = cmy / dfloat(natoms(itype)) - cmz = cmz / dfloat(natoms(itype)) - cmxmin(itype) = dmin1(cmxmin(itype),cmx) - cmymin(itype) = dmin1(cmymin(itype),cmy) - cmzmin(itype) = dmin1(cmzmin(itype),cmz) - cmxmax(itype) = dmax1(cmxmax(itype),cmx) - cmymax(itype) = dmax1(cmymax(itype),cmy) - cmzmax(itype) = dmax1(cmzmax(itype),cmz) - end do - end do - - ! If there is a restart file for all system, read it - - if ( restart_from(0) /= 'none' ) then - record = restart_from(0) - write(*,*) ' Restarting all system from file: ', trim(adjustl(record)) - open(10,file=restart_from(0),status='old',action='read',iostat=ioerr) - ilubar = 0 - ilugan = ntotmol*3 - do i = 1, ntotmol - read(10,*,iostat=ioerr) x(ilubar+1), x(ilubar+2), x(ilubar+3), & - x(ilugan+1), x(ilugan+2), x(ilugan+3) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read restart file: ', trim(adjustl(record)) - stop exit_code_open_file - end if - ilubar = ilubar + 3 - ilugan = ilugan + 3 - end do - close(10) - return - end if - - ! Building random initial point - - write(*,dash3_line) - write(*,*) ' Setting initial trial coordinates ... ' - write(*,dash2_line) - - if ( chkgrad ) then - write(*,*) ' For checking gradient, will set avoidoverlap to false. ' - avoidoverlap = .false. - end if - - ! Setting random center of mass coordinates, within size limits - - ilubar = 0 - do itype = 1, ntype - if ( restart_from(itype) /= 'none' ) then - ilubar = ilubar + nmols(itype)*3 - cycle - end if - do imol = 1, nmols(itype) - if ( .not. avoidoverlap ) then - fx = 1.d0 - ntry = 0 - do while((fx.gt.precision).and.ntry.le.20) - ntry = ntry + 1 - x(ilubar+1) = cmxmin(itype) + rnd()*(cmxmax(itype)-cmxmin(itype)) - x(ilubar+2) = cmymin(itype) + rnd()*(cmymax(itype)-cmymin(itype)) - x(ilubar+3) = cmzmin(itype) + rnd()*(cmzmax(itype)-cmzmin(itype)) - call restmol(itype,ilubar,n,x,fx,.false.) - end do - else - fx = 1.d0 - ntry = 0 - overlap = .false. - do while((overlap.or.fx.gt.precision).and.ntry.le.20) - ntry = ntry + 1 - x(ilubar+1) = cmxmin(itype) + rnd()*(cmxmax(itype)-cmxmin(itype)) - x(ilubar+2) = cmymin(itype) + rnd()*(cmymax(itype)-cmymin(itype)) - x(ilubar+3) = cmzmin(itype) + rnd()*(cmzmax(itype)-cmzmin(itype)) - if(fix) then - call setibox(x(ilubar+1),x(ilubar+2),x(ilubar+3),& - sizemin,boxl,nboxes,iboxx,iboxy,iboxz) - if(hasfixed(iboxx, iboxy, iboxz ).or.& - hasfixed(iboxx+1,iboxy, iboxz ).or.& - hasfixed(iboxx, iboxy+1,iboxz ).or.& - hasfixed(iboxx, iboxy, iboxz+1).or.& - hasfixed(iboxx-1,iboxy, iboxz ).or.& - hasfixed(iboxx, iboxy-1,iboxz ).or.& - hasfixed(iboxx, iboxy, iboxz-1).or.& - hasfixed(iboxx+1,iboxy+1,iboxz ).or.& - hasfixed(iboxx+1,iboxy, iboxz+1).or.& - hasfixed(iboxx+1,iboxy-1,iboxz ).or.& - hasfixed(iboxx+1,iboxy, iboxz-1).or.& - hasfixed(iboxx, iboxy+1,iboxz+1).or.& - hasfixed(iboxx, iboxy+1,iboxz-1).or.& - hasfixed(iboxx, iboxy-1,iboxz+1).or.& - hasfixed(iboxx, iboxy-1,iboxz-1).or.& - hasfixed(iboxx-1,iboxy+1,iboxz ).or.& - hasfixed(iboxx-1,iboxy, iboxz+1).or.& - hasfixed(iboxx-1,iboxy-1,iboxz ).or.& - hasfixed(iboxx-1,iboxy, iboxz-1).or.& - hasfixed(iboxx+1,iboxy+1,iboxz+1).or.& - hasfixed(iboxx+1,iboxy+1,iboxz-1).or.& - hasfixed(iboxx+1,iboxy-1,iboxz+1).or.& - hasfixed(iboxx+1,iboxy-1,iboxz-1).or.& - hasfixed(iboxx-1,iboxy+1,iboxz+1).or.& - hasfixed(iboxx-1,iboxy+1,iboxz-1).or.& - hasfixed(iboxx-1,iboxy-1,iboxz+1).or.& - hasfixed(iboxx-1,iboxy-1,iboxz-1)) then - overlap = .true. - else - overlap = .false. - end if - end if - if(.not.overlap) call restmol(itype,ilubar,n,x,fx,.false.) - end do - end if - ilubar = ilubar + 3 - end do - end do - - ! Setting random angles, except if the rotations were constrained - - ilugan = ntotmol*3 - do itype = 1, ntype - if ( restart_from(itype) /= 'none' ) then - ilugan = ilugan + nmols(itype)*3 - cycle - end if - do imol = 1, nmols(itype) - if ( constrain_rot(itype,1) ) then - x(ilugan+1) = ( rot_bound(itype,1,1) - dabs(rot_bound(itype,1,2)) ) + & - 2.d0*rnd()*dabs(rot_bound(itype,1,2)) - else - x(ilugan+1) = twopi*rnd() - end if - if ( constrain_rot(itype,2) ) then - x(ilugan+2) = ( rot_bound(itype,2,1) - dabs(rot_bound(itype,2,2)) ) + & - 2.d0*rnd()*dabs(rot_bound(itype,2,2)) - else - x(ilugan+2) = twopi*rnd() - end if - if ( constrain_rot(itype,3) ) then - x(ilugan+3) = ( rot_bound(itype,3,1) - dabs(rot_bound(itype,3,2)) ) + & - 2.d0*rnd()*dabs(rot_bound(itype,3,2)) - else - x(ilugan+3) = twopi*rnd() - end if - ilugan = ilugan + 3 - end do - end do - - ! Compare analytical and finite-difference gradients - - if(chkgrad) then - dbox = discale * radmax + 0.01d0 * radmax - do i = 1, 3 - xlength = sizemax(i) - sizemin(i) - nb = int(xlength/dbox + 1.d0) - if(nb.gt.nbp) nb = nbp - boxl(i) = dmax1(xlength/dfloat(nb),dbox) - nboxes(i) = nb - nb2(i) = nboxes(i) + 2 - end do - call comparegrad(n,x) - stop - end if - - ! - ! Reading restart files of specific molecule types, if available - ! - - ilubar = 0 - ilugan = ntotmol*3 - do itype = 1, ntype - if ( restart_from(itype) /= 'none' ) then - record = restart_from(itype) - write(*,dash3_line) - write(*,*) ' Molecules of type: ', input_itype(itype) - write(*,*) ' Will restart coordinates from: ', trim(adjustl(record)) - open(10,file=record,status='old',action='read',iostat=ioerr) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not open restart file: ', trim(adjustl(record)) - stop exit_code_open_file - end if - do i = 1, nmols(itype) - read(10,*,iostat=ioerr) x(ilubar+1), x(ilubar+2), x(ilubar+3), & - x(ilugan+1), x(ilugan+2), x(ilugan+3) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read restart file: ', trim(adjustl(record)) - stop exit_code_open_file - end if - ilubar = ilubar + 3 - ilugan = ilugan + 3 - end do - close(10) - call swaptype(n,x,itype,0) ! Initialize swap arrays - call swaptype(n,x,itype,1) ! Set arrays for this type - call computef(n,x,fx) - write(*,*) ' Maximum violation of the restraints: ', frest - write(*,*) ' Maximum violation of minimum atom distances: ', fdist - call swaptype(n,x,itype,3) ! Restore all-molecule arrays - else - ilubar = ilubar + nmols(itype)*3 - ilugan = ilugan + nmols(itype)*3 - end if - end do - - ! Return with current random point (not default) - - if(randini) return - - ! Adjusting current point to fit the constraints - - init1 = .true. - call swaptype(n,x,itype,0) ! Initialize swap arrays - itype = 0 - do while( itype <= ntype ) - itype = itype + 1 - if ( itype == ntype + 1 ) then - call swaptype(n,x,itype,3) ! Restore arrays for all molecules - exit - end if - if ( restart_from(itype) /= 'none' ) cycle - call swaptype(n,x,itype,1) ! Set arrays for this type - write(*,dash3_line) - write(*,*) ' Molecules of type: ', input_itype(itype) - write(*,*) ' Adjusting random positions to fit the constraints. ' - i = 0 - call computef(n,x,fx) - hasbad = .true. - do while( frest > precision .and. i <= nloop0_type(itype)-1 .and. hasbad) - i = i + 1 - write(*,prog1_line) - call pgencan(n,x,fx) - call computef(n,x,fx) - if(frest > precision) then - write(*,"( a,i6,a,i6 )")' Fixing bad orientations ... ', i,' of ', nloop0_type(itype) - movebadprint = .true. - call movebad(n,x,fx,movebadprint) - end if - end do - write(*,*) ' Restraint-only function value: ', fx - write(*,*) ' Maximum violation of the restraints: ', frest - call swaptype(n,x,itype,2) ! Save results for this type - end do - init1 = .false. - write(*,hash3_line) - - ! Deallocate hasfixed array - - deallocate(hasfixed) - - return -end subroutine initial - diff --git a/input.f90 b/input.f90 deleted file mode 100644 index 0008d6a..0000000 --- a/input.f90 +++ /dev/null @@ -1,80 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Module that carries the input parameters read from the input file -! - -module input - - use sizes - implicit none - - integer :: nlines - integer :: nrest - integer :: seed - integer :: nloop, nloop_all - integer :: writeout - integer :: ntfix - integer :: ntcon(9) - - integer, allocatable :: nconnect(:,:) ! (ntotat,9) - integer, allocatable :: irestline(:) ! (maxrest) - integer, allocatable :: linestrut(:,:) ! (ntype,2) - integer, allocatable :: resnumbers(:) ! (ntype) - integer, allocatable :: maxcon(:) ! (ntotat) - integer, allocatable :: input_itype(:) ! (ntype) - integer, allocatable :: nloop_type(:) ! (ntype) - integer, allocatable :: nloop0_type(:) ! (ntype) - integer, allocatable :: maxmove(:) ! (ntype) - - double precision :: dism - double precision :: precison - double precision :: sidemax - double precision :: discale - double precision :: movefrac - double precision :: add_sides_fix - double precision :: precision - double precision :: fbins - double precision :: short_tol_dist - double precision :: short_tol_scale - - double precision, allocatable :: amass(:) ! (ntotat) - double precision, allocatable :: charge(:) ! (ntotat) - - logical :: writebad - logical :: tinker - logical :: pdb - logical :: crd - logical :: xyz - logical :: moldy - logical :: check - logical :: chkgrad - logical :: randini - logical :: movebadrandom - logical :: add_amber_ter, amber_ter_preserve - logical :: add_box_sides - logical :: fix - logical :: avoidoverlap - logical :: packall - logical :: use_short_tol - - logical, allocatable :: changechains(:) ! (ntype) - logical, allocatable :: fixedoninput(:) ! (ntype) - logical, allocatable :: connect(:) ! (ntype) - - character(len=1), parameter :: forbidden_char = '~' - character(len=strl) :: xyzout - character(len=strl) :: crdfile - - character(len=1), allocatable :: chain(:) ! (ntype) - character(len=3), allocatable :: ele(:) ! (ntotat) - character(len=8), allocatable :: segid(:) ! (segment identifier) - character(len=strl), allocatable :: pdbfile(:) ! (ntype) - character(len=strl), allocatable :: name(:) ! (ntype) - character(len=strl), allocatable :: keyword(:,:) ! (nlines,maxkeywords) - character(len=strl), allocatable :: inputfile(:) ! (nlines) - character(len=strl), allocatable :: restart_from(:), restart_to(:) ! (0:ntype) - -end module input diff --git a/jacobi.f90 b/jacobi.f90 deleted file mode 100644 index 04ef83f..0000000 --- a/jacobi.f90 +++ /dev/null @@ -1,106 +0,0 @@ -! -! JACOBI -! Jacobi diagonalizer with sorted output. Same calling sequence as -! EISPACK routine, but must specify nrot! -! - SUBROUTINE jacobi (a, n, np, d, v, nrot) - IMPLICIT CHARACTER (A-Z) -! - INTEGER n, np, nrot - DOUBLEPRECISION a (np, n) - DOUBLEPRECISION d (n) - DOUBLEPRECISION v (np, n) -! - DOUBLEPRECISION onorm, dnorm - DOUBLEPRECISION b, dma, q, t, c, s - DOUBLEPRECISION atemp, vtemp, dtemp - INTEGER i, j, k, l -! - DO 10000 j = 1, n - DO 10010 i = 1, n - v (i, j) = 0.0D0 -10010 CONTINUE - v (j, j) = 1.0D0 - d (j) = a (j, j) -10000 CONTINUE -! - DO 20000 l = 1, nrot - dnorm = 0.0D0 - onorm = 0.0D0 - DO 20100 j = 1, n - dnorm = dnorm + ABS (d (j)) - DO 20110 i = 1, j - 1 - onorm = onorm + ABS (a (i, j)) -20110 CONTINUE -20100 CONTINUE - IF (onorm / dnorm .LE. 0.0D0) GOTO 19999 - DO 21000 j = 2, n - DO 21010 i = 1, j - 1 - b = a (i, j) - IF (ABS (b) .GT. 0.0D0) THEN - dma = d (j) - d (i) - IF (ABS (dma) + ABS (b) .LE. ABS (dma)) THEN - t = b / dma - ELSE - q = 0.5D0 * dma / b - t = SIGN (1.0D0 / (ABS (q) + SQRT (1.0D0 + q * q)), q) - ENDIF - c = 1.0D0 / SQRT (t * t + 1.0D0) - s = t * c - a (i, j) = 0.0D0 - DO 21110 k = 1, i - 1 - atemp = c * a (k, i) - s * a (k, j) - a (k, j) = s * a (k, i) + c * a (k, j) - a (k, i) = atemp -21110 CONTINUE - DO 21120 k = i + 1, j - 1 - atemp = c * a (i, k) - s * a (k, j) - a (k, j) = s * a (i, k) + c * a (k, j) - a (i, k) = atemp -21120 CONTINUE - DO 21130 k = j + 1, n - atemp = c * a (i, k) - s * a (j, k) - a (j, k) = s * a (i, k) + c * a (j, k) - a (i, k) = atemp -21130 CONTINUE - DO 21140 k = 1, n - vtemp = c * v (k, i) - s * v (k, j) - v (k, j) = s * v (k, i) + c * v (k, j) - v (k, i) = vtemp -21140 CONTINUE - dtemp = c * c * d (i) + s * s * d (j) -& - 2.0D0 * c * s * b - d (j) = s * s * d (i) + c * c * d (j) +& - 2.0D0 * c * s * b - d (i) = dtemp - ENDIF -21010 CONTINUE -21000 CONTINUE -20000 CONTINUE -19999 CONTINUE - nrot = l -! - DO 30000 j = 1, n - 1 - k = j - dtemp = d (k) - DO 30100 i = j + 1, n - IF (d (i) .LT. dtemp) THEN - k = i - dtemp = d (k) - ENDIF -30100 CONTINUE - IF (k .GT. j) THEN - d (k) = d (j) - d (j) = dtemp - DO 30200 i = 1, n - dtemp = v (i, k) - v (i, k) = v (i, j) - v (i, j) = dtemp -30200 CONTINUE - ENDIF -30000 CONTINUE -! -RETURN -END subroutine jacobi - - diff --git a/output.f90 b/output.f90 deleted file mode 100644 index 20c0c42..0000000 --- a/output.f90 +++ /dev/null @@ -1,807 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine output: Subroutine that writes the output file -! - -subroutine output(n,x) - - use exit_codes - use sizes - use compute_data - use input - - implicit none - integer :: n, k, i, ilugan, ilubar, itype, imol, idatom,& - irest, iimol, ichain, iatom, irec, ilres, ifres,& - iires, ciires, irescount,& - icart, i_ref_atom, ioerr, ifirst_mol - integer :: nr, nres, imark - integer :: i_fixed, i_not_fixed - - double precision :: x(n) - double precision :: tens(4,4), v(4,4), dv(4) - double precision :: v1(3), v2(3), v3(3) - double precision :: xbar, ybar, zbar, beta, gama, teta, xcm, ycm, zcm - double precision :: xlength, ylength, zlength - double precision :: xxyx, xxyy, xxyz, xyyz, xyyy, xzyx,& - xzyy, xzyz, xyyx, xq, yq, zq, q0, q1, q2, q3 - double precision :: xtemp, ytemp, ztemp - double precision :: sxmin, symin, szmin, sxmax, symax, szmax - - character :: write_chain, even_chain, odd_chain - character(len=64) :: title - character(len=strl) :: pdb_atom_line, tinker_atom_line, crd_format - character(len=8) :: crdires,crdresn,crdsegi,atmname - character(len=strl) :: record - character(len=5) :: i5hex, tmp_i5hex - - ! Job title - - title = ' Built with Packmol ' - - ! - ! Write restart files, if required - ! - - ! Restart file for all system - - if ( restart_to(0) /= 'none' ) then - record = restart_to(0) - open(10,file=restart_to(0),iostat=ioerr) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not open restart_to file: ', trim(adjustl(record)) - stop exit_code_open_file - end if - ilubar = 0 - ilugan = ntotmol*3 - do i = 1, ntotmol - write(10,"(6(tr1,es23.16))") x(ilubar+1), x(ilubar+2), x(ilubar+3), & - x(ilugan+1), x(ilugan+2), x(ilugan+3) - ilubar = ilubar + 3 - ilugan = ilugan + 3 - end do - close(10) - write(*,*) ' Wrote restart file for all system: ', trim(adjustl(record)) - end if - - ! Restart files for specific molecule types - - ilubar = 0 - ilugan = ntotmol*3 - do itype = 1, ntype - if ( restart_to(itype) /= 'none' ) then - record = restart_to(itype) - open(10,file=record,iostat=ioerr) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not open restart_to file: ', trim(adjustl(record)) - stop exit_code_open_file - end if - do i = 1, nmols(itype) - write(10,"(6(tr1,es23.16))") x(ilubar+1), x(ilubar+2), x(ilubar+3), & - x(ilugan+1), x(ilugan+2), x(ilugan+3) - ilubar = ilubar + 3 - ilugan = ilugan + 3 - end do - close(10) - write(*,*) ' Wrote restart file: ', trim(adjustl(record)) - else - ilubar = ilubar + nmols(itype)*3 - ilugan = ilugan + nmols(itype)*3 - end if - end do - - ! Write the output (xyz file) - - if(xyz) then - open(30,file=xyzout,status='unknown') - write(30,*) ntotat - write(30,*) title - ilubar = 0 - ilugan = ntotmol*3 - icart = 0 - i_not_fixed = 0 - i_fixed = ntype - do itype = 1, ntfix - if ( .not. fixedoninput(itype) ) then - i_not_fixed = i_not_fixed + 1 - do imol = 1, nmols(i_not_fixed) - xbar = x(ilubar+1) - ybar = x(ilubar+2) - zbar = x(ilubar+3) - beta = x(ilugan+1) - gama = x(ilugan+2) - teta = x(ilugan+3) - call eulerrmat(beta,gama,teta,v1,v2,v3) - idatom = idfirst(i_not_fixed) - 1 - do iatom = 1, natoms(i_not_fixed) - icart = icart + 1 - idatom = idatom + 1 - call compcart(icart,xbar,ybar,zbar,& - coor(idatom,1),coor(idatom,2),& - coor(idatom,3),& - v1,v2,v3) - write(30,"( tr2,a3,tr2,3(tr2,f14.6) )") ele(idatom), (xcart(icart, k), k = 1, 3) - end do - ilugan = ilugan + 3 - ilubar = ilubar + 3 - end do - else - i_fixed = i_fixed + 1 - idatom = idfirst(i_fixed) - 1 - do iatom = 1, natoms(i_fixed) - idatom = idatom + 1 - write(30,"( tr2,a3,tr2,3(tr2,f14.6) )") ele(idatom), (coor(idatom,k),k=1,3) - end do - end if - end do - close(30) - end if - - ! write the output as a MOLDY file - - if(moldy) then - open(30,file=xyzout,status='unknown') - ! For square moldy boxes, this must be the side dimensions of the box - sxmin = 1.d30 - symin = 1.d30 - szmin = 1.d30 - sxmax = -1.d30 - symax = -1.d30 - szmax = -1.d30 - do irest = 1, nrest - if(ityperest(irest).eq.2) then - sxmin = dmin1(restpars(irest,1),sxmin) - symin = dmin1(restpars(irest,2),symin) - szmin = dmin1(restpars(irest,3),szmin) - sxmax = dmax1(restpars(irest,4)+restpars(irest,1),sxmax) - symax = dmax1(restpars(irest,4)+restpars(irest,2),symax) - szmax = dmax1(restpars(irest,4)+restpars(irest,3),szmax) - else if(ityperest(irest).eq.3) then - sxmin = dmin1(restpars(irest,1),sxmin) - symin = dmin1(restpars(irest,2),symin) - szmin = dmin1(restpars(irest,3),szmin) - sxmax = dmax1(restpars(irest,4),sxmax) - symax = dmax1(restpars(irest,5),symax) - szmax = dmax1(restpars(irest,6),szmax) - else - write(*,*) ' WARNING: The first line of the moldy output' - write(*,*) ' file contains the size of the sides of the' - write(*,*) ' paralelogram that defines the system. ' - write(*,*) ' The numbers printed may not be correct in ' - write(*,*) ' this case because regions other than cubes ' - write(*,*) ' or boxes were used. ' - sxmin = dmin1(sxmin,sizemin(1)) - symin = dmin1(symin,sizemin(2)) - szmin = dmin1(szmin,sizemin(3)) - sxmax = dmax1(sxmax,sizemax(1)) - symax = dmax1(symax,sizemax(2)) - szmax = dmax1(szmax,sizemax(3)) - end if - end do - xlength = sxmax - sxmin - ylength = symax - symin - zlength = szmax - szmin - write(30,"( 3(tr1,f12.6),' 90 90 90 1 1 1 ' )") xlength, ylength, zlength - ilubar = 0 - ilugan = ntotmol*3 - i_not_fixed = 0 - i_fixed = ntype - do itype = 1, ntfix - if ( .not. fixedoninput(itype) ) then - i_not_fixed = i_not_fixed + 1 - record = name(i_not_fixed) - do imol = 1, nmols(i_not_fixed) - xbar = (x(ilubar+1) - sxmin) / xlength - ybar = (x(ilubar+2) - symin) / ylength - zbar = (x(ilubar+3) - szmin) / zlength - beta = x(ilugan+1) - gama = x(ilugan+2) - teta = x(ilugan+3) - call eulerrmat(beta,gama,teta,v1,v2,v3) - - ! Computing cartesian coordinates and quaternions - - xxyx = 0.d0 - xxyy = 0.d0 - xxyz = 0.d0 - xyyx = 0.d0 - xyyy = 0.d0 - xyyz = 0.d0 - xzyx = 0.d0 - xzyy = 0.d0 - xzyz = 0.d0 - idatom = idfirst(i_not_fixed) - 1 - do iatom = 1, natoms(i_not_fixed) - idatom = idatom + 1 - xq = coor(idatom, 1)*v1(1) & - + coor(idatom, 2)*v2(1) & - + coor(idatom, 3)*v3(1) - yq = coor(idatom, 1)*v1(2) & - + coor(idatom, 2)*v2(2) & - + coor(idatom, 3)*v3(2) - zq = coor(idatom, 1)*v1(3) & - + coor(idatom, 2)*v2(3) & - + coor(idatom, 3)*v3(3) - - ! Recovering quaternions for molecule imol - - xxyx = xxyx + xq * coor(idatom,1) * amass(idatom) - xxyy = xxyy + xq * coor(idatom,2) * amass(idatom) - xxyz = xxyz + xq * coor(idatom,3) * amass(idatom) - xyyx = xyyx + yq * coor(idatom,1) * amass(idatom) - xyyy = xyyy + yq * coor(idatom,2) * amass(idatom) - xyyz = xyyz + yq * coor(idatom,3) * amass(idatom) - xzyx = xzyx + zq * coor(idatom,1) * amass(idatom) - xzyy = xzyy + zq * coor(idatom,2) * amass(idatom) - xzyz = xzyz + zq * coor(idatom,3) * amass(idatom) - end do - - tens(1,1) = xxyx + xyyy + xzyz - tens(1,2) = xzyy - xyyz - tens(2,2) = xxyx - xyyy - xzyz - tens(1,3) = xxyz - xzyx - tens(2,3) = xxyy + xyyx - tens(3,3) = xyyy - xzyz - xxyx - tens(1,4) = xyyx - xxyy - tens(2,4) = xzyx + xxyz - tens(3,4) = xyyz + xzyy - tens(4,4) = xzyz - xxyx - xyyy - nr = 16 - call jacobi (tens, 4, 4, dv, v, nr) - q0 = v(1,4) - q1 = v(2,4) - q2 = v(3,4) - q3 = v(4,4) - record = name(i_not_fixed) - xbar = dmin1(0.999999d0,xbar) - ybar = dmin1(0.999999d0,ybar) - zbar = dmin1(0.999999d0,zbar) - write(30,"( a10,tr1,7(f12.6) )") trim(adjustl(record)), xbar, ybar, zbar, & - q0, q1, q2, q3 - ilugan = ilugan + 3 - ilubar = ilubar + 3 - end do - else - i_fixed = i_fixed + 1 - idatom = idfirst(i_fixed) - 1 - - ! Getting the specified position of the molecule - - do irest = 1, nrest - if(irestline(irest).gt.linestrut(i_fixed,1).and.& - irestline(irest).lt.linestrut(i_fixed,2)) then - xcm = restpars(irest,1) - sxmin - ycm = restpars(irest,2) - symin - zcm = restpars(irest,3) - szmin - beta = -restpars(irest,4) - gama = -restpars(irest,5) - teta = -restpars(irest,6) - end if - end do - call eulerrmat(beta,gama,teta,v1,v2,v3) - - ! Computing cartesian coordinates and quaternions - - xxyx = 0.d0 - xxyy = 0.d0 - xxyz = 0.d0 - xyyx = 0.d0 - xyyy = 0.d0 - xyyz = 0.d0 - xzyx = 0.d0 - xzyy = 0.d0 - xzyz = 0.d0 - idatom = idfirst(i_fixed) - 1 - do iatom = 1, natoms(i_fixed) - idatom = idatom + 1 - xtemp = coor(idatom,1) - xcm - ytemp = coor(idatom,2) - ycm - ztemp = coor(idatom,3) - zcm - xq = xtemp*v1(1) + ytemp*v2(1) + ztemp*v3(1) - yq = xtemp*v1(2) + ytemp*v2(2) + ztemp*v3(2) - zq = xtemp*v1(3) + ytemp*v2(3) + ztemp*v3(3) - xxyx = xxyx + xtemp * xq * amass(idatom) - xxyy = xxyy + xtemp * yq * amass(idatom) - xxyz = xxyz + xtemp * zq * amass(idatom) - xyyx = xyyx + ytemp * xq * amass(idatom) - xyyy = xyyy + ytemp * yq * amass(idatom) - xyyz = xyyz + ytemp * zq * amass(idatom) - xzyx = xzyx + ztemp * xq * amass(idatom) - xzyy = xzyy + ztemp * yq * amass(idatom) - xzyz = xzyz + ztemp * zq * amass(idatom) - end do - tens(1,1) = xxyx + xyyy + xzyz - tens(1,2) = xzyy - xyyz - tens(2,2) = xxyx - xyyy - xzyz - tens(1,3) = xxyz - xzyx - tens(2,3) = xxyy + xyyx - tens(3,3) = xyyy - xzyz - xxyx - tens(1,4) = xyyx - xxyy - tens(2,4) = xzyx + xxyz - tens(3,4) = xyyz + xzyy - tens(4,4) = xzyz - xxyx - xyyy - nr = 16 - call jacobi (tens, 4, 4, dv, v, nr) - q0 = v(1,4) - q1 = v(2,4) - q2 = v(3,4) - q3 = v(4,4) - xcm = xcm / xlength - ycm = ycm / ylength - zcm = zcm / zlength - record = name(itype) - xcm = dmin1(0.999999d0,xcm) - ycm = dmin1(0.999999d0,ycm) - zcm = dmin1(0.999999d0,zcm) - write(30,"( a10,tr1,7(f12.6) )") trim(adjustl(record)),& - xcm, ycm, zcm, q0, q1, q2, q3 - end if - end do - close(30) - end if - - ! write the output as pdb file - - if(pdb) then - pdb_atom_line = "( t1,a6,t7,a5,t12,a10,t22,a1,t23,& - &i4,t27,a1,t31,f8.3,t39,f8.3,t47,& - &f8.3,t55,a26 )" - crd_format='(2I10,2X,A8,2X,A8,3F20.10,2X,A8,2X,A8,F20.10)' - - open(30,file=xyzout,status='unknown') - if ( crd ) then - open(40,file=crdfile,status='unknown') - write(40,'("* TITLE ", a64,/& - &"* Packmol generated CHARMM CRD File",/& - &"* Home-Page:",/& - &"* http://m3g.iqm.unicamp.br/packmol",/& - &"* ")') title - write(40,'(i10,2x,a)') ntotat,'EXT' - end if - - write(30,"( & - &'HEADER ',/& - &'TITLE ', a64,/& - &'REMARK Packmol generated pdb file ',/& - &'REMARK Home-Page: ',& - &'http://m3g.iqm.unicamp.br/packmol',/,& - &'REMARK' )" ) title - - if(add_box_sides) then - write(30,"( 'CRYST1',t7,f9.2,t16,f9.2,t25,f9.2,& - &t34,f7.2,t41,f7.2,t48,f7.2,& - &t56,'P 1 1' )") & - sizemax(1)-sizemin(1) + add_sides_fix,& - sizemax(2)-sizemin(2) + add_sides_fix,& - sizemax(3)-sizemin(3) + add_sides_fix,& - 90., 90., 90. - end if - - ilubar = 0 - ilugan = ntotmol*3 - icart = 0 - i_ref_atom = 0 - iimol = 0 - ichain = 0 - i_not_fixed = 0 - i_fixed = ntype - irescount = 1 - do itype = 1, ntfix - if ( .not. fixedoninput(itype) ) then - i_not_fixed = i_not_fixed + 1 - - ! Counting the number of residues of this molecule - - open(15,file=pdbfile(i_not_fixed),status='old') - ifres = 0 - do - read(15,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - if ( record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM' ) then - read(record(23:26),*,iostat=ioerr) imark - if ( ioerr /= 0 ) then - record = pdbfile(i_not_fixed) - write(*,*) ' ERROR: Failed reading residue number ',& - ' from PDB file: ', trim(adjustl(record)) - write(*,*) ' Residue numbers are integers that must',& - ' be between columns 23 and 26. ' - write(*,*) ' Other characters within these columns',& - ' will cause input/output errors. ' - write(*,*) ' Standard PDB format specifications can',& - ' be found at: ' - write(*,*) ' www.rcsb.org/pdb ' - stop exit_code_input_error - end if - if ( ifres .eq. 0 ) ifres = imark - ilres = imark - end if - end do - nres = ilres - ifres + 1 - - do irec = 1, strl - record(irec:irec) = ' ' - end do - - mol: do imol = 1, nmols(i_not_fixed) - iimol = iimol + 1 - - if( chain(i_not_fixed) == "#" ) then - if(imol.eq.1.or.mod(imol,9999).eq.1) then - ichain = ichain + 1 - if( changechains(i_not_fixed) ) then - call chainc(ichain,odd_chain) - ichain = ichain + 1 - call chainc(ichain,even_chain) - else - call chainc(ichain,even_chain) - odd_chain = even_chain - end if - end if - if ( mod(imol,2) == 0 ) write_chain = even_chain - if ( mod(imol,2) /= 0 ) write_chain = odd_chain - else - write_chain = chain(i_not_fixed) - end if - - xbar = x(ilubar+1) - ybar = x(ilubar+2) - zbar = x(ilubar+3) - beta = x(ilugan+1) - gama = x(ilugan+2) - teta = x(ilugan+3) - - call eulerrmat(beta,gama,teta,v1,v2,v3) - - rewind(15) - idatom = idfirst(i_not_fixed) - 1 - iatom = 0 - do while(iatom.lt.natoms(i_not_fixed)) - - read(15,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit mol - if(record(1:4).ne.'ATOM'.and.record(1:6).ne.'HETATM') then - cycle - end if - - iatom = iatom + 1 - icart = icart + 1 - idatom = idatom + 1 - i_ref_atom = i_ref_atom + 1 - call compcart(icart,xbar,ybar,zbar,& - coor(idatom,1),coor(idatom,2),& - coor(idatom,3),v1,v2,v3) - - ! Setting residue numbers for this molecule - - imark = 0 - read(record(23:26),*,iostat=ioerr) imark - if ( ioerr /= 0 ) imark = 1 - if(resnumbers(i_not_fixed).eq.0) then - iires = mod(imol,9999) - ciires = mod(imol,99999999) - else if(resnumbers(i_not_fixed).eq.1) then - iires = imark - ciires = imark - else if(resnumbers(i_not_fixed).eq.2) then - iires = mod(imark-ifres+irescount,9999) - ciires = mod(imark-ifres+irescount,99999999) - else if(resnumbers(i_not_fixed).eq.3) then - iires = mod(iimol,9999) - ciires = mod(iimol,99999999) - end if - if(iires.eq.0) iires = 9999 - if(ciires.eq.0) ciires = 99999999 - - ! Writing output line - - if(record(1:4).eq.'ATOM') then - tmp_i5hex = i5hex(i_ref_atom) - write(30,pdb_atom_line) "ATOM ", tmp_i5hex,& - record(12:21), write_chain, iires,& - record(27:27),& - (xcart(icart,k), k = 1, 3),& - record(55:80) - end if - if(record(1:6).eq.'HETATM') then - tmp_i5hex = i5hex(i_ref_atom) - write(30,pdb_atom_line) "HETATM", tmp_i5hex,& - record(12:21), write_chain, iires,& - record(27:27),& - (xcart(icart,k), k = 1, 3),& - record(55:80) - end if - - if ( crd ) then - write(crdires,'(I8)') ciires - crdires = adjustl(crdires) - crdresn = trim(adjustl(record(18:21))) - crdsegi = crdresn - if (len(trim(adjustl(segid(i_not_fixed))))/=0) crdsegi = trim(adjustl(segid(i_not_fixed))) - atmname = adjustl(record(13:16)) - write(40,crd_format) i_ref_atom, ciires,crdresn, atmname, & - (xcart(icart,k), k = 1, 3), crdsegi,& - crdires, 0. - end if - - end do - irescount = irescount + nres - ilugan = ilugan + 3 - ilubar = ilubar + 3 - - if(add_amber_ter) write(30,"('TER')") - end do mol - close(15) - - ! If fixed molecule on input: - else - i_fixed = i_fixed + 1 - - ! Counting the number of residues of this molecule - - open(15,file=pdbfile(i_fixed),status='old') - ifres = 0 - do - read(15,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - if ( record(1:4).eq.'ATOM'.or.record(1:6).eq.'HETATM' ) then - read(record(23:26),*,iostat=ioerr) imark - if ( ioerr /= 0 ) then - record = pdbfile(i_not_fixed) - write(*,*) ' ERROR: Failed reading residue number ',& - ' from PDB file: ', trim(adjustl(record)) - write(*,*) ' Residue numbers are integers that must',& - ' be between columns 23 and 26. ' - write(*,*) ' Other characters within these columns',& - ' will cause input/output errors. ' - write(*,*) ' Standard PDB format specifications can',& - ' be found at: ' - write(*,*) ' www.rcsb.org/pdb ' - stop exit_code_input_error - end if - if ( ifres .eq. 0 ) ifres = imark - ilres = imark - end if - end do - nres = ilres - ifres + 1 - - iimol = iimol + 1 - idatom = idfirst(i_fixed) - 1 - - rewind(15) - iatom = 0 - do while(iatom.lt.natoms(i_fixed)) - - read(15,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - if(record(1:4).ne.'ATOM'.and.record(1:6).ne.'HETATM') then - if(amber_ter_preserve .and. record(1:3).eq.'TER') then - write(30,"('TER')") - end if - !write(30,"( a80 )") record(1:80) - cycle - end if - - iatom = iatom + 1 - idatom = idatom + 1 - i_ref_atom = i_ref_atom + 1 - - read(record(23:26),*) imark - if(resnumbers(i_fixed).eq.0) then - iires = 1 - ciires = 1 - else if(resnumbers(i_fixed).eq.1) then - iires = imark - ciires = imark - else if(resnumbers(i_fixed).eq.2) then - iires = mod(imark-ifres+irescount,9999) - ciires = mod(imark-ifres+irescount,99999999) - else if(resnumbers(i_fixed).eq.3) then - iires = mod(iimol,9999) - ciires = mod(iimol,99999999) - end if - - if ( chain(i_fixed) == "#" ) then - write_chain = record(22:22) - else - write_chain = chain(i_fixed) - end if - - if(record(1:4).eq.'ATOM') then - tmp_i5hex = i5hex(i_ref_atom) - write(30,pdb_atom_line) "ATOM ", tmp_i5hex,& - record(12:21), write_chain, iires,& - record(27:27),& - (coor(idatom,k), k = 1, 3),& - record(55:80) - end if - if(record(1:6).eq.'HETATM') then - tmp_i5hex = i5hex(i_ref_atom) - write(30,pdb_atom_line) "HETATM", tmp_i5hex,& - record(12:21), write_chain, iires,& - record(27:27),& - (coor(idatom,k), k = 1, 3),& - record(55:80) - end if - - if ( crd ) then - write(crdires,'(I8)') ciires - crdires = adjustl(crdires) - crdresn = trim(adjustl(record(18:21))) - crdsegi = crdresn - if (len(trim(adjustl(segid(i_fixed))))/=0) crdsegi = trim(adjustl(segid(i_fixed))) - atmname = adjustl(record(13:16)) - write(40,crd_format) i_ref_atom, iires,crdresn, atmname, & - (xcart(icart,k), k = 1, 3), crdsegi,& - crdires, 0. - end if - - end do - irescount = irescount + nres - close(15) - if(add_amber_ter) write(30,"('TER')") - end if - end do - ! - ! Write connectivity if available - ! - i_ref_atom = 0 - i_not_fixed = 0 - i_fixed = ntype - do itype = 1, ntfix - if ( .not. fixedoninput(itype) ) then - i_not_fixed = i_not_fixed + 1 - idatom = idfirst(i_not_fixed) - 1 - do imol = 1, nmols(i_not_fixed) - iatom = 0 - ifirst_mol = i_ref_atom + 1 - do while(iatom.lt.natoms(i_not_fixed)) - iatom = iatom + 1 - i_ref_atom = i_ref_atom + 1 - if(connect(itype)) then - call write_connect(30,idatom,iatom,ifirst_mol) - end if - end do - end do - close(15) - ! If fixed molecule on input: - else - i_fixed = i_fixed + 1 - idatom = idfirst(i_fixed) - 1 - iatom = 0 - ifirst_mol = i_ref_atom + 1 - idatom = idfirst(i_fixed) - 1 - do while(iatom.lt.natoms(i_fixed)) - iatom = iatom + 1 - i_ref_atom = i_ref_atom + 1 - if(connect(itype)) then - call write_connect(30,idatom,iatom,ifirst_mol) - end if - end do - end if - end do - write(30,"('END')") - close(30) - if ( crd ) close(40) - end if - - ! Write the output (tinker xyz file) - - if(tinker) then - - tinker_atom_line = "( i7,tr2,a3,3(tr2,f10.6),9(tr2,i7) )" - - open(30, file = xyzout,status='unknown') - - write(30,"( i6,tr2,a64 )") ntotat, title - - ilubar = 0 - ilugan = ntotmol*3 - icart = 0 - i_ref_atom = 0 - i_not_fixed = 0 - i_fixed = ntype - - do itype = 1, ntfix - - if ( .not. fixedoninput(itype) ) then - i_not_fixed = i_not_fixed + 1 - - do imol = 1, nmols(i_not_fixed) - - xbar = x(ilubar+1) - ybar = x(ilubar+2) - zbar = x(ilubar+3) - beta = x(ilugan+1) - gama = x(ilugan+2) - teta = x(ilugan+3) - - call eulerrmat(beta,gama,teta,v1,v2,v3) - - idatom = idfirst(i_not_fixed) - 1 - do iatom = 1, natoms(i_not_fixed) - icart = icart + 1 - idatom = idatom + 1 - call compcart(icart,xbar,ybar,zbar,& - coor(idatom,1),coor(idatom,2),& - coor(idatom,3),& - v1,v2,v3) - - ntcon(1) = nconnect(idatom,1) - do k = 2, maxcon(idatom) - ntcon(k) = nconnect(idatom,k) + i_ref_atom - end do - write(30,tinker_atom_line) i_ref_atom+iatom,& - ele(idatom), (xcart(icart, k), k = 1, 3),& - (ntcon(k), k = 1, maxcon(idatom)) - end do - i_ref_atom = i_ref_atom + natoms(i_not_fixed) - - ilugan = ilugan + 3 - ilubar = ilubar + 3 - - end do - - else - - i_fixed = i_fixed + 1 - idatom = idfirst(i_fixed) - 1 - do iatom = 1, natoms(i_fixed) - idatom = idatom + 1 - ntcon(1) = nconnect(idatom,1) - do k = 2, maxcon(idatom) - ntcon(k) = nconnect(idatom,k) + i_ref_atom - end do - write(30,tinker_atom_line) i_ref_atom+iatom, ele(idatom),& - (coor(idatom,k), k = 1, 3),& - (ntcon(k), k = 1, maxcon(idatom)) - end do - i_ref_atom = i_ref_atom + natoms(i_fixed) - - end if - - end do - close(30) - end if - - return -end subroutine output - -function i5hex(i) - implicit none - integer :: i - character(len=5) i5hex - if(i <= 99999) then - write(i5hex,"(i5)") i - else - write(i5hex,"(z5)") i - end if -end - -subroutine write_connect(iostream,idatom,iatom,ifirst) - use sizes - use input - implicit none - integer :: i, j, iostream, iatom, idatom, ifirst - character(len=5) :: i5hex, tmp_i5hex - character(len=strl) :: str - if(maxcon(iatom+idatom) == 0) return - str = "CONECT" - j=7 - tmp_i5hex = i5hex(iatom+ifirst-1) - write(str(j:j+4),"(a5)") tmp_i5hex - do i = 1, maxcon(iatom+idatom) - j = j + 5 - tmp_i5hex = i5hex(nconnect(iatom+idatom,i)+ifirst-1) - write(str(j:j+4),"(a5)") tmp_i5hex - end do - write(iostream,"(a)") trim(adjustl(str)) -end subroutine write_connect - - - - - - diff --git a/packmol.f90 b/packmol.f90 deleted file mode 100644 index f1d8558..0000000 --- a/packmol.f90 +++ /dev/null @@ -1,954 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -!----------------------------------------------------------------------------- -! -! http://m3g.iqm.unicamp.br/packmol -! -! Usage (see the page above for further information): -! -! ./packmol < inputfile.inp -! -! References: -! -! L. Martinez, R. Andrade, E. G. Birgin, J. M. Martinez, -! PACKMOL: A package for building initial configurations for -! molecular dynamics simulations, J. Comp. Chem. 30:2157-2164, 2009. -! -! J. M. Martinez and L. Martinez, -! Packing optimization for the automated generation of complex -! system's initial configurations for molcular dynamics and -! docking. J. Comp. Chem. 24:819-825, 2003. -! -! This version of Packmol uses the optimization method GENCAN which -! is a part of the TANGO (Trustable Algorithms for Nonlinear General -! Optimization) project. -! Reference: -! E. G. Birgin, J. M. Martinez, Comp. Opt. Appl. 23:101-125, 2002. -! http://www.ime.usp.br/~egbirgin/tango -! -! - -program packmol - - use exit_codes - use sizes - use compute_data - use input - use usegencan - use flashsort - use swaptypemod - use ahestetic - implicit none - - integer :: itype, irest, idatom, iatom - integer :: idtemp, nmtemp, natemp, input_itypetemp - integer :: linesttmp1, linesttmp2, jtype - integer :: ntmol, n, iftype, icart, imol, iicart, iline_atoms - integer :: i, iline, iiatom, iat, iirest, iratcount, ival - integer :: loop - integer :: resntemp, nloop_tmp - integer :: ioerr - integer :: maxmove_tmp - integer :: exit_code = 0 - - double precision, allocatable :: x(:), xprint(:) ! (nn) - double precision :: v1(3),v2(3),v3(3) - double precision :: radscale, value - double precision :: cmx, cmy, cmz, beta, gama, teta - double precision :: xtemp, ytemp, ztemp - double precision :: fx, bestf, flast, fprint, all_type_fx - double precision :: fimp, fimprov - double precision, parameter :: pi=4.d0*datan(1.d0) - - real :: etime, tarray(2), time0 - - character(len=strl) :: record, restart_from_temp, restart_to_temp - character(len=strl) :: xyzfile - character(len=1) :: chain_tmp - - logical :: fixtmp - logical :: rests - logical :: movebadprint - logical :: changechains_tmp, connecttmp - - logical, allocatable :: fixed(:) ! ntype - - ! Printing title - - call title() - - ! Set dimensions of all arrays - - call setsizes() - - ! Allocate local array - - allocate(fixed(ntype),x(nn),xprint(nn),xfull(nn)) - - ! Start time computation - - time0 = etime(tarray) - - ! Reading input file - - call getinp() - - ! Put molecules in their center of mass - - call cenmass() - - ! Writting some input data - - write(*,*) ' Total number of atoms: ', ntotat - - ! Put fixed molecules in the specified position - - do itype = 1, ntype - fixed(itype) = .false. - end do - - do irest = 1, nrest - if(ityperest(irest).eq.1) then - do itype = 1, ntype - if(irestline(irest).gt.linestrut(itype,1).and.& - irestline(irest).lt.linestrut(itype,2)) then - cmx = restpars(irest,1) - cmy = restpars(irest,2) - cmz = restpars(irest,3) - beta = restpars(irest,4) - gama = restpars(irest,5) - teta = restpars(irest,6) - - ! Compute rotation matrix from euler angles - - call eulerfixed(beta,gama,teta,v1,v2,v3) - - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - xtemp = coor(idatom,1)*v1(1) & - + coor(idatom,2)*v2(1) & - + coor(idatom,3)*v3(1) - ytemp = coor(idatom,1)*v1(2) & - + coor(idatom,2)*v2(2) & - + coor(idatom,3)*v3(2) - ztemp = coor(idatom,1)*v1(3) & - + coor(idatom,2)*v2(3) & - + coor(idatom,3)*v3(3) - coor(idatom, 1) = xtemp + cmx - coor(idatom, 2) = ytemp + cmy - coor(idatom, 3) = ztemp + cmz - end do - record = name(itype) - write(*,*) ' Molecule ',trim(adjustl(record)),'(',itype,') will be fixed.' - fixed(itype) = .true. - if(nmols(itype).gt.1) then - write(*,*)' ERROR: Cannot set number > 1',' for fixed molecules. ' - write(*,*) ' Structure: ', itype,': ', trim(adjustl(record)) - stop exit_code_input_error - end if - if ( restart_from(itype) /= 'none' .or. & - restart_to(itype) /= 'none' ) then - write(*,*) ' ERROR: Restart files cannot be used for fixed molecules. ' - write(*,*) ' Structure: ', itype,': ', trim(adjustl(record)) - stop exit_code_input_error - end if - end if - end do - end if - end do - - ! Reseting parameters for removing the fixed molecules - ! fix is the logical variable that informs that there are fixed molecules - - fix = .false. - ntemp = 0 - do itype = 1, ntype - - ! input_itype and fixedoninput vectors are used only to preserve the - ! order of input in the output files - - input_itype(itype) = itype - if(fixed(itype)) then - fix = .true. - fixedoninput(itype) = .true. - else - ntemp = ntemp + 1 - fixedoninput(itype) = .false. - end if - end do - ntfix = ntype - ntype = ntemp - - do i = 1, ntfix - ntype - do itype = 1, ntfix - 1 - if(fixed(itype)) then - record = name(itype) - restart_to_temp = restart_to(itype) - restart_from_temp = restart_from(itype) - fixtmp = fixed(itype) - idtemp = idfirst(itype) - input_itypetemp = input_itype(itype) - nmtemp = nmols(itype) - natemp = natoms(itype) - resntemp = resnumbers(itype) - connecttmp = connect(itype) - if(pdb) xyzfile = pdbfile(itype) - linesttmp1 = linestrut(itype,1) - linesttmp2 = linestrut(itype,2) - changechains_tmp = changechains(itype) - maxmove_tmp = maxmove(itype) - chain_tmp = chain(itype) - nloop_tmp = nloop_type(itype) - jtype = itype + 1 - if(.not.fixed(jtype)) then - name(itype) = name(jtype) - name(jtype) = record(1:10) - restart_to(itype) = restart_to(jtype) - restart_to(jtype) = restart_to_temp - restart_from(itype) = restart_from(jtype) - restart_from(jtype) = restart_from_temp - idfirst(itype) = idfirst(jtype) - idfirst(jtype) = idtemp - input_itype(itype) = input_itype(jtype) - input_itype(jtype) = input_itypetemp - fixed(itype) = fixed(jtype) - fixed(jtype) = fixtmp - nmols(itype) = nmols(jtype) - nmols(jtype) = nmtemp - natoms(itype) = natoms(jtype) - natoms(jtype) = natemp - resnumbers(itype) = resnumbers(jtype) - resnumbers(jtype) = resntemp - connect(itype) = connect(jtype) - connect(jtype) = connecttmp - changechains(itype) = changechains(jtype) - changechains(jtype) = changechains_tmp - maxmove(itype) = maxmove(jtype) - maxmove(jtype) = maxmove_tmp - chain(itype) = chain(jtype) - chain(jtype) = chain_tmp - nloop_type(itype) = nloop_type(jtype) - nloop_type(jtype) = nloop_tmp - if(pdb) then - pdbfile(itype) = pdbfile(jtype) - pdbfile(jtype) = xyzfile - end if - linestrut(itype,1) = linestrut(jtype,1) - linestrut(itype,2) = linestrut(jtype,2) - linestrut(jtype,1) = linesttmp1 - linestrut(jtype,2) = linesttmp2 - end if - end if - end do - end do - - ! Computing the number of variables - ! - ! ntype: 1...ntype (counter for the number of free structures) - ! - ! ntfix: 1...ntype...ntfix (counter for the total number of structures) - ! - - ntmol = 0 - do itype = 1, ntfix - ntmol = ntmol + nmols(itype) - end do - ntotmol = 0 - do itype = 1, ntype - ntotmol = ntotmol + nmols(itype) - end do - n = ntotmol * 6 - write(*,*) ' Total number of molecules: ', ntmol - write(*,*) ' Number of fixed molecules: ', ntmol - ntotmol - write(*,*) ' Number of free molecules: ', ntotmol - write(*,*) ' Number of variables: ', n - - ! Computing the total number of fixed atoms - - natfix = 0 - if(fix) then - do iftype = ntype + 1, ntfix - natfix = natfix + natoms(iftype) - end do - end if - write(*,*) ' Total number of fixed atoms: ', natfix - - ! Setting the array that contains the restrictions per atom - - icart = 0 - do itype = 1, ntype - rests = .false. - do imol = 1, nmols(itype) - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - icart = icart + 1 - idatom = idatom + 1 - nratom(icart) = 0 - iratcount = 0 - do i = 1, mrperatom - iratom(icart,i) = 0 - end do - iline = linestrut(itype,1) - do while(iline.lt.linestrut(itype,2)) - iline = iline + 1 - if(keyword(iline,1).eq.'atoms') then - iiatom = -1 - do iat = 2, maxkeywords - read(keyword(iline,iat),*,iostat=ioerr) iiatom - if ( ioerr /= 0 ) then - if ( iiatom == -1 ) then - write(*,*) ' ERROR: Could not read atom selection for type: ', itype - stop exit_code_input_error - else - exit - end if - end if - if ( iiatom > natoms(itype) ) then - write(*,*) ' ERROR: atom selection with index greater than number of ' - write(*,*) ' atoms in structure ', itype - stop exit_code_input_error - end if - if(iatom.eq.iiatom) exit - end do - do while(keyword(iline,1).ne.'end'.and.& - keyword(iline,2).ne.'atoms') - iline = iline + 1 - if(iatom.eq.iiatom) then - if(keyword(iline,1).eq.'inside'.or.& - keyword(iline,1).eq.'outside'.or.& - keyword(iline,1).eq.'over'.or.& - keyword(iline,1).eq.'above'.or.& - keyword(iline,1).eq.'below') then - nratom(icart) = nratom(icart) + 1 - iratcount = iratcount + 1 - do irest = 1, nrest - if(irestline(irest).eq.iline) iirest = irest - end do - iratom(icart,iratcount) = iirest - end if - end if - end do - iline = iline - 1 - else if(keyword(iline,1).eq.'inside'.or.& - keyword(iline,1).eq.'outside'.or.& - keyword(iline,1).eq.'over'.or.& - keyword(iline,1).eq.'above'.or.& - keyword(iline,1).eq.'below') then - nratom(icart) = nratom(icart) + 1 - iratcount = iratcount + 1 - do irest = 1, nrest - if(irestline(irest).eq.iline) iirest = irest - end do - iratom(icart,iratcount) = iirest - end if - end do - if(nratom(icart).gt.0) rests = .true. - end do - if(.not.rests) then - write(*,*) ' ERROR: Some molecule has no geometrical',& - ' restriction defined: nothing to do.' - stop exit_code_input_error - end if - end do - end do - - ! Read the constraints to rotations about axis, if set - - do itype = 1, ntype - constrain_rot(itype,1) = .false. - constrain_rot(itype,2) = .false. - constrain_rot(itype,3) = .false. - iline = linestrut(itype,1) - do while(iline.lt.linestrut(itype,2)) - iline = iline + 1 - if(keyword(iline,1).eq.'constrain_rotation') then - if(iline.gt.linestrut(itype,1).and.& - iline.lt.linestrut(itype,2)) then - - ! Note that for movable molecules, teta is a rotation on the x-axis, - ! gama is a rotation on the z-axis, - ! beta is a rotation on the y-axis - ! (see eulerrmat routine) - - if(keyword(iline,2).eq.'x') then - constrain_rot(itype,3) = .true. - read(keyword(iline,3),*) rot_bound(itype,3,1) - read(keyword(iline,4),*) rot_bound(itype,3,2) - rot_bound(itype,3,1) = rot_bound(itype,3,1)*pi/180.d0 - rot_bound(itype,3,2) = rot_bound(itype,3,2)*pi/180.d0 - - write(*,*) ' Rotations about x axis of molecules of ',& - ' type ', itype, ' will be constrained. ' - end if - if(keyword(iline,2).eq.'y') then - constrain_rot(itype,1) = .true. - read(keyword(iline,3),*) rot_bound(itype,1,1) - read(keyword(iline,4),*) rot_bound(itype,1,2) - rot_bound(itype,1,1) = rot_bound(itype,1,1)*pi/180.d0 - rot_bound(itype,1,2) = rot_bound(itype,1,2)*pi/180.d0 - - write(*,*) ' Rotations about y axis of molecules of ',& - ' type ', itype, ' will be constrained. ' - end if - if(keyword(iline,2).eq.'z') then - constrain_rot(itype,2) = .true. - read(keyword(iline,3),*) rot_bound(itype,2,1) - read(keyword(iline,4),*) rot_bound(itype,2,2) - rot_bound(itype,2,1) = rot_bound(itype,2,1)*pi/180.d0 - rot_bound(itype,2,2) = rot_bound(itype,2,2)*pi/180.d0 - - write(*,*) ' Rotations about z axis of molecules of ',& - ' type ', itype, ' will be constrained. ' - end if - if ( keyword(iline,2) /= 'x' .and. & - keyword(iline,2) /= 'y' .and. & - keyword(iline,2) /= 'z' ) then - write(*,*) ' ERROR: constrain_rotation option not properly defined (not x, y, or z) ' - stop exit_code_input_error - end if - end if - end if - end do - end do - - ! Setting the vector that contains the default tolerances - - do i = 1, ntotat - radius(i) = dism/2.d0 - fscale(i) = 1.d0 - if ( use_short_tol ) then - use_short_radius(i) = .true. - else - use_short_radius(i) = .false. - end if - short_radius(i) = short_tol_dist/2.d0 - short_radius_scale(i) = short_tol_scale - end do - - ! Setting the radius defined for atoms of each molecule, - ! but not atom-specific, first - - icart = 0 - do itype = 1, ntfix - iline = linestrut(itype,1) - iline_atoms = 0 - do while( iline <= linestrut(itype,2) ) - if ( keyword(iline,1) == "atoms" ) then - iline_atoms = iline - iline = iline + 1 - cycle - end if - if ( keyword(iline,1) == "end" .and. & - keyword(iline,2) == "atoms" ) then - iline_atoms = 0 - iline = iline + 1 - cycle - end if - if ( iline_atoms == 0 ) then - ! - ! Read radius - ! - if ( keyword(iline,1) == "radius" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read radius from keyword. ' - stop exit_code_input_error - end if - iicart = icart - do imol = 1, nmols(itype) - do iatom = 1, natoms(itype) - iicart = iicart + 1 - radius(iicart) = value - end do - end do - end if - ! - ! Read minimum-distance function scale - ! - if ( keyword(iline,1) == "fscale" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read fscale value from keyword. ' - stop exit_code_input_error - end if - iicart = icart - do imol = 1, nmols(itype) - do iatom = 1, natoms(itype) - iicart = iicart + 1 - fscale(iicart) = value - end do - end do - end if - ! - ! Read short_radius - ! - if ( keyword(iline,1) == "short_radius" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read short_radius value from keyword. ' - stop exit_code_input_error - end if - iicart = icart - do imol = 1, nmols(itype) - do iatom = 1, natoms(itype) - iicart = iicart + 1 - short_radius(iicart) = value - use_short_radius(iicart) = .true. - end do - end do - end if - ! - ! Read short_radius scale - ! - if ( keyword(iline,1) == "short_radius_scale" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read short_radius_scale value from keyword. ' - stop exit_code_input_error - end if - iicart = icart - do imol = 1, nmols(itype) - do iatom = 1, natoms(itype) - iicart = iicart + 1 - short_radius_scale(iicart) = value - use_short_radius(iicart) = .true. - end do - end do - end if - end if - iline = iline + 1 - end do - icart = icart + nmols(itype)*natoms(itype) - end do - - ! If some radius was defined using atom-specific definitions, overwrite - ! the general radius defined for the molecule - - icart = 0 - do itype = 1, ntfix - iline = linestrut(itype,1) - iline_atoms = 0 - do while( iline <= linestrut(itype,2) ) - if ( keyword(iline,1) == "atoms" ) then - iline_atoms = iline - iline = iline + 1 - cycle - end if - if ( keyword(iline,1) == "end" .and. & - keyword(iline,2) == "atoms" ) then - iline_atoms = 0 - iline = iline + 1 - cycle - end if - if ( iline_atoms /= 0 ) then - ! - ! Read atom specific radius - ! - if ( keyword(iline,1) == "radius" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read radius from keyword. ' - stop exit_code_input_error - end if - ival = 2 - do - read(keyword(iline_atoms,ival),*,iostat=ioerr) iat - if ( ioerr /= 0 ) exit - if ( iat > natoms(itype) ) then - write(*,*) ' ERROR: atom selection with index greater than number of ' - write(*,*) ' atoms in structure ', itype - stop exit_code_input_error - end if - radius(icart+iat) = value - ival = ival + 1 - end do - end if - ! - ! Read atom specific function scale - ! - if ( keyword(iline,1) == "fscale" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read fscale value from keyword. ' - stop exit_code_input_error - end if - ival = 2 - do - read(keyword(iline_atoms,ival),*,iostat=ioerr) iat - if ( ioerr /= 0 ) exit - if ( iat > natoms(itype) ) then - write(*,*) ' ERROR: atom selection with index greater than number of ' - write(*,*) ' atoms in structure ', itype - stop exit_code_input_error - end if - fscale(icart+iat) = value - ival = ival + 1 - end do - end if - ! - ! Read atom specific short radius - ! - if ( keyword(iline,1) == "short_radius" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read short_radius value from keyword. ' - stop exit_code_input_error - end if - ival = 2 - do - read(keyword(iline_atoms,ival),*,iostat=ioerr) iat - if ( ioerr /= 0 ) exit - if ( iat > natoms(itype) ) then - write(*,*) ' ERROR: atom selection with index greater than number of ' - write(*,*) ' atoms in structure ', itype - stop exit_code_input_error - end if - short_radius(icart+iat) = value - use_short_radius(icart+iat) = .true. - ival = ival + 1 - end do - end if - ! - ! Read atom specific short radius function scale - ! - if ( keyword(iline,1) == "short_radius_scale" ) then - read(keyword(iline,2),*,iostat=ioerr) value - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Could not read short_radius_scale value from keyword. ' - stop exit_code_input_error - end if - ival = 2 - do - read(keyword(iline_atoms,ival),*,iostat=ioerr) iat - if ( ioerr /= 0 ) exit - if ( iat > natoms(itype) ) then - write(*,*) ' ERROR: atom selection with index greater than number of ' - write(*,*) ' atoms in structure ', itype - stop exit_code_input_error - end if - short_radius_scale(icart+iat) = value - use_short_radius(icart+iat) = .true. - ival = ival + 1 - end do - end if - end if - iline = iline + 1 - end do - iicart = icart - icart = icart + natoms(itype) - do imol = 2, nmols(itype) - do iatom = 1, natoms(itype) - icart = icart + 1 - radius(icart) = radius(iicart+iatom) - fscale(icart) = fscale(iicart+iatom) - short_radius(icart) = short_radius(iicart+iatom) - short_radius_scale(icart) = short_radius_scale(iicart+iatom) - use_short_radius(icart) = use_short_radius(iicart+iatom) - end do - end do - end do - - ! Check if the short radii were set correctly, if the case - - ioerr = 0 - do i = 1, ntotat - if ( use_short_radius(i) ) then - if ( short_radius(i) >= radius(i) ) then - write(*,*) ' ERROR: The short radius must be smaller than the default radius. ' - write(*,*) ' (the default radius is one half of the default tolerance).' - stop exit_code_input_error - end if - end if - end do - - ! If there are no variables (only fixed molecules, stop) - - if(n.eq.0) then - call output(n,x) - write(*,dash1_line) - write(*,*) ' There are only fixed molecules, therefore there is nothing to do. ' - write(*,*) ' The output file contains the fixed molecules in the desired positions. ' - write(*,dash1_line) - write(*,*) ' Wrote output file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - write(*,dash1_line) - stop exit_code_input_error - end if - - ! - ! (Re)setting parameters and building initial point - ! - - call initial(n,x) - - ! Computing the energy at the initial point - - radscale = 1.d0 - do i = 1, ntotat - radius_ini(i) = radius(i) - end do - call computef(n,x,all_type_fx) - write(*,*) ' Objective function at initial point: ', all_type_fx - fprint = all_type_fx - do i = 1, n - xprint(i) = x(i) - end do - - ! Stop if only checking the initial approximation - - if(check) then - call output(n,x) - write(*,*) ' Wrote initial point to output file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - stop - end if - - ! - ! Main loop: first pack types of molecules separately, then - ! pack all molecules together - ! - - call swaptype(n,x,itype,0) ! Save all-molecule vector data - itype = 0 - main : do while(itype <= ntype) - itype = itype + 1 - if ( packall ) itype = ntype + 1 - - ! Use larger tolerance than required to improve separation - - radscale = discale - do i = 1, ntotat - radius(i) = discale*radius_ini(i) - end do - - ! Set vectors for specific or all-molecule packing - - if ( itype <= ntype ) then - call swaptype(n,x,itype,1) ! Set vectors to pack only this type of molecule - else - call swaptype(n,x,itype,3) ! Restore all-molecule vectors - end if - - ! Print titles - - write(*,hash3_line) - if ( itype <= ntype ) then - write(*,*) ' Packing molecules of type: ', input_itype(itype) - else - write(*,*) ' Packing all molecules together ' - end if - write(*,hash3_line) - - ! Checking if first approximation is a solution - - call computef(n,x,fx) - - if ( fdist < precision .and. frest < precision ) then - - write(*,*) - write(*,*) ' Initial approximation is a solution. Nothing to do. ' - write(*,*) - call swaptype(n,x,itype,3) ! Restore all-molecule vectors - call output(n,x) - if( itype == ntype + 1 ) then - write(*,*) ' Solution written to file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - else - write(*,*) ' Current point written to file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - end if - call writesuccess(itype,fdist,frest,fx) - - ! Otherwise, pack the molecules - - else - - loop = -1 - - ! Initializing parameters relative to the improvement of the function - fimp = 1.d99 - fimprov = fimp - do i = 1, ntotat - radiuswork(i) = radius(i) - radius(i) = radius_ini(i) - end do - call computef(n,x,fx) - do i = 1, ntotat - radius(i) = radiuswork(i) - end do - bestf = fx - flast = fx - - gencanloop : do while(loop.lt.nloop) - loop = loop + 1 - - ! Moving bad molecules - if(radscale == 1.d0 .and. fimp.le.10.d0) then - movebadprint = .true. - call movebad(n,x,fx,movebadprint) - flast = fx - end if - - - write(*,dash3_line) - write(*,*) ' Starting GENCAN loop: ', loop - write(*,*) ' Scaling radii by: ', radscale - write(*,*) - - ! CALL GENCAN - - write(*,prog1_line) - call pgencan(n,x,fx) - - ! - ! Compute the statistics of the last optimization loop - ! - - ! Use the user-specified radii for statistics - - do i = 1, ntotat - radiuswork(i) = radius(i) - radius(i) = radius_ini(i) - end do - call computef(n,x,fx) - - if(bestf.gt.0.d0) fimprov = -100.d0 * (fx - bestf) / bestf - if(bestf.eq.0.d0) fimprov = 100.d0 - if(flast.gt.0.d0) fimp = -100.d0 * (fx - flast) / flast - if(flast.eq.0.d0) fimp = 100.d0 - fimp = dmin1(99.99d0,dmax1(-99.99d0,fimp)) - fimprov = dmin1(99.99d0,dmax1(-99.99d0,fimprov)) - - write(*,"(/& - &' Function value from last GENCAN loop: f = ', e10.5, /& - &' Best function value before: f = ', e10.5, /& - &' Improvement from best function value: ', f8.2, ' %',/& - &' Improvement from last loop: ', f8.2, ' %', /& - &' Maximum violation of target distance: ', f12.6, /& - &' Maximum violation of the constraints: ', e10.5 & - &)") fx, bestf, fimprov, fimp, fdist, frest - flast = fx - - ! - ! Analysis of final loop packing and output data - ! - - if ( itype <= ntype ) then - - ! Save best function value for this packing - - if ( fx < bestf ) bestf = fx - - ! Check if this point is a solution - - call swaptype(n,x,itype,2) ! Save this type current point - ! If the solution was found for this type - if( fdist < precision .and. frest < precision ) then - call swaptype(n,x,itype,3) ! Restore all molecule vectors - call output(n,x) - write(*,*) ' Current structure written to file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - call writesuccess(itype,fdist,frest,fx) - exit gencanloop - end if - - ! Compute and report function value for all-type packing - - call swaptype(n,x,itype,3) ! Restore all molecule vectors - call computef(n,x,all_type_fx) - write(*,"(' All-type function value: ', e10.5 )") all_type_fx - - else - - call computef(n,x,fx) - all_type_fx = fx - if ( fx < bestf ) bestf = fx - ! If solution was found for all system - if ( fdist < precision .and. frest < precision ) then - call output(n,x) - call writesuccess(itype,fdist,frest,fx) - write(*,*) ' Solution written to file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - write(*,dash3_line) - exit main - end if - - end if - write(*,dash3_line) - - ! If this is the best structure so far - if( mod(loop+1,writeout) == 0 .and. all_type_fx < fprint ) then - call output(n,x) - write(*,*) ' Current solution written to file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - fprint = all_type_fx - do i = 1, n - xprint(i) = x(i) - end do - - ! If the user required printing even bad structures - else if ( mod(loop+1,writeout) == 0 .and. writebad ) then - call output(n,x) - write(*,*) ' Writing current (perhaps bad) structure to file: ', trim(adjustl(xyzout)) - if ( crd ) write(*,*) ' ... and to CRD file: ', trim(adjustl(crdfile)) - end if - - ! Restore vector for packing this type of molecule, if the case - - if ( itype <= ntype ) then - call swaptype(n,x,itype,0) ! Reset type vectors - call swaptype(n,x,itype,1) ! Set vector for molecules of this type - call computef(n,x,fx) - end if - - ! Restore the working radii - - do i = 1, ntotat - radius(i) = radiuswork(i) - end do - if ( radscale > 1.d0 ) then - if( ( fdist < precision .and. fimp < 10.d0 ) .or. & - fimp < 2.d0 ) then - radscale = dmax1(0.9*radscale,1.d0) - do i = 1, ntotat - radius(i) = dmax1(radius_ini(i),0.9d0*radius(i)) - end do - end if - end if - - if(loop.eq.nloop) then - if ( itype .eq. ntype+1 ) then - write(*,*)' STOP: Maximum number of GENCAN loops achieved.' - call checkpoint(n,xprint) - exit_code = exit_code_failed_to_converge - exit main - else - write(*,*)' Maximum number of GENCAN loops achieved.' - end if - end if - - end do gencanloop - - end if - - end do main - - write(*,*) ' Running time: ', etime(tarray) - time0,' seconds. ' - write(*,dash3_line) - write(*,*) - - ! Fortran < 2008 doesn't support non-constant exit codes - if (exit_code == 0) then - stop - elseif (exit_code == exit_code_failed_to_converge) then - stop exit_code_failed_to_converge - else - stop exit_code_general_error - end if - -end program packmol - diff --git a/pgencan.f90 b/pgencan.f90 deleted file mode 100644 index 3da6df3..0000000 --- a/pgencan.f90 +++ /dev/null @@ -1,98 +0,0 @@ -! -! Written by Ernesto G. Birgin, 2009-2011. -! Copyright (c) 2009-2018, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine pgencan: This is only a interface to set some -! parameters. What might be important here -! is the setup of the constraint_axis constraint. -! - -subroutine pgencan(n,x,fx) - - use sizes - use compute_data - use usegencan - implicit none - - double precision :: lambda(1), rho(1) - double precision :: epsgpsn,gpsupn,delmin - double precision :: x(n), fx - integer :: m,iprint,maxfc,ncomp,iter,fcnt,gcnt,cgcnt,inform - integer :: n, i - integer :: trtype1 - integer :: itype, imol - - ! Setup upper and lower bounds for variables. Usually there are none, - ! but one might want to restrict the rotation of the molecules in one - ! or more axis - - do i = 1,n/2 - l(i) = - 1.0d+20 - u(i) = 1.0d+20 - end do - i = n/2 - do itype = 1, ntype - do imol = 1, nmols(itype) - if ( constrain_rot(itype,1) ) then - l(i+1) = rot_bound(itype,1,1) - dabs(rot_bound(itype,1,2)) - u(i+1) = rot_bound(itype,1,1) + dabs(rot_bound(itype,1,2)) - else - l(i+1) = - 1.0d+20 - u(i+1) = 1.0d+20 - end if - if ( constrain_rot(itype,2) ) then - l(i+2) = rot_bound(itype,2,1) - dabs(rot_bound(itype,2,2)) - u(i+2) = rot_bound(itype,2,1) + dabs(rot_bound(itype,2,2)) - else - l(i+2) = - 1.0d+20 - u(i+2) = 1.0d+20 - end if - if ( constrain_rot(itype,3) ) then - l(i+3) = rot_bound(itype,3,1) - dabs(rot_bound(itype,3,2)) - u(i+3) = rot_bound(itype,3,1) + dabs(rot_bound(itype,3,2)) - else - l(i+3) = - 1.0d+20 - u(i+3) = 1.0d+20 - end if - i = i + 3 - end do - end do - - m = 0 - epsgpsn = 1.0d-06 - maxfc = 10 * maxit - if(init1) iprint = iprint1 - if(.not.init1) iprint = iprint2 - ncomp = 50 - delmin = 2.d0 - trtype1 = 1 - - call easygencan(n,x,l,u,m,lambda,rho,epsgpsn,maxit,maxfc,& - trtype1,iprint,ncomp,fx,g,gpsupn,iter,fcnt,& - gcnt,cgcnt,inform,wi,wd,delmin) - if( inform.ne.7 .and.(iprint1.gt.0 .or. iprint2.gt.0) ) write(*,*) - - return -end subroutine pgencan - -! -! Function that test convergence according to Packmol precision -! - -function packmolprecision(n,x) - use input, only : precision - use compute_data, only : fdist, frest - implicit none - integer :: n - double precision :: f, x(n) - logical :: packmolprecision - - call computef(n,x,f) - - packmolprecision = .false. - if ( fdist < precision .and. frest < precision ) then - packmolprecision = .true. - end if - -end function packmolprecision diff --git a/polartocart.f90 b/polartocart.f90 deleted file mode 100644 index 5007ff3..0000000 --- a/polartocart.f90 +++ /dev/null @@ -1,106 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine eulerrmat: Computes the rotation matrix from the -! Euler angles -! -! Note that: -! In this routine, beta is a rotation about the y-axis -! gama is a rotation about the z-axis -! teta is a rotation about the x-axis - -subroutine eulerrmat(beta,gama,teta,v1,v2,v3) - - implicit none - double precision :: beta, gama, teta - double precision :: cb, sb, cg, sg, ct, st - double precision :: v1(3), v2(3), v3(3) - - cb = dcos(beta) - sb = dsin(beta) - cg = dcos(gama) - sg = dsin(gama) - ct = dcos(teta) - st = dsin(teta) - - v1(1)=-sb * sg * ct + cb * cg - v1(2)=-sb * cg * ct - cb * sg - v1(3)= sb * st - - v2(1)= cb * sg * ct + sb * cg - v2(2)= cb * cg * ct - sb * sg - v2(3)=-cb * st - - v3(1)= sg * st - v3(2)= cg * st - v3(3)= ct - - return -end subroutine eulerrmat - -! -! Subroutine compcart: Compute cartesian coordinates using -! the center of mass, the canonical coordinates -! and the rotation matrix -! - -subroutine compcart(icart,xbar,ybar,zbar,& - xcoor,ycoor,zcoor,v1,v2,v3) - - use compute_data, only : xcart - implicit none - integer :: icart - double precision :: xbar, ybar, zbar - double precision :: xcoor, ycoor, zcoor - double precision :: v1(3), v2(3), v3(3) - - xcart(icart,1) = xbar + xcoor*v1(1) + ycoor*v2(1) + zcoor*v3(1) - xcart(icart,2) = ybar + xcoor*v1(2) + ycoor*v2(2) + zcoor*v3(2) - xcart(icart,3) = zbar + xcoor*v1(3) + ycoor*v2(3) + zcoor*v3(3) - - return -end subroutine compcart - -! -! Subroutine eulerfixed: This routine was added because it defines -! the rotation in the "human" way, an is thus used -! to set the position of the fixed molecules. -! That means: beta is a counterclockwise rotation around x axis. -! gama is a counterclockwise rotation around y axis. -! teta is a counterclockwise rotation around z axis. -! The other routine should better do this as well, but then we need to change -! all the derivative calculations, just for the sake of human interpretation -! of the rotation which, in that case, is not really important. Maybe some day. -! - -subroutine eulerfixed(beta,gama,teta,v1,v2,v3) - - implicit none - double precision :: beta, gama, teta - double precision :: c1, s1, c2, s2, c3, s3 - double precision :: v1(3), v2(3), v3(3) - - c1 = dcos(beta) - s1 = dsin(beta) - c2 = dcos(gama) - s2 = dsin(gama) - c3 = dcos(teta) - s3 = dsin(teta) - - v1(1) = c2*c3 - v1(2) = c1*s3 + c3*s1*s2 - v1(3) = s1*s3 - c1*c3*s2 - - v2(1) = -c2*s3 - v2(2) = c1*c3 - s1*s2*s3 - v2(3) = c1*s2*s3 + c3*s1 - - v3(1) = s2 - v3(2) = -c2*s1 - v3(3) = c1*c2 - - return -end subroutine eulerfixed - diff --git a/random.f90 b/random.f90 deleted file mode 100644 index 05beeac..0000000 --- a/random.f90 +++ /dev/null @@ -1,50 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! - -! -! Function that returns a real random number between 0. and 1. -! - -double precision function rnd() - - call random_number(rnd) - - return -end function rnd - -! -! Subroutine that initializes the random number generator given a seed -! - -subroutine init_random_number(iseed) - integer :: size - integer :: i, iseed - integer, allocatable :: seed(:) - call random_seed(size=size) - allocate(seed(size)) - do i = 1, size - seed(i) = i*iseed - end do - call random_seed(put=seed) - deallocate(seed) - return -end subroutine init_random_number - -! -! Subroutine that uses the date to create a random seed -! - -subroutine seed_from_time(seed) - - implicit none - integer :: seed, value(8) - character(len=10) :: b(3) - call date_and_time( b(1), b(2), b(3), value ) - seed = value(1)+value(2)+value(3)+value(4)+value(5)+value(6)+value(7)+value(8) - seed = seed + value(1)+value(2)+value(3)+value(4)+value(5)/100+value(6)*100+value(7)/10+value(8)*10 - -end subroutine seed_from_time - diff --git a/resetboxes.f90 b/resetboxes.f90 deleted file mode 100644 index 9598400..0000000 --- a/resetboxes.f90 +++ /dev/null @@ -1,30 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine resetboxes: Subroutine that resets the occupancy of -! linked cell boxes -! - -subroutine resetboxes() - - use sizes - use compute_data, only : latomfirst, latomfix, & - lboxfirst, lboxnext, hasfree - implicit none - integer :: i, j, k, ibox - - ! Reset data for boxes that contain fixed atom - - ibox = lboxfirst - do while( ibox > 0 ) - call ibox_to_ijk(ibox,i,j,k) - latomfirst(i,j,k) = latomfix(i,j,k) - hasfree(i,j,k) = .false. - ibox = lboxnext(ibox) - end do - lboxfirst = 0 - -end subroutine resetboxes - diff --git a/restmol.f90 b/restmol.f90 deleted file mode 100644 index 8466cb3..0000000 --- a/restmol.f90 +++ /dev/null @@ -1,86 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! subroutine restmol: either compute the restraint function -! value for a single molecule or solve -! the problem of puting this molecule -! in the restraint region -! - -subroutine restmol(itype,ilubar,n,x,fx,solve) - - use sizes - use compute_data - use usegencan - implicit none - - integer :: n, nsafe, ntotsafe, itype, i, ilubar, nmoltype, ip1, ip2 - double precision :: x(n), fx - logical :: solve, initsafe - - ! Saving global problem variables - - nsafe = n - ntotsafe = ntotmol - nmoltype = nmols(itype) - do i = 1, ntype - compsafe(i) = comptype(i) - end do - initsafe = init1 - - ! Preparing system to solve for this molecule - - n = 6 - ntotmol = 1 - nmols(itype) = 1 - xmol(1) = x(ilubar+1) - xmol(2) = x(ilubar+2) - xmol(3) = x(ilubar+3) - xmol(4) = x(ilubar+ntotsafe*3+1) - xmol(5) = x(ilubar+ntotsafe*3+2) - xmol(6) = x(ilubar+ntotsafe*3+3) - do i = 1, ntype - if(i.eq.itype) then - comptype(i) = .true. - else - comptype(i) = .false. - end if - end do - init1 = .true. - - ! If not going to solve the problem, compute energy and return - - if(.not.solve) then - call computef(n,xmol,fx) - ! Otherwise, put this molecule in its constraints - else - ip1 = iprint1 - ip2 = iprint2 - iprint1 = 0 - iprint2 = 0 - call pgencan(n,xmol,fx) - iprint1 = ip1 - iprint2 = ip2 - end if - - ! Restoring original problem data - - ntotmol = ntotsafe - n = nsafe - nmols(itype) = nmoltype - x(ilubar+1) = xmol(1) - x(ilubar+2) = xmol(2) - x(ilubar+3) = xmol(3) - x(ilubar+ntotmol*3+1) = xmol(4) - x(ilubar+ntotmol*3+2) = xmol(5) - x(ilubar+ntotmol*3+3) = xmol(6) - do i = 1, ntype - comptype(i) = compsafe(i) - end do - init1 = initsafe - - return -end subroutine restmol - diff --git a/setibox.f90 b/setibox.f90 deleted file mode 100644 index 36f9b94..0000000 --- a/setibox.f90 +++ /dev/null @@ -1,30 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine setibox: set box index for given coordinates -! - -subroutine setibox(x,y,z,sizemin,boxl,nboxes,iboxx,iboxy,iboxz) - - implicit none - double precision :: x, y, z, sizemin(3), boxl(3), xtemp, ytemp, ztemp - integer :: nboxes(3), iboxx, iboxy, iboxz - - xtemp = x - sizemin(1) - ytemp = y - sizemin(2) - ztemp = z - sizemin(3) - iboxx = int(xtemp/boxl(1)) + 1 - iboxy = int(ytemp/boxl(2)) + 1 - iboxz = int(ztemp/boxl(3)) + 1 - if(xtemp.le.0) iboxx = 1 - if(ytemp.le.0) iboxy = 1 - if(ztemp.le.0) iboxz = 1 - if(iboxx.gt.nboxes(1)) iboxx = nboxes(1) - if(iboxy.gt.nboxes(2)) iboxy = nboxes(2) - if(iboxz.gt.nboxes(3)) iboxz = nboxes(3) - - return -end subroutine setibox - diff --git a/setijk.f90 b/setijk.f90 deleted file mode 100644 index dbfc14e..0000000 --- a/setijk.f90 +++ /dev/null @@ -1,46 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutines that set the indexes of a three-dimensional array -! given the undimensional counter of the vector (for an array -! with dimensions (0:nboxes(1)+1,0:nboxes(2)+1,0:nboxes(3)+1), and -! vice-versa. -! - -subroutine ibox_to_ijk(ibox,i,j,k) - - use compute_data, only : nb2 - implicit none - integer :: ibox, i, j, k, iibox - - k = mod(ibox,nb2(3)) - if ( k == 0 ) k = nb2(3) - - iibox = ibox - k - iibox = iibox / nb2(3) + 1 - j = mod(iibox,nb2(2)) - if ( j == 0 ) j = nb2(2) - - iibox = iibox - j - iibox = iibox / nb2(2) + 1 - i = mod(iibox,nb2(1)) - if ( i == 0 ) i = nb2(1) - - k = k - 1 - j = j - 1 - i = i - 1 - -end subroutine ibox_to_ijk - -subroutine ijk_to_ibox(i,j,k,ibox) - - use compute_data, only : nb2 - implicit none - integer :: i, j, k, ibox - - ibox = i*nb2(2)*nb2(3) + j*nb2(3) + k + 1 - -end subroutine ijk_to_ibox - diff --git a/setsizes.f90 b/setsizes.f90 deleted file mode 100644 index 66c3335..0000000 --- a/setsizes.f90 +++ /dev/null @@ -1,364 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine that sets the sizes of all allocatable arrays -! - -subroutine setsizes() - - use exit_codes - use sizes - use compute_data - use input - use usegencan - use flashsort - - implicit none - integer :: i, ival, ilast, iline, itype - integer :: ioerr - integer :: strlength - character(len=strl) :: record, word, blank, alltospace - logical :: inside_structure - - ! Instructions on how to run packmol - - write(*,*) ' Packmol must be run with: packmol < inputfile.inp ' - write(*,*) - write(*,*) ' Userguide at: http://m3g.iqm.unicamp.br/packmol ' - write(*,*) - - ! Getting input lines from the input file - - write(*,*) ' Reading input file... (Control-C aborts)' - - do i = 1, strl - blank(i:i) = ' ' - end do - nlines = 0 - maxkeywords = 0 - ntype = 0 - do - read(5,str_format,iostat=ioerr) record - - ! Replace any strange blank character by spaces - record = alltospace(record) - - if ( ioerr /= 0 ) exit - - ! Remove comments - i = 0 - do while( i < strl ) - i = i + 1 - if ( record(i:i) == '#' ) exit - end do - i = i - 1 - if ( i > 0 ) then - record = record(1:i)//blank(i+1:strl) - else - cycle - end if - if ( strlength(record) < 1 ) cycle - record = trim(record) - - ! - ! Convert file name paths with spaces to single strings - ! - ! check for quotes and replace spaces by @ - call parse_spaces(record) - - ! Number of lines of the input file - - nlines = nlines + 1 - - ! Check the number of keywords in this line - - i = 0 - ival = 0 - do while(i < strl) - i = i + 1 - ilast = i - do while(record(i:i) > ' ' .and. i < strl) - i = i + 1 - end do - if(i > ilast) then - ival = ival + 1 - maxkeywords = max(maxkeywords,ival) - end if - end do - end do - rewind(5) - - allocate(inputfile(nlines),keyword(nlines,maxkeywords)) - - ! Read input to inputfile array - - iline = 0 - do - read(5,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - - ! Convert all strange blank characters to spaces - - record = alltospace(record) - call parse_spaces(record) - - ! Remove comments - - i = 0 - do while( i < strl ) - i = i + 1 - if ( record(i:i) == '#' ) exit - end do - i = i - 1 - if ( i > 0 ) then - record = record(1:i)//blank(i+1:strl) - else - cycle - end if - if ( strlength(record) < 1 ) cycle - - iline = iline + 1 - inputfile(iline) = record - end do - - ! Read all keywods into keyword array - - call getkeywords() - - ! Checking the filetype of coordinate files (default is pdb) - - tinker = .false. - pdb = .false. - xyz = .false. - moldy = .false. - fbins = dsqrt(3.d0) - do i = 1, nlines - if(keyword(i,1).eq.'filetype') then - if(keyword(i,2).eq.'tinker') tinker = .true. - if(keyword(i,2).eq.'pdb') pdb = .true. - if(keyword(i,2).eq.'xyz') xyz = .true. - if(keyword(i,2).eq.'moldy') moldy = .true. - end if - if(keyword(i,1).eq.'fbins') then - record = keyword(i,2) - read(record,*,iostat=ioerr) fbins - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Invalid value for fbins. ' - stop exit_code_input_error - end if - end if - end do - if(.not.pdb.and..not.tinker.and..not.xyz.and..not.moldy) then - pdb = .true. - write(*,*) - write(*,*)' WARNING: File type not (correctly?) specified, using PDB' - end if - - ! Getting the number of different types of molecules - - ntype = 0 - do iline = 1, nlines - if ( keyword(iline,1) == "structure" ) then - ntype = ntype + 1 - if ( keyword(iline,2) == "none" ) then - write(*,*) ' ERROR: structure without filename. ' - write(*,*) ' The syntax must be, for example: structure water.pdb ' - stop exit_code_input_error - end if - end if - end do - - allocate(nmols(ntype),natoms(ntype),idfirst(ntype),constrain_rot(ntype,3),& - rot_bound(ntype,3,2),dmax(ntype),& - cmxmin(ntype),cmymin(ntype),cmzmin(ntype),& - cmxmax(ntype),cmymax(ntype),cmzmax(ntype),& - comptype(ntype),compsafe(ntype),& - restart_from(0:ntype),restart_to(0:ntype),& - nloop_type(ntype),nloop0_type(ntype)) - - ! Reading the number of molecules of each type, and the number of atoms - ! of each molecule type - - itype = 0 - inside_structure = .false. - do iline = 1, nlines - if ( keyword(iline,1) == "structure" ) then - inside_structure = .true. - itype = itype + 1 - natoms(itype) = 0 - nmols(itype) = 0 - nloop_type(itype) = 0 - nloop0_type(itype) = 0 - - ! Read the number of atoms of this type of molecule - - open(10,file=keyword(iline,2),status='old',iostat=ioerr) - if( ioerr /= 0 ) call failopen(keyword(iline,2)) - if ( pdb ) then - do - read(10,str_format,iostat=ioerr) record - if ( ioerr /= 0 ) exit - if ( record(1:4) == "ATOM" .or. record(1:6) == "HETATM" ) then - natoms(itype) = natoms(itype) + 1 - end if - end do - end if - if ( tinker ) then - do - read(10,*,iostat=ioerr) i - if ( ioerr /= 0 ) cycle - natoms(itype) = i - exit - end do - end if - if ( xyz ) then - read(10,*,iostat=ioerr) i - if ( ioerr == 0 ) natoms(itype) = i - end if - if ( moldy ) then - read(10,*,iostat=ioerr) word, i - if ( ioerr == 0 ) natoms(itype) = i - end if - close(10) - if ( natoms(itype) == 0 ) then - write(*,*) ' ERROR: Could not read any atom from file: ', & - trim(adjustl(keyword(iline,2))) - end if - - end if - - if ( keyword(iline,1) == "end" .and. & - keyword(iline,2) == "structure" ) inside_structure = .false. - - ! Read number of molecules for each type - - if ( keyword(iline,1) == "number" ) then - read(keyword(iline,2),*,iostat=ioerr) nmols(itype) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Error reading number of molecules of type ', itype - stop exit_code_input_error - end if - if ( nmols(itype) < 1 ) then - write(*,*) ' ERROR: Number of molecules of type ', itype, ' set to less than 1 ' - stop exit_code_input_error - end if - end if - - ! Read the (optional) number of gencan loops for this molecule - - if ( keyword(iline,1) == "nloop" ) then - if ( inside_structure ) then - read(keyword(iline,2),*,iostat=ioerr) nloop_type(itype) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Error reading number of loops of type ', itype - stop exit_code_input_error - end if - if ( nloop_type(itype) < 1 ) then - write(*,*) ' ERROR: Number of loops of type ', itype, ' set to less than 1 ' - stop exit_code_input_error - end if - end if - end if - - ! Read the (optional) number of gencan loops for initial setup for this molecule - - if ( keyword(iline,1) == "nloop0" ) then - if ( inside_structure ) then - read(keyword(iline,2),*,iostat=ioerr) nloop0_type(itype) - if ( ioerr /= 0 ) then - write(*,*) ' ERROR: Error reading number of loops-0 of type ', itype - stop exit_code_input_error - end if - if ( nloop0_type(itype) < 1 ) then - write(*,*) ' ERROR: Number of loops-0 of type ', itype, ' set to less than 1 ' - stop exit_code_input_error - end if - end if - end if - - end do - do itype = 1, ntype - if ( nmols(itype) == 0 ) then - write(*,*) ' Warning: Number of molecules not set for type '& - ,itype,': assuming 1 ' - nmols(itype) = 1 - end if - end do - - ! Total number of atoms and molecules - - ntotat = 0 - ntotmol = 0 - do itype = 1, ntype - ntotat = ntotat + nmols(itype)*natoms(itype) - ntotmol = ntotmol + nmols(itype) - end do - - ! The number of variables of the problem - - nn = ntotmol*6 - - ! The number of bins of the linked cell method in each direction - - nbp = int((fbins*dble(ntotat))**(1.d0/3.d0)) + 1 - - ! Allocate arrays depending on nbp parameter - - allocate(latomfirst(0:nbp+1,0:nbp+1,0:nbp+1),& - latomfix(0:nbp+1,0:nbp+1,0:nbp+1),& - hasfree(0:nbp+1,0:nbp+1,0:nbp+1),& - lboxnext((nbp+2)**3)) - - ! Checking the total number of restrictions defined - - i = 0 - do iline = 1, nlines - if ( keyword(iline,1) == 'fixed' .or. & - keyword(iline,1) == 'inside' .or. & - keyword(iline,1) == 'outside' .or. & - keyword(iline,1) == 'over' .or. & - keyword(iline,1) == 'above' .or. & - keyword(iline,1) == 'below' .or. & - keyword(iline,1) == 'constrain_rotation' ) then - i = i + 1 - end if - end do - maxrest = i - mrperatom = i - - ! Allocate arrays depending on ntotat, nn, maxrest, and mrperatom - - allocate(nratom(ntotat),iratom(ntotat,mrperatom),ibmol(ntotat),& - ibtype(ntotat),xcart(ntotat,3),coor(ntotat,3),& - radius(ntotat),radius_ini(ntotat),fscale(ntotat),& - use_short_radius(ntotat), short_radius(ntotat), short_radius_scale(ntotat),& - gxcar(ntotat,3),& - latomnext(ntotat),& - fdist_atom(ntotat), frest_atom(ntotat),& - fmol(ntotat),radiuswork(ntotat),& - fixedatom(ntotat)) - allocate(ityperest(maxrest),restpars(maxrest,9)) - allocate(xmol(nn)) - - ! Allocate other arrays used for input and output data - - allocate(nconnect(ntotat,9),maxcon(ntotat),& - amass(ntotat),charge(ntotat),ele(ntotat)) - - allocate(irestline(maxrest),linestrut(ntype,2),resnumbers(ntype),& - input_itype(ntype),changechains(ntype),chain(ntype),& - fixedoninput(ntype),pdbfile(ntype),name(ntype),& - segid(ntype),maxmove(ntype),connect(ntype)) - - ! Allocate vectors for flashsort - - allocate(indflash(ntotat),lflash(ntotat)) - - ! Allocate arrays for GENCAN - - allocate(l(nn),u(nn),wd(8*nn),wi(nn),g(nn)) - -end subroutine setsizes - diff --git a/sizes.f90 b/sizes.f90 deleted file mode 100644 index 640b757..0000000 --- a/sizes.f90 +++ /dev/null @@ -1,31 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! -! sizes.i: Define the maximum dimensions of the problems -! -! maxrest: Maximum number of restrictions -! mrperatom: Maximum number of restrictions per atom -! maxtry: Number of tries for building the initial point -! nbp: Maximum number of boxes for fast function evaluation (nbp**3) -! nn: Maximum number of variables -! (at least the number of molecules*6) -! maxkeywords: Maximum number of keywords in input file -! - -module sizes - - integer :: maxrest - integer :: mrperatom - integer :: maxtry - integer :: nbp - integer :: nn - integer :: maxkeywords - - integer, parameter :: strl = 1000 - character(len=*), parameter :: str_format = "( a1000 )" - -end module sizes - diff --git a/strlength.f90 b/strlength.f90 deleted file mode 100644 index 301473c..0000000 --- a/strlength.f90 +++ /dev/null @@ -1,97 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Function that determines the length of a string (better than -! intrinsic "len" because considers tabs as empty characters) -! -function strlength(string) - - use sizes - implicit none - integer :: strlength - character(len=strl) :: string - logical empty_char - - strlength = strl - do while(empty_char(string(strlength:strlength))) - strlength = strlength - 1 - if ( strlength == 0 ) exit - end do - -end function strlength - -! -! Function that determines if a character is empty (empty, space, or tab) -! (nice suggestion from Ian Harvey -IanH0073- at github) -! - -function empty_char(ch) - character :: ch - logical empty_char - empty_char = .false. - if ( ch == '' .or. & - ch == achar(9) .or. & - ch == achar(32) ) then - empty_char = .true. - end if -end function empty_char - -! -! Function that replaces all non-space empty characters by spaces -! - -function alltospace(record) - - use sizes - implicit none - integer :: i - logical :: empty_char - character(len=strl) :: alltospace, record - - do i = 1, strl - if ( empty_char(record(i:i)) ) then - alltospace(i:i) = " " - else - alltospace(i:i) = record(i:i) - end if - end do - -end function alltospace - -subroutine parse_spaces(record) - use exit_codes - use input, only : forbidden_char - use sizes - implicit none - integer :: i, strlength - character(len=strl) :: record - ! Replace spaces within quotes by ~ - i = 0 - do while(i < strlength(record)) - i = i + 1 - if ( record(i:i) == '"' ) then - i = i + 1 - do while(record(i:i) /= '"') - i = i + 1 - if( i > strlength(record) ) then - write(*,*) ' ERROR: Could not find ending quotes in line: ', trim(record) - stop exit_code_input_error - end if - if(record(i:i) == " ") then - record(i:i) = forbidden_char - end if - end do - end if - end do - ! Replace spaces after \ by the forbidden_char and remove the \ - i = 0 - do while(i < strlength(record)-1) - i = i + 1 - if (record(i:i) == "\" .and. record(i+1:i+1) == " ") then - record(i:i) = forbidden_char - record = record(1:i)//record(i+2:strlength(record)) - end if - end do -end \ No newline at end of file diff --git a/swaptype.f90 b/swaptype.f90 deleted file mode 100644 index 8d11f70..0000000 --- a/swaptype.f90 +++ /dev/null @@ -1,89 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine that swaps indexes for packing molecules one at a time -! - -subroutine swaptype(n,x,itype,action) - - use sizes, only : nn - use compute_data, only : ntype, comptype, nmols, ntotmol - use input, only : nloop, nloop_all, nloop_type - use swaptypemod - use ahestetic - implicit none - integer ::n, itype, ilubar, ilugan, i, action - double precision :: x(nn) - - ! Save original data - - if ( action == 0 ) then - do i = 1, nn - xfull(i) = x(i) - end do - ntemp = n - ntottemp = ntotmol - end if - - ! Swapping data for packing this itype - - if ( action == 1 ) then - do i = 1, ntype - if(i == itype) then - comptype(i) = .true. - else - comptype(i) = .false. - end if - end do - n = nmols(itype) * 6 - ntotmol = nmols(itype) - nloop = nloop_type(itype) - ilubar = 0 - do i = 1, itype - 1 - ilubar = ilubar + nmols(i) * 3 - end do - ilubar = ilubar + 1 - ilugan = ntemp/2 + ilubar - do i = 1, n / 2 - x(i) = xfull(ilubar) - x(i+n/2) = xfull(ilugan) - ilubar = ilubar + 1 - ilugan = ilugan + 1 - end do - end if - - ! Save results for this type - - if ( action == 2 ) then - ilubar = 0 - do i = 1, itype - 1 - ilubar = ilubar + nmols(i)*3 - end do - ilubar = ilubar + 1 - ilugan = ntemp/2 + ilubar - do i = 1, n/2 - xfull(ilubar) = x(i) - xfull(ilugan) = x(i+n/2) - ilubar = ilubar + 1 - ilugan = ilugan + 1 - end do - end if - - ! Restore all-molecule vectors - - if ( action == 3 ) then - n = ntemp - ntotmol = ntottemp - nloop = nloop_all - do i = 1, n - x(i) = xfull(i) - end do - do i = 1, ntype - comptype(i) = .true. - end do - end if - -end subroutine swaptype - diff --git a/swaptypemod.f90 b/swaptypemod.f90 deleted file mode 100644 index d808659..0000000 --- a/swaptypemod.f90 +++ /dev/null @@ -1,16 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Module that contains the temporary data for swap molecules -! for individual packing -! - -module swaptypemod - - integer :: ntemp, ntottemp - double precision, allocatable :: xfull(:) ! (nn) - -end module swaptypemod - diff --git a/title.f90 b/title.f90 deleted file mode 100644 index 5625d6c..0000000 --- a/title.f90 +++ /dev/null @@ -1,19 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! - -! Routine to print the title - -subroutine title() - - use ahestetic - write(*,hash3_line) - write(*,"(' PACKMOL - Packing optimization for the automated generation of', /& - &' starting configurations for molecular dynamics simulations.', /& - &' ',/& - &t62,' Version 20.11.1 ')") - write(*,hash3_line) - -end subroutine title diff --git a/tobar.f90 b/tobar.f90 deleted file mode 100644 index 7ec66d5..0000000 --- a/tobar.f90 +++ /dev/null @@ -1,42 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! subroutine tobar: moves molecules to their baricentres -! - -subroutine tobar() - - use sizes - use compute_data, only : coor, ntype, natoms, idfirst - implicit none - integer :: idatom, itype, iatom - double precision :: xcm, ycm, zcm - - do itype = 1, ntype - idatom = idfirst(itype) - 1 - xcm = 0.d0 - ycm = 0.d0 - zcm = 0.d0 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - xcm = xcm + coor(idatom,1) - ycm = ycm + coor(idatom,2) - zcm = zcm + coor(idatom,3) - end do - xcm = xcm / natoms(itype) - ycm = ycm / natoms(itype) - zcm = zcm / natoms(itype) - idatom = idfirst(itype) - 1 - do iatom = 1, natoms(itype) - idatom = idatom + 1 - coor(idatom,1) = coor(idatom,1) - xcm - coor(idatom,2) = coor(idatom,2) - ycm - coor(idatom,3) = coor(idatom,3) - zcm - end do - end do - - return -end subroutine tobar - diff --git a/usegencan.f90 b/usegencan.f90 deleted file mode 100644 index b390d8d..0000000 --- a/usegencan.f90 +++ /dev/null @@ -1,18 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Optimization variables passed as common go pgencan - -module usegencan - - use sizes - implicit none - - integer :: maxit, iprint1, iprint2 - integer, allocatable :: wi(:) ! (nn) - double precision, allocatable :: l(:), u(:), g(:) ! (nn) - double precision, allocatable :: wd(:) ! (8*nn) - -end module usegencan diff --git a/writesuccess.f90 b/writesuccess.f90 deleted file mode 100644 index 4854c7c..0000000 --- a/writesuccess.f90 +++ /dev/null @@ -1,46 +0,0 @@ -! -! Written by Leandro Martínez, 2009-2011. -! Copyright (c) 2009-2018, Leandro Martínez, Jose Mario Martinez, -! Ernesto G. Birgin. -! -! Subroutine writesuccess -! -! Writes the success messages for good packings -! - -subroutine writesuccess(itype,fdist,frest,f) - - use input, only : input_itype - use compute_data, only : ntype - use ahestetic - implicit none - integer :: itype - double precision :: fdist, frest, f - - if(itype.le.ntype) then - write(*,dash1_line) - write(*,*)' Packing solved for molecules of type', input_itype(itype) - write(*,*)' Objective function value: ', f - write(*,*)' Maximum violation of target distance: ',fdist - write(*,*)' Max. constraint violation: ', frest - write(*,dash1_line) - else - write(*,hash3_line) - write(*,"(& - &t33, ' Success! ', /,& - &t14, ' Final objective function value: ', e10.5, /,& - &t14, ' Maximum violation of target distance: ', f10.6, /,& - &t14, ' Maximum violation of the constraints: ', e10.5 & - &)") f, fdist, frest - write(*,dash3_line) - write(*,"(& - &t14,' Please cite this work if Packmol was useful: ',/,/,& - &t11,' L. Martinez, R. Andrade, E. G. Birgin, J. M. Martinez, ',/,& - &t9,' PACKMOL: A package for building initial configurations for',/,& - &t19,' molecular dynamics simulations. ',/,& - &t10,' Journal of Computational Chemistry, 30:2157-2164,2009.' )") - write(*,hash3_line) - end if - -end subroutine writesuccess - From f28f071471f5d9b8afe3d53c1ca791b6ae634eb0 Mon Sep 17 00:00:00 2001 From: "Federico E. Benelli" Date: Wed, 21 Dec 2022 22:52:35 -0300 Subject: [PATCH 3/4] added fpm compatiblity --- gencan.f | 6006 ------------------------------------------------------ 1 file changed, 6006 deletions(-) delete mode 100644 gencan.f diff --git a/gencan.f b/gencan.f deleted file mode 100644 index 3f98f10..0000000 --- a/gencan.f +++ /dev/null @@ -1,6006 +0,0 @@ -C ***************************************************************** -C ***************************************************************** - - subroutine evalal(n,x,m,lambda,rho,f,flag) - -C This subroutine computes the objective function when GENCAN is -C being used stand-alone to solve a unique bound-constrained problem. -C When GENCAN is being used in an Augmented Lagrangian framework, -C this subroutine must compute the Augmented Lagrangian function. -C -C On Entry: -C -C n integer, -C number of variables, -C -C x double precision x(n), -C current point, -C -C m integer, -C number of constraints (equalities plus inequalities), -C -C lambda double precision lambdae(m), -C current estimation of the Lagrange multipliers, -C -C rho double precision rho(m) -C penalty parameters, -C -C NOTE: arguments m, lambda and rho are useful when GENCAN is being used -C for solving the box-constrained subproblems of an Augmented Lagrangian -C framework. When GENCAN is being used stand-alone for solving a bound- -C constrained problem, these arguments are dummy arguments. -C -C On Return -C -C f double precision, -C objective function value at x, -C -C flag integer -C 0 means "no errors", -C 1 means "some error occurs in the objective funtion evaluation". - - implicit none - -C SCALAR ARGUMENTS - integer flag,m,n - double precision f - -C ARRAY ARGUMENTS - double precision lambda(m),rho(m),x(n) - -C LOCAL SCALARS - - flag = 0 - - call computef(n,x,f) - - end - -C ***************************************************************** -C ***************************************************************** - - subroutine evalnal(n,x,m,lambda,rho,g,flag) - -C This subroutine computes the gradient of the objective function -C when GENCAN is being used stand-alone to solve a unique bound- -C constrained problem. When GENCAN is being used in an Augmented -C Lagrangian framework, this subroutine must compute the gradient of -C Augmented Lagrangian. -C -C On Entry: -C -C n integer, -C number of variables, -C -C x double precision x(n), -C current point, -C -C m integer, -C number of constraints (equalities plus inequalities), -C -C lambda double precision lambdae(m), -C current estimation of the Lagrange multipliers, -C -C rho double precision rho(m) -C penalty parameters, -C -C NOTE: arguments m, lambda and rho are useful when GENCAN is being used -C for solving the box-constrained subproblems of an Augmented Lagrangian -C framework. When GENCAN is being used stand-alone for solving a bound- -C constrained problem, these arguments are dummy arguments. -C -C On Return -C -C g double precision g(n), -C gradient of the objective function at x, -C -C flag integer -C 0 means "no errors", -C 1 means "some error occurs in the gradient evaluation". - - implicit none - -C SCALAR ARGUMENTS - integer flag,m,n - -C ARRAY ARGUMENTS - double precision g(n),lambda(m),rho(m),x(n) - -C LOCAL SCALARS - - flag = 0 - - call computeg(n,x,g) - - end - -C ***************************************************************** -C ***************************************************************** - -c Modified by L. Martinez (there was an error on the number of -c parameters when calling this subroutine). This subroutine does -c nothing. -c subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) - - subroutine evalhd(n) - -C This subroutine computes the product of the Hessian matrix times -C the input vector argument d. If GENCAN is being used stand-alone -C to solve a bound-constrained problem, the ''Hessian matrix'' must -C be the Hessian matrix of the objective function. On the other hand, -C if GENCAN is being used to solve the bound-constrained subproblems -C in an Augmented Lagrangian framework, the Hessian matrix must be -C the Hessian of the Augmented Lagrangian function. -C -C IMPORTANT: This subroutine does not need to be coded if the user -C prefers to approximate the Hessian-vector product by incremental -C quotients. In this case, it is enough to set the GENCAN input -C argument htvtype equal to 1 and an internal GENCAN subroutine will -C be used to compute the approximation. In fact, this is the default -C GENCAN option. See the GENCAN and EASYGENCAN arguments descriptions -C for details. -C -C On Entry: -C -C nind integer -C number of component of the Hessian-vector product that -C must be computed, -C -C ind integer ind(nind) -C the component that must be computed are ind(1)-th ... ind(nind)-th, -C -C n integer, -C number of variables, -C -C x double precision x(n), -C current point, -C -C m integer, -C number of constraints (equalities plus inequalities), -C -C lambda double precision lambdae(m), -C current estimation of the Lagrange multipliers, -C -C rho double precision rho(m) -C penalty parameters, -C -C d double precision d(n) -C vector of the Hessian-vector product. -C -C NOTE: arguments m, lambda and rho are useful when GENCAN is being used -C for solving the box-constrained subproblems of an Augmented Lagrangian -C framework. When GENCAN is being used stand-alone for solving a bound- -C constrained problem, these arguments are dummy arguments. -C -C On Return -C -C hd double precision g(n), -C Hessian-vector product, -C -C flag integer -C 0 means "no errors", -C 1 means "some error occurs in the gradient evaluation". - - implicit none - -C SCALAR ARGUMENTS -c integer flag,m,n,nind - integer n - -C ARRAY ARGUMENTS -c integer ind(nind) -c double precision d(n),hd(n),lambda(m),rho(m),x(n) - -c flag = - 1 - - end - -C************************************************************************** - -C Last update of EASYGENCAN: February 18th, 2005. - - subroutine easygencan(n,x,l,u,m,lambda,rho,epsgpsn,maxit,maxfc, - +trtype,iprint,ncomp,f,g,gpsupn,iter,fcnt,gcnt,cgcnt,inform,wi,wd, - +delmin) - - implicit none - -C SCALAR ARGUMENTS - integer cgcnt,fcnt,gcnt,m,maxfc,maxit,n,ncomp,inform,iprint,iter - double precision epsgpsn,f,gpsupn - -C ARRAY ARGUMENTS - integer wi(n) - double precision g(n),l(n),lambda(m),rho(m),u(n),wd(8*n),x(n) - -C This subroutine aims to simplify the use of GENCAN. For this -C purpose it gives values to most of the GENCAN arguments and -C leaves to the user those arguments which he/she may would like to -C set by him/herself. -C -C The arguments of EASYGENCAN are the input and output arguments of -C GENCAN that are supposed to be useful for a common user. The input -C arguments are mostly related to basic problem information, like -C dimension and bounds, and the initial point. There are also input -C arguments related to simple stopping criteria (like norm of the -C projected gradient, and maximum number of iterations and -C functional evaluations). There are also two input arguments -C related to control the amount of information written into the -C screen. The output arguments are related to information of the -C solution and some few performance measurements. Basically, on -C return, EASYGENCAN gives to the user the solution, the objective -C functional value and its gradient at the solution, Euclidian and -C sup-norm of the projected gradient at the solution, the number of -C iterations, functional and gradient evaluations, and Conjugate -C Gradient iterations used to reach the solution, and, finally, a -C flag that indicates the stopping criterion that was satisfied. -C -C All the other arguments of GENCAN are setted with its default -C values by EASYGENCAN. EASYGENCAN divides the arguments of GENCAN -C in two sets. Those that are related to the behaviour of GENCAN are -C declared as Fortran parameters (constants). The other arguments of -C GENCAN, most of them related to alternative stopping criteria, and -C that may depend of, for example, maxit, are declared as local -C variables of EASYGENCAN. -C -C GENCAN arguments that are defined as Fortran parameters in this -C subroutine are GENCAN arguments that should not be modified by a -C common user. They are arguments that modify the behaviour of -C GENCAN and whos values were selected because they are classical -C values in some cases or because some numerical experiments seemed -C to indicate that they are the best choices. -C -C GENCAN arguments that are declared as local variables in this -C subroutine are GENCAN arguments that may be modified if, with -C their suggested values, GENCAN does not give the desired result. -C Most of them are related to Conjugate Gradients or to disabled -C stopping criteria that may be useful in bad-scaled problems or -C problems with not trustable derivatives. -C -C Finally, this subroutine declares as local variables some -C arguments of GENCAN which in fact are output arguments. Most of -C them are related to quantities that can be used for statistics -C related to the GENCAN performance, like number Spectral Projected -C Gradient iterations, Truncated Newton iterations, Conjugate -C Gradient iterations, etc. As we assume that this values are not -C useful for the common user, this subroutine throw all of them -C away. -C -C We describe below the meaning of the arguments of the EASYGENCAN -C subroutine. More detailed descriptions as well as the descriptions -C of all the other GENCAN arguments that are not arguments of -C EASYGENCAN are also described at the begining of the GENCAN -C subroutine. -C -C On entry: -C -C n integer -C number of variables -C -C x double precision x(n) -C initial estimation of the solution -C -C l double precision l(n) -C lower bounds on the variables -C -C u double precision u(n) -C upper bounds on the variables -C -C m integer -C lambda double precision lambda(m) -C rho double precision rho(m) -C These three parameters are not used nor modified by -C GENCAN and they are passed as arguments to the user- -C defined subroutines evalal and evalnal to compute the -C objective function and its gradient, respectively. -C Clearly, in an Augmented Lagrangian context, if GENCAN is -C being used to solve the bound-constrainted subproblems, m -C would be the number of constraints, lambda the Lagrange -C multipliers approximation and rho the penalty parameters -C -C epsgpsn double precision -C GENCAN stops declaring convergence if it finds a point -C whos projected gradient sup-norm is smaller than or equal -C to epsgpsn -C -C maxit integer -C GENCAN stops declaring ''maximum number of iteration -C achieved'' if the number of iterations exceeds maxit -C -C maxfc integer -C the same as before but with the number of functional -C evaluations -C -C iprint integer -C indicates the degree of details of the output generated -C by GENCAN. Setting iprint to a value smaller than 2 will -C make GENCAN to generate no output at all. An iprint value -C greater than or equal to 2 will generate information of -C every GENCAN iteration. An iprint value greater than or -C equal to 3 will also show information of the Conjugate -C Gradient iterations (used to compute the Truncated Newton -C direction) and also information related to the line -C search procedures in the Spectral Projected Gradient -C direction and the Truncated Newton direction. -C -C ncomp integer -C Sometimes, vectors like the current point x, the gradient -C of the objective function g, or the search directions -C (Spectral Projected Gradient direction or Truncated -C Newton direction), among other vector, are showed in the -C screen. In such cases, if the problem dimension is large, -C to show just a few elements of these vectors may be -C preferable. Argument ncomp can be used to indicate how -C many array elements must be displayed. -C -C wi integer wi(n) -C integer working space -C -C wd double precision wd(8*n) -C double precision working space -C -C On return: -C -C x double precision x(n) -C estimation of the solution -C -C f double precision -C objective function value at the solution -C -C g double precision g(n) -C gradient of the objective function at the solution -C -C gpsupn double precision -C sup-norm of the continuous projected gradient -C -C iter integer -C number of iterations used to reach the solution -C -C fcnt integer -C number of functional evaluations -C -C gcnt integer -C number of gradient evaluations -C -C cgcnt integer -C number of Conjugate Gradient iterations -C -C inform integer -C termination criteria. inform equal to 1 means that -C GENCAN converged with the sup-norm of the continuous -C projected gradient stopping criterion (inform equal to 0 -C means the same but with the Euclidian norm). Other -C positive values means that GENCAN stopped by a may be not -C successful stopping criteria. A negative value means that -C there was an error in the user-defined subroutines that -C computes the objective function (subroutine evalal), the -C gradient (subroutine evalnal), or the Hessian-vector -C product (subroutine evalhd). See the GENCAN description -C for more details. - -C HERE STARTS THE DESCRIPTION OF SOME GENCAN ARGUMENTS THAT ARE -C BEING SETTED INSIDE EASYGENCAN. THE FIRST SET OF ARGUMENTS ARE -C THOSE ARGUMENTS THAT WE WILL CALL ''CONSTANTS'' AND THAT, AS THEIR -C VALUES ALTER THE BEHAVIOUR OF GENCAN, SHOULD NOT BE MODIFIED BY A -C COMMON USER. - -C CONSTANTS FOR GENERAL USES - -C Steps: h = max( steabs, sterel * abs( x ) ) should be a number -C such that h is small ( relatively to x ) and x + h is different -C from x. So, h is something that can be used a a step for a finite -C differences approximation of a partial derivative relative to x. - -C Epsilons: something smaller than max( epsabs, epsrel * abs( x ) ) -C should be considered as ``zero'' when compared with x. It is used, -C for example, to detect that a step taken during a line search is -C too small. - -C Infinitys: infrel is a big number that may appear in the -C calculations. infabs is a number that should never be reached in -C the calculations and is used the represent ``infinite''. Detailed -C explanations of how are they used are rather cumbersome. - - double precision steabs,sterel,epsabs,epsrel,infabs,infrel - parameter ( steabs = 1.0d-10 ) - parameter ( sterel = 1.0d-07 ) - parameter ( epsabs = 1.0d-20 ) - parameter ( epsrel = 1.0d-10 ) - parameter ( infabs = 1.0d+99 ) - parameter ( infrel = 1.0d+20 ) - -C CONSTANTS FOR CLASSICAL LINE-SEARCH CONDITIONS - -C beta is the constant for the ''beta condition''. We use this -C condition to test whether is promising to extrapolate or not. - -C gamma is the constant for the sufficient decrease ''Armijo -C condition''. - -C theta is the constant for the ''angle condition''. - -C sigma1 and sigma2 are the constants for the safeguarding quadratic -C interpolations. We use them in a rather unusual way. Instead of -C discarding a new step anew if it does not belong to the interval -C [ sigma1 * aprev, sigma2 * aprev ], we discard it if it does not -C belong to the interval [ sigma1, sigma2 * aprev ]. In such a case -C we take something similar to ''anew = aprev / 2''. - - double precision beta,gamma,theta,sigma1,sigma2 - parameter ( beta = 0.5d0 ) - parameter ( gamma = 1.0d-04 ) - parameter ( theta = 1.0d-06 ) - parameter ( sigma1 = 0.1d0 ) - parameter ( sigma2 = 0.9d0 ) - -C CONSTANTS FOR SPECIFIC PROCEDURES (NOT SO CLASSICAL) - -C In line searches, when interpolating, the step may become so -C small that we should declare a line search failure indicating that -C direction may not be a descent direction. This decision is never -C take before doing at least mininterp interpolations. - -C In line searches, the beta condition (see above) may recommend to -C extrapolate. We never do more than maxextrap extrapolations. - -C In the line searches, when we need to interpolate and the result -C of the quadratic interpolation is rejected, the new step is -C computed as anew = aprev / nint. When the beta condition -C recommends to extrapolate, we compute anew = aprev * next. - -C When computing the Newton direction by Conjugate Gradients we -C never go further an artificial ''trust region''. This ''trust -C radius'' is never smaller than delmin. - -C In active set strategies, constants eta is used to decide whether -C the current face should be abandoned or not. In particular, the -C current face is abandoned when the norm of the internal to face -C component of the continuous projected gradient is smaller than -C ( 1 - eta ) times the norm of the continuous projected gradient. -C In this way, values of eta near 1 makes the method to work hard -C inside the faces and values of eta near 0 makes the method to -C abandon the faces very quickly. - -C We always use as a first step in a line search procedure along a -C first order direction the spectral steplength. This steplength -C must belong to the interval [lspgmi,lspgma]. - - integer maxextrap,mininterp - parameter ( maxextrap = 100 ) - parameter ( mininterp = 4 ) - - double precision nint,next,delmin,eta,lspgma,lspgmi - parameter ( nint = 2.0d0 ) - parameter ( next = 2.0d0 ) -c parameter ( delmin = 1.d4 ) - parameter ( eta = 0.9d0 ) - parameter ( lspgma = 1.0d+10 ) - parameter ( lspgmi = 1.0d-10 ) - -C DIMENSIONS FOR SOME WORKING SPACES - -C In non-monotone line searches, given p, the last p objective -C functional values must be stored. For this reason we declare a -C vector with pmax double precision elements. So p must be less than -C or equal to pmax. - -C Sometimes, is the problem is bad scaled, to request a small -C gradient norm at the solution may be inadequate. For this reason, -C a test to verify if this norm is not decreasing during maxitngp -C (MAXimum of ITerations with No Gradient Progress) consecutive -C iterations then we stop the method with a warning. As it is not -C expected a monotone decreasing of the gradient norm, again, the -C norm of the last maxitngp iterations must be saved. For this -C purpose, we declare a vector of tmax elements. So maxitngp must -C be less than or equal to tmax. - - integer tmax - parameter ( tmax = 10000 ) - -C HERE STARTS THE DESCRIPTION OF THE OTHER ARGUMENTS OF GENCAN BEING -C SETTED BY EASYGENCAN. THESE ARGUMENTS MAY BE MODIFIED BY A COMMON -C USER IF, WITH THEIR SUGGESTED VALUES, GENCAN DOES NOT GIVE THE -C EXPECTED RESULT. - -C GENCAN INPUT ARGUMENTS THAT WILL BE SETTED BELOW - - logical nearlyq - - integer cgmaxit,cgscre,gtype,htvtype,maxitnfp,maxitngp,maxitnqmp, - + trtype - - double precision cgepsf,cgepsi,cggpnf,delta0,epsgpen,epsnfp, - + epsnqmp,fmin - -C GENCAN OUTPUT ARGUMENTS THAT WILL BE DISCARDED - - integer spgfcnt,spgiter,tnexbcnt,tnexgcnt,tnexbfe,tnexgfe,tnfcnt, - + tnintcnt,tnintfe,tniter,tnstpcnt - - double precision gpeucn2 - -C GENCAN WORKING VECTORS (WHICH DIMENSION IS NOT RELATED TO THE -C PROBLEM DIMENSION) - - double precision lastgpns(tmax) - -C ARGUMENTS RELATED TO DERIVATIVES CALCULATIONS - -C gtype indicates in which way the gradient of the objective -C function will be computed. If the user have been implemented the -C user-supplied evalnal subroutine to compute the gradient of the -C objective function then gtype argument must be set to 0 (ZERO) and -C the user-supplied evalnal subroutine will be called by GENCAN any -C time the gradient would be required. -C -C The prototype of the evalnal subroutine must be: -C -C subroutine evalnal(n,x,m,lambda,rho,nal,flag) -C -C SCALAR ARGUMENTS -C integer n,m,flag -C -C ARRAY ARGUMENTS -C double precision x(n),lambda(m),rho(m),nal(n) -C -C ''Here must be written the subroutine body that calculates the -C n-dimensional gradient vector of the objective function -C evaluated at x and saves it in nal. It also must set flag to 0 -C (ZERO) if the gradient was successfully computed and to any -C other value if the gradient vector is not well defined at the -C required point x. If GENCAN is been used stand-alone to solve -C a unique bound-constrained problem then m, lambda and rho are -C dummy arguments. On the other hand, if GENCAN is been used in -C an Augmented Lagrangian framework then these arguments should -C be used for the number of constraints, the Lagrange -C multipliers approximation and the penalty parameters, -C respectively.'' -C -C end -C -C If, on the other hand, the user is not able to provide evalnal -C subroutine, gtype argument must be set to 1 (ONE). In this case, -C every time GENCAN needs to compute the gradient of the objective -C function, an internal subroutine that approximates it by finite- -C differences will be used (be aware that it maybe very time -C consuming). Moreover, note that the evalnal subroutine must still -C be present (with an empty body). - - gtype = 0 - -C htvtype indicates in which way the product of the Hessian of the -C objective function times an arbitrary vector will be computed. If -C the user has not been implemented the user-supplied evalhd -C subroutine to do this task then htvtype argument must be set to 1 -C (ONE). In this case an internal subroutine that approximates this -C product by incremental quotients will be used. Note that, even in -C this case, evalhd subroutine must be present (with an empty body). -C This is the default option and the empty-body subroutine follows: -C -C subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) -C -C SCALAR ARGUMENTS -C integer nind,n,m,flag -C -C ARRAY ARGUMENTS -C integer ind(nind) -C double precision d(n),hd(n),lambda(m),rho(m),x(n) -C -C flag = - 1 -C -C end -C -C If, on the other hand, the user prefers to implement his/her own -C evalhd subroutine then htvtype argument must be set to 0 (ZERO). -C In this case, the product of the Hessian times vector d (input -C argument of evalhd subroutine) must be saved in vector hd (output -C argument of evalhd subroutine). The other arguments description as -C well as some hints on how to implement your own evalhd subroutine -C can be found in the GENCAN arguments description. - -C When ALGENCAN uses GENCAN to solve the subproblems in the classical -C Augmented Lagrangian framework, ALGENCAN uses its own evalhd -C subroutine to overcome the lack of continuity of the second -C derivatives. So, when GENCAN is being used toghether with ALGENCAN, -C htvtype must be equal to 0 (ZERO). On the other hand, if GENCAN is -C being used stand-alone, just set htvtype equal to 1 (ONE) and add -C the empty-body subroutine described above. - - htvtype = 1 - -C ARGUMENTS RELATED TO STOPPING CRITERIA - -C Besides the stopping criterion related to the sup-norm of the -C continuous projected gradient, there is another stopping criterion -C related to its Euclidian norm. So, GENCAN stops the process if it -C finds a point at which the Euclidian norm of the continuous -C projected gradient is smaller than epsgpen. - - epsgpen = 0.0d0 - -C For an explanation of maxitngp see above the explanation of tmax -C in ''DIMENSIONS FOR SOME WORKING SPACES''. Just note that the -C value of maxitngp must be less than or equal to tmax. - - maxitngp = tmax - -C maxitnfp means MAXimum of allowed number of iterations with No -C Progress in the objective functional value. ''Progress'' from one -C iteration to the next one refers to ( fnew - fprev ). Since the -C begining of the algorithm we save the ''best progress'' and -C consider that there was no progress in an iteration if the -C progress of this iterations was smaller than epsnfp times the best -C progress. Finally, the algorithm stops if there was no progress -C during maxitnfp consecutive iterations. - - maxitnfp = maxit - epsnfp = 0.0d0 - -C There is a stopping criterion that stops the method if a point -C with a functional value smaller than fmin is found. The idea -C behind this stopping criterion is to stop the method if the -C objective function is not bounded from below. - - fmin = 1.0d-05 - -C ARGUMENTS RELATED TO CONJUGATE GRADIENTS - -C When computing the Truncated Newton direction by Conjugate -C Gradients there is something similar to a ''trust-region radius''. -C This trust radius is updated from iteration to iteration depending -C on the agreement of the objective function and its quadratic -C model. But an initial value for the trust radius is required. If -C the user has a good guess for this initial value then it should be -C passed to GENCAN using the delta0 arguments. On the other hand, if -C delta0 is set to -1, a default value depending on the norm of the -C current point will be used. - - delta0 = - 1.0d0 - delmin = 1.d-2 -c delta0 = delmin - -C The ''trust-region'' can be like a ball (using Euclidian norm) or -C like a box (using sup-norm). This choice can be made using trtype -C (TRust region TYPE) argument. trtype equal to 0 means Euclidian -C norm and trtype equal to 1 means sup-norm. - - trtype = 1 - -C When the method is far from the solution, it may be not useful to -C do a very large effort in computing the Truncated Newton direction -C precisely. To avoid it, a fixed maximum number of iterations for -C Conjugate Gradients can be given to GENCAN. If the user would like -C to choose this maximum number of iterations for Conjugate -C Gradient then it should use the cgmaxit arguments. On the other -C hand he/she prefers to leave this task to GENCAN then he/she -C should set cgmaxit to -1. - - cgmaxit = -1 - -C If the task of deciding the accuracy for computing the Truncated -C Newton direction is leaved to GENCAN then a default strategy based -C on increasing accuracies will be used. The proximity to the -C solution is estimated observing the norm of the projected gradient -C at the current point and locating it between that norm at the -C initial point and the expected value of that norm at the solution. -C Then the accuracy for the Truncated Newton direction of the -C current iteration will be computed taking a precision located in -C the same relative position with respect to two given values for -C the accuracies for the first and the last Truncated Newton -C direction calculations. These two accuracies (cgepsi and cgepsf, -C respectively) must be given by the user. Moreover, the expected -C value of the projected gradient norm at the solution (cggpnf) must -C also be given by the user who must indicate setting argument -C cgscre to 1 or 2 if that norm is the Euclidian or the sup-norm. - - cggpnf = max( 1.0d-04, max( epsgpen, epsgpsn ) ) - cgscre = 2 - cgepsi = 1.0d-01 - cgepsf = 1.0d-05 - -C The next two arguments are used for an alternative stopping -C criterion for Conjugate Gradients. Conjugate Gradients method is -C stopped if the quadratic model makes no progress during maxitnqmp -C (MAXimum of ITerations with No Quadratic Model Progress) -C consecutive iterations. In this context, ''no progress'' means -C that the progress is smaller than epsnqmp (EPSilon to measure the -C No Quadratic Model Progress) times the best progress obtained -C during the previous iterations. - - epsnqmp = 1.0d-04 - maxitnqmp = 5 - -C Depending on how much the objective function seems to be a -C quadratic, function, Conjugate Gradients may take different -C decision. So, if the objective function is a quadratic function or -C is very similar to a quadratic function then the nearlyq argument -C should be set to TRUE, else, it should be set to FALSE. However, -C the option with nearlyq equal TRUE never showed good results. -C Regarding this unexpected no good performance, rather recently it -C was found a bug that affected the behaviour of GENCAN just in this -C case (See the April 1st, 2003 modifications report at the end of -C this file). So, new experiments setting nearlyq equal TRUE should -C be made. - - nearlyq = .false. - -C FINALLY, CALL GENCAN - - call gencan(n,x,l,u,m,lambda,rho,epsgpen,epsgpsn,maxitnfp,epsnfp, - +maxitngp,fmin,maxit,maxfc,delta0,cgmaxit,cgscre,cggpnf,cgepsi, - +cgepsf,epsnqmp,maxitnqmp,nearlyq,nint,next,mininterp,maxextrap, - +gtype,htvtype,trtype,iprint,ncomp,f,g,gpeucn2,gpsupn,iter,fcnt, - +gcnt,cgcnt,spgiter,spgfcnt,tniter,tnfcnt,tnstpcnt,tnintcnt, - +tnexgcnt,tnexbcnt,tnintfe,tnexgfe,tnexbfe,inform,wd(1),wd(n+1), - +wd(2*n+1),wi,lastgpns,wd(3*n+1),eta,delmin,lspgma,lspgmi,theta, - +gamma,beta,sigma1,sigma2,sterel,steabs,epsrel,epsabs,infrel, - +infabs) - - end - -C ****************************************************************** -C ****************************************************************** - -C Last update of GENCAN or any of its dependencies: -C -C February 18th, 2005. -C -C See report of modifications at the end of this file. - - subroutine gencan(n,x,l,u,m,lambda,rho,epsgpen,epsgpsn,maxitnfp, - +epsnfp,maxitngp,fmin,maxit,maxfc,udelta0,ucgmaxit,cgscre,cggpnf, - +cgepsi,cgepsf,epsnqmp,maxitnqmp,nearlyq,nint,next,mininterp, - +maxextrap,gtype,htvtype,trtype,iprint,ncomp,f,g,gpeucn2,gpsupn, - +iter,fcnt,gcnt,cgcnt,spgiter,spgfcnt,tniter,tnfcnt,tnstpcnt, - +tnintcnt,tnexgcnt,tnexbcnt,tnintfe,tnexgfe,tnexbfe,inform,s,y,d, - +ind,lastgpns,w,eta,delmin,lspgma,lspgmi,theta,gamma,beta,sigma1, - +sigma2,sterel,steabs,epsrel,epsabs,infrel,infabs) - - implicit none - -C SCALAR ARGUMENTS - logical nearlyq - integer cgcnt,cgscre,fcnt,gcnt,gtype,htvtype,inform,iprint,iter,m, - + maxextrap,maxfc,maxit,maxitnfp,maxitngp,maxitnqmp, - + mininterp,n,ncomp,spgfcnt,spgiter,tnexbcnt,tnexbfe, - + tnexgcnt,tnexgfe,tnfcnt,tnintcnt,tnintfe,tniter,tnstpcnt, - + trtype,ucgmaxit - double precision beta,cgepsf,cgepsi,cggpnf,delmin,epsabs,epsgpen, - + epsgpsn,epsnfp,epsnqmp,epsrel,eta,f,fmin,gamma,gpeucn2, - + gpsupn,infabs,infrel,lspgma,lspgmi,next,nint,sigma1, - + sigma2,steabs,sterel,theta,udelta0 - -C ARRAY ARGUMENTS - integer ind(n) - double precision d(n),g(n),l(n),lambda(m),lastgpns(0:maxitngp-1), - + rho(m),s(n),u(n),w(5*n),x(n),y(n) - -C Solves the box-constrained minimization problem -C -C Minimize f(x) -C -C subject to -C -C l <= x <= u -C -C using a method described in -C -C E. G. Birgin and J. M. Martinez, ''Large-scale active-set box- -C constrained optimization method with spectral projected -C gradients'', Computational Optimization and Applications 23, pp. -C 101-125, 2002. -C -C Subroutine evalal must be supplied by the user to evaluate the -C objective function. The prototype of evalal subroutine must be -C -C subroutine evalal(n,x,m,lambda,rho,f,flag) -C -C C On Entry: -C C -C C n integer -C C number of variables -C C -C C x double precision x(n) -C C current point -C C -C C m integer -C C number of constraints (equalities plus inequalities) -C C -C C lambda double precision lambda(m) -C C current estimation of the Lagrange multipliers -C C -C C rho double precision rho(m) -C C penalty parameters -C C -C C NOTE: arguments m, lambda and rho are useful when GENCAN is -C C being used for solving the box-constrained subproblems of an -C C Augmented Lagrangian framework. When GENCAN is being used -C C stand-alone for solving a bound-constrained problem, these -C C arguments are dummy arguments and must be ignored. -C C -C C On Return -C C -C C f double precision -C C objective function value at x -C C -C C flag integer -C C 0 means ''no errors'' -C C any other value means ''there was an error in the -C C objective function calculation''. -C C -C C SCALAR ARGUMENTS -C integer flag,m,n -C double precision f -C -C C ARRAY ARGUMENTS -C double precision lambda(m),rho(m),x(n) -C -C C ''Here it should be the body of evalal subroutine that saves -C C in f the objective function value at x. Moreover, it sets -C C flag equal to 0 if the calculation was successfully done and -C C sets flag equal to any other value different from 0 if the -C C objective function is not well defined at the current point -C C x.'' -C -C end -C -C Subroutine evalnal to calculate the gradient of the objective -C function may be supplied by the user or not, depending on the -C value of gtype argument (gtype equal to 0 means that the evalnal -C subroutine will be supplied by the user and gtype equal to 1 means -C that an internal GENCAN subroutine will be used to estimate the -C gradient vector by central finite differences). In any case, a -C subroutine named evalnal with the following prototype must -C present. -C -C subroutine evalnal(n,x,m,lambda,rho,g,flag) -C -C C On Entry: -C -C C n integer -C C number of variables -C C -C C x double precision x(n) -C C current point -C C -C C m integer -C C number of constraints (equalities plus inequalities) -C C -C C lambda double precision lambda(m) -C C current estimation of the Lagrange multipliers -C C -C C rho double precision rho(m) -C C penalty parameters -C C -C C NOTE: arguments m, lambda and rho are useful when GENCAN is -C C being used for solving the box-constrained subproblems of an -C C Augmented Lagrangian framework. When GENCAN is being used -C C stand-alone for solving a bound-constrained problem, these -C C arguments are dummy arguments and must be ignored. -C C -C C On Return -C C -C C g double precision g(n) -C C gradient of the objective function at x -C C -C C flag integer -C C 0 means ''no errors'', -C C any other value means ''there was an error in the -C C gradient calculation''. -C C -C C SCALAR ARGUMENTS -C integer flag,m,n -C -C C ARRAY ARGUMENTS -C double precision g(n),lambda(m),rho(m),x(n) -C -C C ''Here it should be the body of evalnal subroutine that -C C saves in g the gradient vector of the objective function at -C C x. Moreover, it sets flag equal to 0 if the calculation was -C C successfully done and sets flag equal to any other value -C C different from 0 if the gradient vector is not well defined -C C at the current point x. If GENCAN gtype argument was setted -C C to 1, i.e., the finite difference approximation provided by -C C GENCAN will be used, then this subroutine must even be -C C present for compilation purpose but it will never be -C C called.'' -C -C end -C -C Subroutine evalhd to calculate of the Hessian of the objective -C function times a given vector may be supplied by the user or not, -C depending on the value of htvtype argument (htvtype equal to 0 -C means that the evalhd subroutine will be supplied by the user and -C htvtype equal to 1 means tha an internal GENCAN subroutine will be -C used to estimate the product by incremental quotients). In any -C case, a subroutine named evalhd with the following prototype must -C present. -C -C subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) -C -C C On Entry: -C C -C C nind integer -C C number of component of the Hessian-vector product that -C C must be computed -C C -C C ind integer ind(nind) -C C the component that must be computed are ind(1)-th ... -C C ind(nind)-th -C C -C C n integer -C C number of variables -C C -C C x double precision x(n) -C C current point -C C -C C m integer -C C number of constraints (equalities plus inequalities) -C C -C C lambda double precision lambda(m) -C C current estimation of the Lagrange multipliers -C C -C C rho double precision rho(m) -C C penalty parameters -C C -C C NOTE: arguments m, lambda and rho are useful when GENCAN is -C C being used for solving the box-constrained subproblems of an -C C Augmented Lagrangian framework. When GENCAN is being used -C C stand-alone for solving a bound-constrained problem, these -C C arguments are dummy arguments and must be ignored. -C C -C C d double precision d(n) -C C vector of the Hessian-vector product -C C -C C On Return -C C -C C hd double precision g(n) -C C Hessian-vector product -C C -C C flag integer -C C 0 means ''no errors'', -C C any other value means ''there was an error in the -C C product calculation''. Just as an example, as it has -C C no sense that an error occurs in a matrix-vector -C C product, the error could happen in the Hessian -C C calculation. But the possible errors will depend -C C on the way this Hessian-vector product is computed -C C or approximated. -C -C C SCALAR ARGUMENTS -C integer flag,m,n,nind -C -C C ARRAY ARGUMENTS -C integer ind(nind) -C double precision d(n),hd(n),lambda(m),rho(m),x(n) -C -C C ''Here it should be the body of evalhd subroutine that saves -C C in hd the product of the Hessian of the objective function -C C times vector d. Moreover, it sets flag equal to 0 if the -C C calculation was successfully done and sets flag equal to any -C C other value different from 0 if the Hessian matrix is not -C C well defined at the current point x. If GENCAN htvtype -C C argument was setted to 1, i.e., the incremental quotients -C C approximation provided by GENCAN will be used, then this -C C subroutine must even be present for compilation purposes -C C but it will never be called.'' -C -C end -C -C In evalhd subroutine, the information about the matrix H must be -C passed by means of common declarations. This subroutine must be -C coded by the user, taking into account that only nind components -C of d are nonnull and that ind is the set of indices of those -C components. In other words, the user must write evalhd in such a -C way that hd is the vector whose i-th entry is -C -C hd(i) = \Sum_{j=1}^{nind} H_{i,ind(j)} d_ind(j) -C -C Moreover, the only components of hd that must be computed are -C those which correspond to the indices ind(1),...,ind(nind). -C However, observe that it must be assumed that, in d, the whole -C dense vector is present, with its n components, even the null -C ones. So, if the user decides to code evalhd without taking into -C account the presence of ind and nind, it can be easily done. A -C final observation: probably, if nind is close to n, it is not -C worthwhile to use ind, due to the cost of accessing the correct -C indices. -C -C Example: Assume that H is dense. The main steps of evalhd could -C be: -C -C do i = 1,nind -C indi = ind(i) -C hd(indi) = 0.0d0 -C do j = 1,nind -C indj = ind(j) -C hd(indi) = hd(indi) + H(indi,indj) * d(indj) -C end do -C end do -C -C -C Description of the GENCAN arguments: -C -C On Entry -C -C n integer -C number of variables -C -C x double precision x(n) -C initial estimation of the solution -C -C l double precision l(n) -C lower bounds on the variables -C -C u double precision u(n) -C upper bounds on the variables -C -C m integer -C lambda double precision lambda(m) -C rho double precision rho(m) -C These three parameters are not used nor modified by -C GENCAN and they are passed as arguments to the user- -C defined subroutines evalal and evalnal to compute the -C objective function and its gradient, respectively. -C Clearly, in an Augmented Lagrangian context, if GENCAN is -C being used to solve the bound-constrainted subproblems, m -C would be the number of constraints, lambda the Lagrange -C multipliers approximation and rho the penalty parameters -C -C epsgpen double precision -C epsgpen means EPSilon for the Projected Gradient Euclidian -C Norm. It is a small positive number for declaring -C convergence when the Euclidian norm of the continuous -C projected gradient is less than or equal to epsgpen -C -C RECOMMENDED: epsgpen = 1.0d-05 -C -C CONSTRAINTS: epsgpen >= 0.0 -C -C epsgpsn double precision -C epsgpsn means EPSilon for the Projected Gradient Sup Norm. -C It is a small positive number for declaring convergence -C when the sup norm of the continuous projected gradient is -C less than or equal to epsgpsn -C -C RECOMMENDED: epsgpsn = 1.0d-05 -C -C CONSTRAINTS: epsgpsn >= 0.0 -C -C maxitnfp integer -C maxitnfp means MAXimum of ITerations with No Function -C Progress. See below for more details. -C -C epsnfp double precision -C epsnfp means EPSilon for No Function Progress. It is a -C small positive number for declaring ''lack of progress in -C the objective function value'' if f(x_k) - f(x_{k+1}) <= -C epsnfp * max{ f(x_j) - f(x_{j+1}, j < k } during maxitnfp -C consecutive iterations. This stopping criterion may be -C inhibited setting maxitnfp equal to maxit. -C -C RECOMMENDED: maxitnfp = 5 and epsnfp = 1.0d-02 -C -C CONSTRAINTS: maxitnfp >= 1 and epsnfp >= 0.0 -C -C maxitngp integer -C maxitngp means MAXimum of ITerations with No Gradient -C Progress. If the order of the Euclidian norm of the -C continuous projected gradient did not change during -C maxitngp consecutive iterations then the execution stops. -C -C RECOMMENDED: maxitngp = 10 -C -C CONSTRAINTS: maxitngp >= 1 -C -C fmin double precision -C function value for the stopping criteria f <= fmin -C -C There is a stopping criterion that stops GENCAN if a -C point with a functional value smaller than fmin is found. -C The idea behind this stopping criterion is to stop the -C method if the objective function is not bounded from -C below. -C -C RECOMMENDED: fmin = - infabs -C -C CONSTRAINTS: there are no constraints for this argument -C -C maxit integer -C maximum number of allowed iterations -C -C RECOMMENDED: maxit = 1000 -C -C CONSTRAINTS: maxit >= 0 -C -C maxfc integer -C maximum allowed number of functional evaluations -C -C RECOMMENDED: maxfc = 5 * maxit -C -C CONSTRAINTS: maxfc >= 1 -C -C udelta0 double precision -C initial ''trust-radius'' for Conjugate Gradients. The -C default value max( delmin, 0.1 * max( 1, ||x|| ) ) is -C used if the user sets udelta0 <= 0. -C -C RECOMMENDED: udelta0 = - 1.0 -C -C CONSTRAINTS: there are no constraints for this argument -C -C ucgmaxit integer -C maximum allowed number of iterations for each run of the -C Conjugate Gradient subalgorithm -C -C The default values for this argument is max( 1, 10 * -C log( nind ) ), where nind is the number of free -C variables, and it will be used if the user sets ucgmaxit -C to any non-positive value. -C -C RECOMMENDED: ucgmaxit = - 1 -C -C CONSTRAINTS: there are no constraints for this argument -C -C cgscre integer -C See below -C -C cggpnf double precision -C cgscre means conjugate gradient stopping criterion -C relation, and cggpnf means Conjugate Gradients projected -C gradient final norm. Both are related to a stopping -C criterion of Conjugate Gradients. This stopping criterion -C depends on the norm of the residual of the linear system. -C The norm of the residual should be less or equal than a -C ''small'' quantity which decreases as we are -C approximating the solution of the minimization problem -C (near the solution, better the truncated-Newton direction -C we aim). Then, the log of the required accuracy requested -C to Conjugate Gradient has a linear dependence on the log -C of the norm of the continuous projected gradient. This -C linear relation uses the squared Euclidian norm of the -C projected gradient if cgscre is equal to 1 and uses the -C sup-norm if cgscre is equal to 2. In addition, the -C precision required to CG is equal to cgepsi (conjugate -C gradient initial epsilon) at x0 and cgepsf (conjugate -C gradient final epsilon) when the Euclidian- or sup-norm -C of the projected gradient is equal to cggpnf (conjugate -C gradients projected gradient final norm) which is an -C estimation of the value of the Euclidian- or sup-norm of -C the projected gradient at the solution. -C -C RECOMMENDED: cgscre = 1, cggpnf = epsgpen; or -C cgscre = 2, cggpnf = epsgpsn. -C -C CONSTRAINTS: allowed values for cgscre are just 1 or 2 -C cggpnf >= 0.0 -C -C cgepsi double precision -C See below -C -C cgepsf double precision -C small positive numbers for declaring convergence of the -C Conjugate Gradients subalgorithm when ||r||_2 < cgeps * -C ||rhs||_2, where r is the residual and rhs is the right -C hand side of the linear system, i.e., CG stops when the -C relative error of the solution is smaller than cgeps. -C -C cgeps varies from cgepsi to cgepsf in a way that depends -C on cgscre as follows: -C -C i) CASE cgscre = 1: log10(cgeps^2) depends linearly on -C log10(||g_P(x)||_2^2) which varies from ||g_P(x_0)||_2^2 -C to epsgpen^2 -C -C ii) CASE cgscre = 2: log10(cgeps) depends linearly on -C log10(||g_P(x)||_inf) which varies from ||g_P(x_0)||_inf -C to epsgpsn -C -C RECOMMENDED: cgepsi = 1.0d-01, cgepsf = 1.0d-05 -C -C CONSTRAINTS: cgepsi >= cgepsf >= 0.0 -C -C epsnqmp double precision -C See below -C -C maxitnqmp integer -C This and the previous argument are used for a stopping -C criterion of the Conjugate Gradients subalgorithm. If the -C progress in the quadratic model is smaller than fraction -C of the best progress ( epsnqmp * bestprog ) during -C maxitnqmp consecutive iterations then CG is stopped -C declaring ''not enough progress of the quadratic model''. -C -C RECOMMENDED: epsnqmp = 1.0d-04, maxitnqmp = 5 -C -C CONSTRAINTS: epsnqmp >= 0.0, maxitnqmp >= 1. -C -C nearlyq logical -C If the objective function is (nearly) quadratic, use the -C option nearlyq = TRUE. Otherwise, keep the default -C option. -C -C If, in an iteration of CG we find a direction d such that -C d^T H d <= 0 then we take the following decision: -C -C (i) If nearlyq = TRUE then we take direction d and try to -C go to the boundary choosing the best point among the two -C points at the boundary and the current point. -C -C (ii) If nearlyq = FALSE then we stop at the current point. -C -C Moreover, if the objective function is quadratic more -c effort is due in computing the Truncated Newton direction. -C -C RECOMMENDED: nearlyq = FALSE -C -C CONSTRAINTS: allowed values are just TRUE or FALSE. -C -C nint double precision -C Constant for the interpolation. See the description of -C sigma1 and sigma2 above. Sometimes, in a line search, we -C take the new trial step as the previous one divided by -C nint -C -C RECOMMENDED: nint = 2.0 -C -C CONSTRAINTS: nint > 1.0. -C -C next double precision -C Constant for the extrapolation. When extrapolating we -C try alpha_new = alpha * next -C -C RECOMMENDED: next = 2.0 -C -C CONSTRAINTS: next > 1.0 -C -C mininterp integer -C Constant for testing if, after having made at least -C mininterp interpolations, the steplength is too small. In -C that case, failure of the line search is declared (may be -C the direction is not a descent direction due to an error -C in the gradient calculations). Use mininterp greater -C than or equal to maxfc for inhibit this stopping -C criterion -C -C RECOMMENDED: mininterp = 4 -C -C CONSTRAINTS: mininterp >= 1 -C -C maxextrap integer -C Constant to limit the number of extrapolations in the -C Truncated Newton direction. -C -C RECOMMENDED: maxextrap = 100 -C -C CONSTRAINTS: maxextrap >= 0 -C -C gtype integer -C gtype indicates in which way the gradient of the -C objective function will be computed. If the user have -C been implemented the user-supplied evalnal subroutine to -C compute the gradient of the objective function then -C gtype argument must be set to 0 (ZERO) and the user- -C supplied evalnal subroutine will be called by GENCAN any -C time the gradient would be required. -C -C subroutine evalnal(n,x,m,lambda,rho,g,flag) -C -C C On Entry: -C -C C n integer, -C C number of variables, -C C -C C x double precision x(n), -C C current point, -C C -C C m integer, -C C number of constraints (equalities plus -C C inequalities), -C C -C C lambda double precision lambda(m), -C C current estimation of the Lagrange -C C multipliers, -C C -C C rho double precision rho(m) -C C penalty parameters, -C C -C C NOTE: arguments m, lambda and rho are useful when -C C GENCAN is being used for solving the box- -C C constrained subproblems of an Augmented Lagrangian -C C framework. When GENCAN is being used stand-alone -C C for solving a bound-constrained problem, these -C C arguments are dummy arguments. -C C -C C On Return -C C -C C g double precision g(n), -C C gradient of the objective function at x, -C C -C C flag integer -C C 0 means ''no errors'', -C C 1 means ''some error occurs in the gradient -C C evaluation''. -C C -C C SCALAR ARGUMENTS -C integer flag,m,n -C -C C ARRAY ARGUMENTS -C double precision g(n),lambda(m),rho(m),x(n) -C -C C ''Here it should be the body of evalnal subroutine -C C that saves in g the gradient vector of the -C C objective at x. Moreover, it sets flag equal to 0 -C C if the calculation was successfully done and sets -C C flag equal to any other value different from 0 if -C C the gradient vector is not well defined at the -C C current point x. If GENCAN gtype argument was -C C setted to 1, i.e., the finite difference -C C approximation provided by GENCAN will be used, then -C C this subroutine must even be present for -C C compilation purposes but it will never be called.'' -C -C end -C -C If, on the other hand, the user is not able to provide -C evalnal subroutine, gtype argument must be set to 1 -C (ONE). In this case, every time GENCAN needs to compute -C the gradient of the objective function, an internal -C subroutine that approximates it by finite-differences -C will be used (be aware that it maybe very time -C consuming). Moreover, note that the evalnal subroutine -C must still be present (with an empty body). -C -C RECOMMENDED: gtype = 0 (provided you have the evalg -C subroutine) -C -C CONSTRAINTS: allowed values are just 0 or 1. -C -C htvtype integer -C htvtype indicates in which way the product of the Hessian -C of the objective function times an arbitrary vector will be -C computed. If the user has not been implemented the user- -C supplied evalhd subroutine to do this task then htvtype -C argument must be set to 1 (ONE). In this case an internal -C subroutine that approximates this product by incremental -C quotients will be used. Note that, even in this case, -C evalhd subroutine must be present (with an empty body). -C This is the default option and the empty-body subroutine -C follows: -C -C subroutine evalhd(nind,ind,n,x,m,lambda,rho,d,hd,flag) -C -C C SCALAR ARGUMENTS -C integer nind,n,m,flag -C -C C ARRAY ARGUMENTS -C integer ind(nind) -C double precision x(n),lambda(m),rho(m),d(n),hd(n) -C -C flag = - 1 -C -C end -C -C If, on the other hand, the user prefers to implement his/ -C her own evalhd subroutine then htvtype argument must be -C set to 0 (ZERO). In this case, the product of the Hessian -C times vector d (input argument of evalhd subroutine) must -C be saved in vector hd (output argument of evalhd -C subroutine). The other arguments description as well as -C some hints on how to implement your own evalhd subroutine -C can be found in the GENCAN arguments description. -C -C RECOMMENDED: htvtype = 1 -C -C (you take some risk using this option but, unless you -C have a good evalhd subroutine, incremental quotients is a -C very cheap option) -C -C CONSTRAINTS: allowed values are just 0 or 1. -C -C trtype integer -C Type of Conjugate Gradients ''trust-radius''. trtype -C equal to 0 means Euclidian-norm trust-radius and trtype -C equal to 1 means sup-norm trust radius -C -C RECOMMENDED: trtype = 0 -C -C CONSTRAINTS: allowed values are just 0 or 1. -C -C iprint integer -C Commands printing. Nothing is printed if iprint is -C smaller than 2. If iprint is greater than or equal to -C 2, GENCAN iterations information is printed. If iprint -C is greater than or equal to 3, line searches and -C Conjugate Gradients information is printed. -C -C RECOMMENDED: iprint = 2 -C -C CONSTRAINTS: allowed values are just 2 or 3. -C -C ncomp integer -C This constant is just for printing. In a detailed -C printing option, ncomp component of some vectors will be -C printed -C -C RECOMMENDED: ncomp = 5 -C -C CONSTRAINTS: ncomp >= 0 -C -C s double precision s(n) -C y double precision y(n) -C d double precision d(n) -C ind integer ind(n) -C lastgpns double precision lastgpns(maxitngp) -C w double precision w(5*n) -C working vectors -C -C eta double precision -C Constant for deciding abandon the current face or not. We -C abandon the current face if the norm of the internal -C gradient (here, internal components of the continuous -C projected gradient) is smaller than ( 1 - eta ) times the -C norm of the continuous projected gradient. Using eta = -C 0.9 is a rather conservative strategy in the sense that -C internal iterations are preferred over SPG iterations. -C -C RECOMMENDED: eta = 0.9 -C -C CONSTRAINTS: 0.0 < eta < 1.0 -C -C delmin double precision -C Smaller Conjugate Gradients ''trust radius'' to compute -C the Truncated Newton direction -C -C RECOMMENDED: delmin = 0.1 -C -C CONSTRAINTS: delmin > 0.0 -C -C lspgmi double precision -C See below -C -C lspgma double precision -C The spectral steplength, called lamspg, is projected onto -C the box [lspgmi,lspgma] -C -C RECOMMENDED: lspgmi = 1.0d-10 and lspgma = 1.0d+10 -C -C CONSTRAINTS: lspgma >= lspgmi > 0.0 -C -C theta double precision -C Constant for the angle condition, i.e., at iteration k we -C need a direction dk such that <= - theta -C ||gk||_2 ||dk||_2, where gk is \nabla f(xk) -C -C RECOMMENDED: theta = 10^{-6} -C -C CONSTRAINTS: 0.0 < theta < 1.0 -C -C gamma double precision -C Constant for the Armijo criterion -C f(x + alpha d) <= f(x) + gamma * alpha * -C -C RECOMMENDED: gamma = 1.0d-04 -C -C CONSTRAINTS: 0.0 < gamma < 0.5. -C -C beta double precision -C Constant for the beta condition < beta -C * . If (xk + dk) satisfies the Armijo condition -C but does not satisfy the beta condition then the point is -C accepted, but if it satisfied the Armijo condition and -C also satisfies the beta condition then we know that there -C is the possibility for a successful extrapolation -C -C RECOMMENDED: beta = 0.5 -C -C CONSTRAINTS: 0.0 < beta < 1.0. -C -C sigma1 double precision -C See below -C -C sigma2 double precision -C Constant for the safeguarded interpolation. If alpha_new -C is not inside the interval [sigma1, sigma * alpha] then -C we take alpha_new = alpha / nint -C -C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 -C -C CONSTRAINTS: 0 < sigma1 < sigma2 < 1. -C -C sterel double precision -C See below -C -C steabs double precision -C This constants mean a ''relative small number'' and ''an -C absolute small number'' for the increments in finite -C difference approximations of derivatives -C -C RECOMMENDED: epsrel = 1.0d-07 and epsabs = 1.0d-10 -C -C CONSTRAINTS: sterel >= steabs > 0 -C -C epsrel double precision -C See below -C -C epsabs double precision -C See below -C -C infrel double precision -C See below -C -C infabs double precision -C This four constants mean a ''relative small number'', -C ''an absolute small number'', ''a relative large number'' -C and ''an absolute large number''. Basically, a quantity A -C is considered negligible with respect to another quantity -C B if |A| < max ( epsrel * |B|, epsabs ) -C -C RECOMMENDED: epsrel = 1.0d-10, epsabs = 1.0d-20, -C infrel = 1.0d+20, infabs = 1.0d+99 -C -C CONSTRAINTS: epsrel >= epsabs >= 0.0 -C infabs >= infrel >= 0.0 -C -C On Return -C -C x double precision x(n) -C Final estimation to the solution -C -C f double precision -C Function value at the final estimation -C -C g double precision g(n) -C Gradient at the final estimation -C -C gpeucn2 double precision -C Squared Euclidian norm of the continuous projected -C gradient at the final estimation -C -C gpsupn double precision -C the same as before but with sup-norm -C -C iter integer -C number of iterations -C -C fcnt integer -C number of function evaluations -C -C gcnt integer -C number of gradient evaluations -C -C cgcnt integer -C number of Conjugate Gradients iterations -C -C spgiter integer -C number of Spectral Projected Gradient iterations -C -C spgfcnt integer -C number of functional evaluations along Spectral Projected -C Gradient directions -C -C tniter integer -C number of Truncated-Newton iterations -C -C tnfcnt integer -C number of functional evaluations along Truncated-Newton -C directions -C -C tnintcnt integer -C number of times a backtracking in a Truncated-Newton -C direction was needed -C -C tnexgcnt integer -C number of times an extrapolation in a Truncated-Newton -C direction successfully decreased the objective funtional -C value -C -C tnexbcnt integer -C number of times an extrapolation was aborted in the first -C extrapolated point by an increase in the objective -C functional value -C -C tnstpcnt integer -C number of times the Newton point was accepted (without -C interpolations nor extrapolations) -C -C tnintfe integer -C number of functional evaluations used in interpolations -C along Truncated-Newton directions -C -C tnexgfe integer -C number of functional evaluations used in successful -C extrapolations along Truncated-Newton directions -C -C tnexbfe integer -C number of functional evaluations used in unsuccessful -C extrapolations along Truncated-Newton directions -C -C inform integer -C This output parameter tells what happened in this -C subroutine, according to the following conventions: -C -C 0 = convergence with small Euclidian norm of the -C continuous projected gradient (smaller than epsgpen); -C -C 1 = convergence with small sup-norm of the continuous -C projected gradient (smaller than epsgpsn); -C -C 2 = the algorithm stopped by ''lack of progress'', that -C means that f(xk) - f(x_{k+1}) <= epsnfp * -C max{ f(x_j) - f(x_{j+1}, j < k } during maxitnfp -C consecutive iterations. If desired, set maxitnfp -C equal to maxit to inhibit this stopping criterion. -C -C 3 = the algorithm stopped because the order of the -C Euclidian norm of the continuous projected gradient -C did not change during maxitngp consecutive -C iterations. Probably, we are asking for an -C exaggerated small norm of continuous projected -C gradient for declaring convergence. If desired, set -C maxitngp equal to maxit to inhibit this stopping -C criterion. -C -C 4 = the algorithm stopped because the functional value -c is very small (smaller than fmin). If desired, set -C fmin equal to minus infabs to inhibit this stopping -C criterion. -C -C 6 = too small step in a line search. After having made at -C least mininterp interpolations, the steplength -C becames small. ''small steplength'' means that we are -C at point x with direction d and step alpha, and -C -C alpha * ||d||_infty < max( epsabs, epsrel * -C ||x||_infty ). -C -C In that case failure of the line search is declared -C (may be the direction is not a descent direction due -C to an error in the gradient calculations). If -C desired, set mininterp equal to maxfc to inhibit this -C stopping criterion. -C -C 7 = it was achieved the maximum allowed number of -C iterations (maxit); -C -C 8 = it was achieved the maximum allowed number of -C function evaluations (maxfc); -C -C < 0 = error in evalal, evalnal or evalhd subroutines. - -C LOCAL SCALARS - character * 3 ittype - integer cgiter,cgmaxit,fcntprev,i,infotmp,itnfp,nind,nprint, - + rbdind,rbdtype,tnexbprev,tnexgprev,tnintprev - double precision acgeps,amax,amaxx,bestprog,bcgeps,cgeps,currprog, - + delta,epsgpen2,fprev,gieucn2,gpeucn20,gpi,gpnmax,gpsupn0, - + kappa,lamspg,ometa2,sts,sty,xnorm - logical packmolprecision - -C ================================================================== -C Initialization -C ================================================================== - -C Set some initial values: - -C counters, - iter = 0 - fcnt = 0 - gcnt = 0 - cgcnt = 0 - - spgiter = 0 - spgfcnt = 0 - - tniter = 0 - tnfcnt = 0 - - tnstpcnt = 0 - tnintcnt = 0 - tnexgcnt = 0 - tnexbcnt = 0 - - tnintfe = 0 - tnexgfe = 0 - tnexbfe = 0 - -C just for printing, - nprint = min0( n, ncomp ) - -C for testing convergence, - epsgpen2 = epsgpen ** 2 - -C for testing whether to abandon the current face or not, -C (ometa2 means '(one minus eta) squared') - ometa2 = ( 1.0d0 - eta ) ** 2 - -C for testing progress in f, and - fprev = infabs - bestprog = 0.0d0 - itnfp = 0 - -C for testing progress in the projected gradient norm. - do i = 0,maxitngp - 1 - lastgpns(i) = infabs - end do - -C Print problem information - - if( iprint .ge. 3 ) then - write(*, 977) n - write(*, 978) nprint,(l(i),i=1,nprint) - write(*, 979) nprint,(u(i),i=1,nprint) - write(*, 980) nprint,(x(i),i=1,nprint) - - write(10,977) n - write(10,978) nprint,(l(i),i=1,nprint) - write(10,979) nprint,(u(i),i=1,nprint) - write(10,980) nprint,(x(i),i=1,nprint) - end if - -C Project initial guess. If the initial guess is infeasible, -C projection puts it into the box. - - do i = 1,n - x(i) = max( l(i), min( x(i), u(i) ) ) - end do - -C Compute x Euclidian norm - - xnorm = 0.0d0 - do i = 1,n - xnorm = xnorm + x(i) ** 2 - end do - xnorm = sqrt( xnorm ) - -C Compute function and gradient at the initial point - - call evalal(n,x,m,lambda,rho,f,inform) - -c LM: Added packmolprecision function test, for Packmol - - if ( packmolprecision(n,x) ) then - if(iprint.gt.0) then - write(*,780) -780 format(' Current point is a solution.') - end if - return - end if - - fcnt = fcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - end if - - if ( gtype .eq. 0 ) then - call evalnal(n,x,m,lambda,rho,g,inform) - else ! if ( gtype .eq. 1 ) then - call evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - end if - -C Compute continuous-project-gradient Euclidian and Sup norms, -C internal gradient Euclidian norm, and store in nind the number of -C free variables and in array ind their identifiers. - - nind = 0 - gpsupn = 0.0d0 - gpeucn2 = 0.0d0 - gieucn2 = 0.0d0 - do i = 1,n - gpi = min( u(i), max( l(i), x(i) - g(i) ) ) - x(i) - gpsupn = max( gpsupn, abs( gpi ) ) - gpeucn2 = gpeucn2 + gpi ** 2 - if ( x(i) .gt. l(i) .and. x(i) .lt. u(i) ) then - gieucn2 = gieucn2 + gpi ** 2 - nind = nind + 1 - ind(nind) = i - end if - end do - -C Compute a linear relation between gpeucn2 and cgeps2, i.e., -C scalars a and b such that -c -C a * log10(||g_P(x_0)||_2^2) + b = log10(cgeps_0^2) and -c -C a * log10(||g_P(x_f)||_2^2) + b = log10(cgeps_f^2), -c -C where cgeps_0 and cgeps_f are provided. Note that if -C cgeps_0 is equal to cgeps_f then cgeps will be always -C equal to cgeps_0 and cgeps_f. - -C We introduce now a linear relation between gpsupn and cgeps also. - -c LM: changed to avoid error with gpsupn=0 - if ( gpsupn .ne. 0.0d0 ) then - acgeps = log10( cgepsf / cgepsi ) / log10( cggpnf / gpsupn ) - bcgeps = log10( cgepsi ) - acgeps * log10( gpsupn ) - else - acgeps = 0.0d0 - bcgeps = cgepsf - end if -c if ( cgscre .eq. 1 ) then -c acgeps = 2.0d0 * log10( cgepsf / cgepsi ) / -c + log10( cggpnf ** 2 / gpeucn2 ) -c bcgeps = 2.0d0 * log10( cgepsi ) - acgeps * log10( gpeucn2 ) -c else ! if ( cgscre .eq. 2 ) then -c acgeps = log10( cgepsf / cgepsi ) / log10( cggpnf / gpsupn ) -c bcgeps = log10( cgepsi ) - acgeps * log10( gpsupn ) -c end if - -C And it will be used for the linear relation of cgmaxit - - gpsupn0 = gpsupn - gpeucn20 = gpeucn2 - -C Print initial information - - if( iprint .ge. 2 ) then -c LM: output for packmol -c write(*,1003) iter,f,gpsupn - if((mod((iter-1),10).eq.0.or.iter.eq.0).and.iter.ne.1) then - write(*,778) - else if(mod(iter,10).eq.0) then - write(*,779) - else if(iter.ne.1) then - write(*,777) - end if - end if -777 format('*******',$) -778 format(' |',$) -779 format('**********|') - - if( iprint .ge. 3 ) then - write(*, 981) iter - write(*, 985) nprint,(x(i),i=1,nprint) - write(*, 986) nprint,(g(i),i=1,nprint) - write(*, 987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, - + nprint) - write(*, 988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, - + nind)) - write(*, 1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, - + spgiter,tniter,fcnt,gcnt,cgcnt - - write(10,981) iter - write(10,985) nprint,(x(i),i=1,nprint) - write(10,986) nprint,(g(i),i=1,nprint) - write(10,987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, - + nprint) - write(10,988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, - + nind)) - write(10,1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, - + spgiter,tniter,fcnt,gcnt,cgcnt - end if - -C ================================================================== -C Main loop -C ================================================================== - - 100 continue - -C ================================================================== -C Test stopping criteria -C ================================================================== - -c LM: Added packmolprecision function test, for Packmol - - if ( packmolprecision(n,x) ) then - goto 500 - end if - -C Test whether the continuous-projected-gradient Euclidian norm -C is small enough to declare convergence - - if ( gpeucn2 .le. epsgpen2 ) then - inform = 0 - - if ( iprint .ge. 3 ) then - write(*, 990) inform,epsgpen - write(10,990) inform,epsgpen - end if - - go to 500 - end if - -C Test whether the continuous-projected-gradient Sup norm -C is small enough to declare convergence - - if ( gpsupn .le. epsgpsn ) then - inform = 1 - - if ( iprint .ge. 3 ) then - write(*, 991) inform,epsgpsn - write(10,991) inform,epsgpsn - end if - - go to 500 - end if - -C Test whether we performed many iterations without good progress -C of the functional value - - currprog = fprev - f - bestprog = max( currprog, bestprog ) - - if ( currprog .le. epsnfp * bestprog ) then - - itnfp = itnfp + 1 - - if ( itnfp .ge. maxitnfp ) then - inform = 2 - - if ( iprint .ge. 3 ) then - write(*, 992) inform,epsnfp,maxitnfp - write(10,992) inform,epsnfp,maxitnfp - end if - - go to 500 - endif - - else - itnfp = 0 - endif - -C Test whether we have performed many iterations without good -C reduction of the euclidian-norm of the projected gradient - - gpnmax = 0.0d0 - do i = 0,maxitngp - 1 - gpnmax = max( gpnmax, lastgpns(i) ) - end do - - lastgpns(mod( iter, maxitngp )) = gpeucn2 - - if ( gpeucn2 .ge. gpnmax ) then - - inform = 3 - - if ( iprint .ge. 3 ) then - write(*, 993) inform,maxitngp - write(10,993) inform,maxitngp - end if - - go to 500 - - endif - -C Test whether the functional value is very small - - if ( f .le. fmin ) then - - inform = 4 - - if ( iprint .ge. 3 ) then - write(*, 994) inform,fmin - write(10,994) inform,fmin - end if - - go to 500 - - end if - -C Test whether the number of iterations is exhausted - - if ( iter .ge. maxit ) then - - inform = 7 - - if ( iprint .ge. 3 ) then - write(*, 997) inform,maxit - write(10,997) inform,maxit - end if - - go to 500 - - end if - -C Test whether the number of functional evaluations is exhausted - - if ( fcnt .ge. maxfc ) then - - inform = 8 - - if ( iprint .ge. 3 ) then - write(*, 998) inform,maxfc - write(10,998) inform,maxfc - end if - - go to 500 - - end if - -C ================================================================== -C The stopping criteria were not satisfied, a new iteration will be -C made -C ================================================================== - - iter = iter + 1 - -C ================================================================== -C Save current values, f, x and g -C ================================================================== - - fprev = f - - do i = 1,n - s(i) = x(i) - y(i) = g(i) - end do - -C ================================================================== -C Compute new iterate -C ================================================================== - -C We abandon the current face if the norm of the internal gradient -C (here, internal components of the continuous projected gradient) -C is smaller than (1-eta) times the norm of the continuous -C projected gradient. Using eta=0.9 is a rather conservative -C strategy in the sense that internal iterations are preferred over -C SPG iterations. Replace eta = 0.9 by other tolerance in (0,1) if -C you find it convenient. - - if ( gieucn2 .le. ometa2 * gpeucn2 ) then - -C ============================================================== -C Some constraints should be abandoned. Compute the new iterate -C using an SPG iteration -C ============================================================== - - ittype = 'SPG' - spgiter = spgiter + 1 - -C Compute spectral steplength - - if ( iter .eq. 1 .or. sty .le. 0.0d0 ) then - lamspg = max( 1.0d0, xnorm ) / sqrt( gpeucn2 ) - else - lamspg = sts / sty - end if - lamspg = min( lspgma, max( lspgmi, lamspg ) ) - -C Perform a line search with safeguarded quadratic interpolation -C along the direction of the spectral continuous projected -C gradient - - fcntprev = fcnt - - call spgls(n,x,m,lambda,rho,f,g,l,u,lamspg,nint,mininterp, - + fmin,maxfc,iprint,fcnt,inform,w(1),w(n+1),gamma,sigma1,sigma2, - + sterel,steabs,epsrel,epsabs,infrel,infabs) - - spgfcnt = spgfcnt + ( fcnt - fcntprev ) - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - end if - -C Compute the gradient at the new iterate - - if ( gtype .eq. 0 ) then - call evalnal(n,x,m,lambda,rho,g,inform) - else ! if ( gtype .eq. 1 ) then - call evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - end if - - else - -C ============================================================== -C The new iterate will belong to the closure of the current face -C ============================================================== - - ittype = 'TN ' - tniter = tniter + 1 - -C Compute trust-region radius - - if ( iter .eq. 1 ) then - if( udelta0 .le. 0.0d0 ) then - delta = max( delmin, 0.1d0 * max( 1.0d0, xnorm ) ) - else - delta = udelta0 - end if - else - delta = max( delmin, 10.0d0 * sqrt( sts ) ) - end if - -C Shrink the point, its gradient and the bounds - - call shrink(nind,ind,n,x) - call shrink(nind,ind,n,g) - call shrink(nind,ind,n,l) - call shrink(nind,ind,n,u) - -C Compute the descent direction solving the newtonian system by -C conjugate gradients - -C Set conjugate gradient stopping criteria. Default values are -C taken if you set ucgeps < 0 and ucgmaxit < 0, respectively. -C Otherwise, the parameters cgeps and cgmaxit will be the ones -C set by the user. - - if( ucgmaxit .le. 0 ) then - if ( nearlyq ) then - cgmaxit = nind - else - if ( cgscre .eq. 1 ) then - kappa = log10( gpeucn2 / gpeucn20 )/ - + log10( epsgpen2 / gpeucn20 ) - else ! if ( cgscre .eq. 2 ) then - kappa= log10( gpsupn / gpsupn0 ) / - + log10( epsgpsn / gpsupn0 ) - end if - kappa = max( 0.0d0, min( 1.0d0, kappa ) ) - cgmaxit = int( - + ( 1.0d0 - kappa ) * max( 1.0d0, 10.0d0 * - + log10( dfloat( nind ) ) ) + kappa * dfloat( nind ) ) -c L. Martinez added to accelerate the iterations near the solution - cgmaxit = min(20,cgmaxit) - end if -c cgmaxit = 2 * nind - else - cgmaxit = ucgmaxit - end if - - if ( cgscre .eq. 1 ) then - cgeps = sqrt( 10.0d0 ** ( acgeps * log10( gpeucn2 ) + - + bcgeps ) ) - else ! if ( cgscre .eq. 2 ) then - cgeps = 10.0d0 ** ( acgeps * log10( gpsupn ) + bcgeps ) - end if - cgeps = max( cgepsf, min( cgepsi, cgeps ) ) - -C Call conjugate gradients - - call cg(nind,ind,n,x,m,lambda,rho,g,delta,l,u,cgeps,epsnqmp, - + maxitnqmp,cgmaxit,nearlyq,gtype,htvtype,trtype,iprint,ncomp,d, - + cgiter,rbdtype,rbdind,inform,w(1),w(n+1),w(2*n+1),w(3*n+1), - + w(4*n+1),theta,sterel,steabs,epsrel,epsabs,infrel,infabs) - - cgcnt = cgcnt + cgiter - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - -C Compute maximum step - - if ( inform .eq. 2 ) then - amax = 1.0d0 - else - amax = infabs - do i = 1,nind - if ( d(i) .gt. 0.0d0 ) then - amaxx = ( u(i) - x(i) ) / d(i) - if ( amaxx .lt. amax ) then - amax = amaxx - rbdind = i - rbdtype = 2 - end if - else if ( d(i) .lt. 0.0d0 ) then - amaxx = ( l(i) - x(i) ) / d(i) - if ( amaxx .lt. amax ) then - amax = amaxx - rbdind = i - rbdtype = 1 - end if - end if - end do - end if - -C Perform the line search - - tnintprev = tnintcnt - tnexgprev = tnexgcnt - tnexbprev = tnexbcnt - - fcntprev = fcnt - - call tnls(nind,ind,n,x,m,lambda,rho,l,u,f,g,d,amax,rbdtype, - + rbdind,nint,next,mininterp,maxextrap,fmin,maxfc,gtype,iprint, - + fcnt,gcnt,tnintcnt,tnexgcnt,tnexbcnt,inform,w(1),w(n+1), - + w(2*n+1),gamma,beta,sigma1,sigma2,sterel,steabs,epsrel,epsabs, - + infrel,infabs) - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - if ( tnintcnt .gt. tnintprev ) then - tnintfe = tnintfe + ( fcnt - fcntprev ) - else if ( tnexgcnt .gt. tnexgprev ) then - tnexgfe = tnexgfe + ( fcnt - fcntprev ) - else if ( tnexbcnt .gt. tnexbprev ) then - tnexbfe = tnexbfe + ( fcnt - fcntprev ) - else - tnstpcnt = tnstpcnt + 1 - end if - - tnfcnt = tnfcnt + ( fcnt - fcntprev ) - -C Expand the point, its gradient and the bounds - - call expand(nind,ind,n,x) - call expand(nind,ind,n,g) - call expand(nind,ind,n,l) - call expand(nind,ind,n,u) - -C If the line search (interpolation) in the Truncated Newton -C direction stopped due to a very small step (inform = 6), we -C will discard this iteration and force a SPG iteration - -C Note that tnls subroutine was coded in such a way that in case -C of inform = 6 termination the subroutine discards all what was -C done and returns with the same point it started - - if ( inform .eq. 6 ) then - - if ( iprint .ge. 3 ) then - write(*,*) - write(*,*) - + ' The previous TN iteration was discarded due to', - + ' a termination for very small step in the line ', - + ' search. A SPG iteration will be forced now. ' - - write(10,*) - write(10,*) - + ' The previous TN iteration was discarded due to', - + ' a termination for very small step in the line ', - + ' search. A SPG iteration will be forced now. ' - end if - - ittype = 'SPG' - spgiter = spgiter + 1 - -C Compute spectral steplength - - if ( iter .eq. 1 .or. sty .le. 0.0d0 ) then - lamspg = max( 1.0d0, xnorm ) / sqrt( gpeucn2 ) - else - lamspg = sts / sty - end if - lamspg = min( lspgma, max( lspgmi, lamspg ) ) - -C Perform a line search with safeguarded quadratic -C interpolation along the direction of the spectral -C continuous projected gradient - - fcntprev = fcnt - - call spgls(n,x,m,lambda,rho,f,g,l,u,lamspg,nint,mininterp, - + fmin,maxfc,iprint,fcnt,inform,w(1),w(n+1),gamma,sigma1, - + sigma2,sterel,steabs,epsrel,epsabs,infrel,infabs) - - spgfcnt = spgfcnt + ( fcnt - fcntprev ) - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - end if - -C Compute the gradient at the new iterate - - infotmp = inform - - if ( gtype .eq. 0 ) then - call evalnal(n,x,m,lambda,rho,g,inform) - else ! if ( gtype .eq. 1 ) then - call evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs, - + inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 3 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - end if - - inform = infotmp - - end if - - end if - -C ================================================================== -C Prepare for the next iteration -C ================================================================== - -C This adjustment/projection is ''por lo que las putas pudiera'' - - do i = 1,n - if ( x(i) .le. l(i) + max( epsrel * abs( l(i) ), epsabs ) ) - + then - x(i) = l(i) - else if (x(i). ge. u(i) - max( epsrel * abs( u(i) ), epsabs )) - + then - x(i) = u(i) - end if - end do - -C Compute x Euclidian norm - - xnorm = 0.0d0 - do i = 1,n - xnorm = xnorm + x(i) ** 2 - end do - xnorm = sqrt( xnorm ) - -C Compute s = x_{k+1} - x_k, y = g_{k+1} - g_k, and - - sts = 0.0d0 - sty = 0.0d0 - do i = 1,n - s(i) = x(i) - s(i) - y(i) = g(i) - y(i) - sts = sts + s(i) ** 2 - sty = sty + s(i) * y(i) - end do - -C Compute continuous-project-gradient Euclidian and Sup norms, -C internal gradient Euclidian norm, and store in nind the number of -C free variables and in array ind their identifiers. - - nind = 0 - gpsupn = 0.0d0 - gpeucn2 = 0.0d0 - gieucn2 = 0.0d0 - do i = 1,n - gpi = min( u(i), max( l(i), x(i) - g(i) ) ) - x(i) - gpsupn = max( gpsupn, abs( gpi ) ) - gpeucn2 = gpeucn2 + gpi ** 2 - if ( x(i) .gt. l(i) .and. x(i) .lt. u(i) ) then - gieucn2 = gieucn2 + gpi ** 2 - nind = nind + 1 - ind(nind) = i - end if - end do - -C Print information of this iteration - - if( iprint .ge. 2 ) then -c Output for packmol -c write(*, 1003) iter,f,gpsupn - if((mod((iter-1),10).eq.0.or.iter.eq.0).and.iter.ne.1) then - write(*,778) - else if(mod(iter,10).eq.0) then - write(*,779) - else if(iter.ne.1) then - write(*,777) - end if - end if - - if ( iprint .ge. 3 ) then - write(*, 983) iter,ittype - write(*, 985) nprint,(x(i),i=1,nprint) - write(*, 986) nprint,(g(i),i=1,nprint) - write(*, 987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, - + nprint) - write(*, 988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, - + nind)) - write(*, 1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, - + spgiter,tniter,fcnt,gcnt,cgcnt - - write(10,983) iter,ittype - write(10,985) nprint,(x(i),i=1,nprint) - write(10,986) nprint,(g(i),i=1,nprint) - write(10,987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, - + nprint) - write(10,988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, - + nind)) - write(10,1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, - + spgiter,tniter,fcnt,gcnt,cgcnt - end if - -C ================================================================== -C Test some stopping criteria that may occur inside the line -C searches -C ================================================================== - - if ( inform .eq. 6 ) then - - if ( iprint .ge. 3 ) then - write(*, 996) inform,mininterp,epsrel,epsabs - write(10,996) inform,mininterp,epsrel,epsabs - end if - - go to 500 - - end if - -C ================================================================== -C Iterate -C ================================================================== - - go to 100 - -C ================================================================== -C End of main loop -C ================================================================== - -C ================================================================== -C Report output status and return -C ================================================================== - - 500 continue - -C Print final information - - if ( iprint .ge. 3 ) then - write(*, 982) iter - write(*, 985) nprint,(x(i),i=1,nprint) - write(*, 986) nprint,(g(i),i=1,nprint) - write(*, 987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, - + nprint) - write(*, 988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, - + nind)) - write(*, 1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, - + spgiter,tniter,fcnt,gcnt,cgcnt - - write(10,982) iter - write(10,985) nprint,(x(i),i=1,nprint) - write(10,986) nprint,(g(i),i=1,nprint) - write(10,987) nprint,(min(u(i),max(l(i),x(i)-g(i)))-x(i),i=1, - + nprint) - write(10,988) min0(nprint,nind),nind,(ind(i),i=1,min0(nprint, - + nind)) - write(10,1002) f,sqrt(gpeucn2),sqrt(gieucn2),gpsupn,nind,n, - + spgiter,tniter,fcnt,gcnt,cgcnt - end if - - return - -C Non-executable statements - - 977 format(/1X, 'Entry to GENCAN. Number of variables: ',I7) - 978 format(/1X,'Lower bounds (first ',I6, ' components): ', - */,6(1X,1PD11.4)) - 979 format(/1X,'Upper bounds (first ',I6, ' components): ', - */,6(1X,1PD11.4)) - 980 format(/1X,'Initial point (first ',I6, ' components): ', - */,6(1X,1PD11.4)) - 981 format(/1X,'GENCAN iteration: ',I6, ' (Initial point)') - 982 format(/1X,'GENCAN iteration: ',I6, ' (Final point)') - 983 format(/,1X,'GENCAN iteration: ',I6, - *' (This point was obtained using a ',A3,' iteration)') - 985 format(1X,'Current point (first ',I6, ' components): ', - */,6(1X,1PD11.4)) - 986 format(1X,'Current gradient (first ',I6, ' components): ', - */,6(1X,1PD11.4)) - 987 format(1X,'Current continuous projected gradient (first ',I6, - *' components): ',/,6(1X,1PD11.4)) - 988 format(1X,'Current free variables (first ',I6, - *', total number ',I6,'): ',/,10(1X,I6)) - 990 format(/1X,'Flag of GENCAN = ',I3, - *' (convergence with Euclidian-norm of the projected gradient', - */,1X,'smaller than ',1PD11.4,')') - 991 format(/1X,'Flag of GENCAN = ',I3, - *' (convergence with sup-norm of the projected gradient', - */,1X,'smaller than ',1PD11.4,')') - 992 format(/1X,'Flag of GENCAN= ',I3, - *' (The algorithm stopped by lack of enough progress. This means', - */,1X,'that f(x_k) - f(x_{k+1}) .le. ',1PD11.4, - *' * max [ f(x_j)-f(x_{j+1}, j < k ]',/,1X,'during ',I7, - *' consecutive iterations') - 993 format(/1X,'Flag of GENCAN = ',I3, - *' (The algorithm stopped because the order of the', - */,1X,'Euclidian-norm of the continuous projected gradient did', - *' not change during ',/,1X,I7,' consecutive iterations.', - *' Probably, an exaggerated small norm of the',/,1X,'continuous', - *' projected gradient is required for declaring convergence') - 994 format(/1X,'Flag of GENCAN = ',I3, - *' (The algorithm stopped because the functional value is', - */,1X,'smaller than ',1PD11.4) - 996 format(/1X,'Flag of GENCAN = ',I3, - *' (Too small step in a line search. After having made at ', - */,1X,'least ',I7,' interpolations, the steplength becames small.', - *' Small means that',/,1X,'we were at point x with direction d', - *' and took a step alpha such that',/,1X,'alpha * |d_i| .lt.', - *' max [',1PD11.4,' * |x_i|,',1PD11.4,' ] for all i)') - 997 format(/1X,'Flag of GENCAN = ',I3, - *' (It was exceeded the maximum allowed number of iterations', - */,1X,'(maxit=',I7,')') - 998 format(/1X,'Flag of GENCAN = ',I3, - *' (It was exceeded the maximum allowed number of functional', - */,1X,'evaluations (maxfc=',I7,')') - 1002 format(1X,'Functional value: ', 1PD11.4, - */,1X,'Euclidian-norm of the continuous projected gradient: ', - *1PD11.4, - */,1X,'Euclidian-norm of the internal projection of gp: ',1PD11.4, - */,1X,'Sup-norm of the continuous projected gradient: ',1PD11.4, - */,1X,'Free variables at this point: ',I7, - *' (over a total of ',I7,')', - */,1X,'SPG iterations: ',I7, - */,1X,'TN iterations: ',I7, - */,1X,'Functional evaluations: ',I7, - */,1X,'Gradient evaluations: ',I7, - */,1X,'Conjugate gradient iterations: ',I7) - 1003 format(6X,I6,T22,D17.6,T43,D17.6) -C1003 format(6X,'Iter = ',I6,' f = ',1PD11.4,' gpsupn = ',1PD11.4) - 1000 format(/1X,'Flag of GENCAN = ',I3,' Fatal Error') - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine spgls(n,x,m,lambda,rho,f,g,l,u,lamspg,nint,mininterp, - +fmin,maxfc,iprint,fcnt,inform,xtrial,d,gamma,sigma1,sigma2,sterel, - +steabs,epsrel,epsabs,infrel,infabs) - - implicit none - -C SCALAR ARGUMENTS - integer fcnt,m,maxfc,mininterp,n,inform,iprint - double precision epsabs,epsrel,f,fmin,gamma,infrel,infabs,lamspg, - + nint,sigma1,sigma2,steabs,sterel - -C ARRAY ARGUMENTS - double precision d(n),g(n),l(n),lambda(m),rho(m),u(n),x(n), - + xtrial(n) - -C Safeguarded quadratic interpolation, used in the Spectral -C Projected Gradient directions. -C -C On Entry -C -C n integer -C the order of the x -C -C x double precision x(n) -C current point -C -C m integer -C lambda double precision lambda(m) -C rho double precision rho(m) -C These three parameters are not used nor modified by -C GENCAN and they are passed as arguments to the user- -C defined subroutines evalal and evalnal to compute the -C objective function and its gradient, respectively. -C Clearly, in an Augmented Lagrangian context, if GENCAN is -C being used to solve the bound-constrainted subproblems, m -C would be the number of constraints, lambda the Lagrange -C multipliers approximation and rho the penalty parameters -C -C f double precision -C function value at the current point -C -C g double precision g(n) -C gradient vector at the current point -C -C l double precision l(n) -C lower bounds -C -C u double precision u(n) -C upper bounds -C -C lamspg double precision -C spectral steplength -C -C nint double precision -C constant for the interpolation. See the description of -C sigma1 and sigma2 above. Sometimes we take as a new -C trial step the previous one divided by nint -C -C RECOMMENDED: nint = 2.0 -C -C mininterp integer -C constant for testing if, after having made at least -C mininterp interpolations, the steplength is so small. In -C that case failure of the line search is declared (may be -C the direction is not a descent direction due to an error -C in the gradient calculations) -C -C RECOMMENDED: mininterp = 4 -C -C fmin double precision -C functional value for the stopping criterion f <= fmin -C -C maxfc integer -C maximum number of functional evaluations -C -C iprint integer -C Commands printing. Nothing is printed if iprint is -C smaller than 2. If iprint is greater than or equal to -C 2, GENCAN iterations information is printed. If iprint -C is greater than or equal to 3, line searches and -C Conjugate Gradients information is printed. -C -C RECOMMENDED: iprint = 2 -C -C CONSTRAINTS: allowed values are just 2 or 3. -C -C xtrial double precision xtrial(n) -C d double precision d(n) -C working vectors -C -C gamma double precision -C constant for the Armijo criterion -C f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d> -C -C RECOMMENDED: gamma = 10^{-4} -C -C sigma1 double precision -C sigma2 double precision -C constant for the safeguarded interpolation -C if alpha_new \notin [sigma1, sigma*alpha] then we take -C alpha_new = alpha / nint -C -C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 -C -C sterel double precision -C steabs double precision -C this constants mean a ``relative small number'' and ``an -C absolute small number'' for the increments in finite -C difference approximations of derivatives -C -C RECOMMENDED: epsrel = 10^{-7}, epsabs = 10^{-10} -C -C epsrel double precision -C epsabs double precision -C infrel double precision -C infabs double precision -C this constants mean a ``relative small number'', ``an -C absolute small number'', and ``infinite or a very big -C number''. Basically, a quantity A is considered -C negligible with respect to another quantity B if |A| < -C max ( epsrel * |B|, epsabs ) -C -C RECOMMENDED: epsrel = 10^{-10}, epsabs = 10^{-20}, -C infrel = 10^{+20}, infabs = 10^{+99} -C -C On Return -C -C x double precision -C final estimation of the solution -C -C f double precision -C functional value at the final estimation -C -C fcnt integer -C number of functional evaluations used in the line search -C -C inform integer -C This output parameter tells what happened in this -C subroutine, according to the following conventions: -C -C 0 = convergence with an Armijo-like criterion -C (f(xnew) <= f(x) + gamma * alpha * ); -C -C 4 = the algorithm stopped because the functional value -C is smaller than fmin; -C -C 6 = too small step in the line search. After having made -C at least mininterp interpolations, the steplength -C becames small. ''small steplength'' means that we are -C at point x with direction d and step alpha, and, for -C all i, -C -C | alpha * d(i) | <= max ( epsrel * |x(i)|, epsabs ). -C -C In that case failure of the line search is declared -C (maybe the direction is not a descent direction due -C to an error in the gradient calculations). Use -C mininterp > maxfc to inhibit this criterion; -C -C 8 = it was achieved the maximum allowed number of -C function evaluations (maxfc); -C -C < 0 = error in evalf subroutine. - -C LOCAL SCALARS - logical samep - integer i,interp - double precision alpha,atmp,ftrial,gtd - -C Print presentation information - - if ( iprint .ge. 4 ) then - write(*, 980) lamspg - write(10,980) lamspg - end if - -C Initialization - - interp = 0 - -C Compute first trial point, spectral projected gradient direction, -C and directional derivative . - - alpha = 1.0d0 - - gtd = 0.0d0 - do i = 1,n - xtrial(i) = min( u(i), max( l(i), x(i) - lamspg * g(i) ) ) - d(i) = xtrial(i) - x(i) - gtd = gtd + g(i) * d(i) - end do - - call evalal(n,xtrial,m,lambda,rho,ftrial,inform) - fcnt = fcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - -C Print information of the first trial - - if ( iprint .ge. 4 ) then - write(*, 999) alpha,ftrial,fcnt - write(10,999) alpha,ftrial,fcnt - end if - -C Main loop - - 100 continue - -C Test Armijo stopping criterion - - if ( ftrial .le. f + gamma * alpha * gtd ) then - - f = ftrial - - do i = 1,n - x(i) = xtrial(i) - end do - - inform = 0 - - if ( iprint .ge. 4 ) then - write(*, 990) inform - write(10,990) inform - end if - - go to 500 - - end if - -C Test whether f is very small - - if ( ftrial .le. fmin ) then - - f = ftrial - - do i = 1,n - x(i) = xtrial(i) - end do - - inform = 4 - - if ( iprint .ge. 4 ) then - write(*, 994) inform - write(10,994) inform - end if - - go to 500 - - end if - -C Test whether the number of functional evaluations is exhausted - - if ( fcnt .ge. maxfc ) then - - if ( ftrial .lt. f ) then - - f = ftrial - - do i = 1,n - x(i) = xtrial(i) - end do - - end if - - inform = 8 - - if ( iprint .ge. 4 ) then - write(*, 998) inform - write(10,998) inform - end if - - go to 500 - - end if - -C Compute new step (safeguarded quadratic interpolation) - - interp = interp + 1 - - if ( alpha .lt. sigma1 ) then - alpha = alpha / nint - - else - atmp = ( - gtd * alpha ** 2 ) / - + ( 2.0d0 * ( ftrial - f - alpha * gtd ) ) - - if ( atmp .lt. sigma1 .or. atmp .gt. sigma2 * alpha ) then - alpha = alpha / nint - - else - alpha = atmp - end if - end if - -C Compute new trial point - - do i = 1,n - xtrial(i) = x(i) + alpha * d(i) - end do - - call evalal(n,xtrial,m,lambda,rho,ftrial,inform) - fcnt = fcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - -C Print information of the current trial - - if ( iprint .ge. 4 ) then - write(*, 999) alpha,ftrial,fcnt - write(10,999) alpha,ftrial,fcnt - end if - -C Test whether at least mininterp interpolations were made and two -C consecutive iterates are close enough - - samep = .true. - do i = 1,n - if ( abs( alpha * d(i) ) .gt. - + max( epsrel * abs( x(i) ), epsabs ) ) then - samep = .false. - end if - end do - - if ( interp .ge. mininterp .and. samep ) then - - if ( ftrial .lt. f ) then - - f = ftrial - - do i = 1,n - x(i) = xtrial(i) - end do - - end if - - inform = 6 - - if ( iprint .ge. 4 ) then - write(*, 996) inform - write(10,996) inform - end if - - go to 500 - - end if - -C Iterate - - go to 100 - -C Return - - 500 continue - - return - -C Non-executable statements - - 980 format(/,6x,'SPG (spectral steplength ',1PD11.4,')',/,/, - * 6x,'SPG Line search') - 999 format(6x,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I5) - 990 format(6x,'Flag of SPG Line search = ',I3, - * ' (Convergence with an Armijo-like criterion)') - 994 format(6x,'Flag of SPG Line search = ',I3, - * ' (Small functional value, smaller than ',/, - * 6X,'parameter fmin)') - 996 format(6x,'Flag of SPG Line search = ',I3, - * ' (Too small step in the interpolation)') - 998 format(6x,'Flag of SPG Line search = ',I3, - * ' (Too many functional evaluations)') - 1000 format(6x,'Flag of SPG Line search = ',I3,' Fatal Error') - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine cg(nind,ind,n,x,m,lambda,rho,g,delta,l,u,eps,epsnqmp, - +maxitnqmp,maxit,nearlyq,gtype,htvtype,trtype,iprint,ncomp,s,iter, - +rbdtype,rbdind,inform,w,y,r,d,sprev,theta,sterel,steabs,epsrel, - +epsabs,infrel,infabs) - - implicit none - -C SCALAR ARGUMENTS - logical nearlyq - integer gtype,htvtype,inform,iprint,iter,m,maxit,maxitnqmp,n, - + ncomp,nind,trtype,rbdind,rbdtype - double precision delta,eps,epsnqmp,epsabs,epsrel,infrel,infabs, - + steabs,sterel,theta - -C ARRAY ARGUMENTS - integer ind(nind) - double precision d(n),g(n),l(n),lambda(m),r(n),rho(m),s(n), - + sprev(n),u(n),w(n),x(n),y(n) - -C This subroutine implements the Conjugate Gradients method for -C minimizing the quadratic approximation q(s) of f(x) at x, where -C -C q(s) = 1/2 s^T H s + g^T s, -C -C H = \nabla^2 f(x), -C -C g = \nabla f(x), -C -C subject to || s || <= delta and l <= x + s <= u. -C -C In the constraint ''|| s || <= delta'', the norm will be the -C Euclidian norm if the input parameter trtype is equal to 0, and -C it will be the Sup norm if trtype is equal to 1. -C -C The method returns an approximation s to the solution such that -C ||H s + g||_2 <= eps * ||g||_2; or converges to the boundary of -C ||s||_2 <= delta and l <= x + s <= u; or finds a point s and a -C direction d such that q(s + alpha d) = q(s) for any alpha, i.e., -C d^T H d = g^T d = 0. -C -C On Entry -C -C nind integer -C number of free variables (this is thee dimension in -C which this subroutine will work) -C -C ind integer ind(n) -C array which contains, in the first nind positions, the -C identifiers of the free variables -C -C n integer -C dimension of the full space -C -C x double precision x(n) -C point at which f function is being approximated by the -C quadratic model -C -C The first nind positions of x contains the free variables -C x_ind(1), x_ind(2), ..., x_ind(nind). -C -C m integer -C lambda double precision lambda(m) -C rho double precision rho(m) -C These three parameters are not used nor modified by -C GENCAN and they are passed as arguments to the user- -C defined subroutines evalal and evalnal to compute the -C objective function and its gradient, respectively. -C Clearly, in an Augmented Lagrangian context, if GENCAN is -C being used to solve the bound-constrainted subproblems, m -C would be the number of constraints, lambda the Lagrange -C multipliers approximation and rho the penalty parameters -C -C g double precision g(n) -C linear coefficient of the quadratic function -C -C This is \nabla f(x) and it also contains in the first -C nind positions the components g_ind(1), g_ind(2), ..., -C g_ind(nind). -C -C IMPORTANT: the linear algebra of this subroutine lies in -C a space of dimension nind. The value of the full -C dimension n, the non-free variables (which are at the end -C of array x) and its gradient components (which are at the -C and of array g) are, at this moment, being used to -C approximate the Hessian times vector products by -C incremental quotients. -C -C delta double precision -C trust region radius (||s||_2 <= delta) -C -C l double precision l(n) -C lower bounds on x + s. It components are ordered in the -C same way as x and g. -C -C u double precision u(n) -C upper bounds on x + s. It components are ordered in the -C same way as x, g and l. -C -C eps double precision -C tolerance for the stopping criterion ||H s + g||_2 < eps -C * ||g||_2 -C -C epsnqmp double precision -C See below -C -C maxitnqmp integer -C This and the previous one parameter are used for a -C stopping criterion of the conjugate gradient -C subalgorithm. If the progress in the quadratic model is -C less or equal than a fraction of the best progress -C ( epsnqmp * bestprog ) during maxitnqmp consecutive -C iterations then CG is stopped by not enough progress of -C the quadratic model. -C -C RECOMMENDED: epsnqmp = 1.0d-4, maxitnqmp = 5 -C -C maxit integer -C maximum number of iterations allowed -C -C nearlyq logical -C if function f is (nearly) quadratic, use the option -C nearlyq = TRUE. Otherwise, keep the default option. -C -C if, in an iteration of CG we find a direction d such that -C d^T H d <= 0 then we take the following decision: -C -C (i) if nearlyq = TRUE then take direction d and try to go -C to the boundary choosing the best point among the two -C point at the boundary and the current point. -C -C (ii) if nearlyq = FALSE then we stop at the current -C point. -C -C RECOMMENDED: nearlyq = FALSE -C -C gtype integer -C type of gradient calculation -C gtype = 0 means user suplied evalg subroutine, -C gtype = 1 means central difference approximation. -C -C RECOMMENDED: gtype = 0 -C -C (provided you have the evalg subroutine) -C -C htvtype integer -C type of Hessian times vector product calculation -C htvtype = 0 means user supplied evalhd subroutine, -C htvtype = 1 means incremental quotients approximation. -C -C RECOMMENDED: htvtype = 1 -C -C (you take some risk using this option but, unless you -C have a good evalhd subroutine, incremental quotients is a -C very cheap option) -C -C trtype integer -C type of trust-region radius -C trtype = 0 means 2-norm trust-region -C trtype = 1 means infinite-norm trust-region -C -C RECOMMENDED: trtype = 0 -C -C iprint integer -C Commands printing. Nothing is printed if iprint is -C smaller than 2. If iprint is greater than or equal to -C 2, GENCAN iterations information is printed. If iprint -C is greater than or equal to 3, line searches and -C Conjugate Gradients information is printed. -C -C RECOMMENDED: iprint = 2 -C -C CONSTRAINTS: allowed values are just 2 or 3. -C -C ncomp integer -C This constant is just for printing. In a detailed -C printing option, ncomp component of some vectors will be -C printed -C -C RECOMMENDED: ncomp = 5 -C -C CONSTRAINTS: ncomp >= 0 -C -C w double precision w(n) -C y double precision y(n) -C r double precision r(n) -C d double precision d(n) -C sprev double precision sprev(n) -C working vectors -C -C theta double precision -C constant for the angle condition, i.e., at iteration k we -C need a direction d_k such that <= - theta -C ||gk||_2 ||dk||_2, where gk is \nabla f(xk) -C -C RECOMMENDED: theta = 10^{-6} -C -C sterel double precision -C steabs double precision -C this constants mean a ``relative small number'' and ``an -C absolute small number'' for the increments in finite -C difference approximations of derivatives -C -C RECOMMENDED: epsrel = 10^{-7}, epsabs = 10^{-10} -C -C epsrel double precision -C epsabs double precision -C infrel double precision -C infabs double precision -C this constants mean a ``relative small number'', ``an -C absolute small number'', and ``infinite or a very big -C number''. Basically, a quantity A is considered -C negligible with respect to another quantity B if |A| < -C max ( epsrel * |B|, epsabs ) -C -C RECOMMENDED: epsrel = 10^{-10}, epsabs = 10^{-20}, -C infrel = 10^{+20}, infabs = 10^{+99} -C -C On Return -C -C s double precision s(n) -C final estimation of the solution -C -C iter integer -C number of Conjugate Gradient iterations performed -C -C inform integer -C termination parameter: -C -C 0 = convergence with ||H s + g||_2 <= eps * ||g||_2; -C -C 1 = convergence to the boundary of ||s||_2 <= delta; -C -C 2 = convergence to the boundary of l - x <= s <= u - x; -C -C 3 = stopping with s = sk such that <= -t heta -C ||gk||_2 ||sk||_2 and > - theta -C ||gk||_2 ||s_{k+1}||_2; -C -C 4 = not enough progress of the quadratic model during -C maxitnqmp iterations, i.e., during maxitnqmp -C iterations | q - qprev | <= max ( epsrel * | q |, -C epsabs ); -C -C 6 = very similar consecutive iterates, for two -C consecutive iterates x and y, for all i | x(i) - -C y(i) | <= max ( epsrel * | x(i) |, epsabs ); -C -C 7 = stopping with d such that d^T H d = 0 and g^T d = 0; -C -C 8 = too many iterations; -C -C < 0 = error in evalhd subroutine. - -C LOCAL SCALARS - character * 5 rbdtypea - logical samep - integer i,itnqmp,rbdnegaind,rbdnegatype,rbdposaind,rbdposatype - double precision aa,alpha,amax,amax1,amax1n,amaxn,amax2,amax2n, - + amax2nx,amax2x,bb,bestprog,beta,cc,currprog,dd,dnorm2,dtr, - + dts,dtw,gnorm2,gts,norm2s,q,qamax,qamaxn,qprev,rnorm2, - + rnorm2prev,snorm2,snorm2prev - -C ================================================================== -C Initialization -C ================================================================== - - gnorm2 = norm2s(nind,g) - - iter = 0 - itnqmp = 0 - qprev = infabs - bestprog = 0.0d0 - - do i = 1,nind - s(i) = 0.0d0 - r(i) = g(i) - end do - - q = 0.0d0 - gts = 0.0d0 - snorm2 = 0.0d0 - rnorm2 = gnorm2 - -C ================================================================== -C Print initial information -C ================================================================== - - if ( iprint .ge. 4 ) then - write(*, 980) maxit,eps - if ( trtype .eq. 0 ) then - write(*, 981) delta - else if ( trtype .eq. 1 ) then - write(*, 982) delta - else - write(*, 983) - end if - write(*, 984) iter,rnorm2,sqrt(snorm2),q - - write(10,980) maxit,eps - if ( trtype .eq. 0 ) then - write(10,981) delta - else if ( trtype .eq. 1 ) then - write(10,982) delta - else - write(10,983) - end if - write(10,984) iter,rnorm2,sqrt(snorm2),q - - end if - -C ================================================================== -C Main loop -C ================================================================== - - 100 continue - -C ================================================================== -C Test stopping criteria -C ================================================================== - -C if ||r||_2 = ||H s + g||_2 <= eps * ||g||_2 then stop - - if ( rnorm2 .le. 1.0d-16 .or. - + ( ( rnorm2 .le. eps ** 2 * gnorm2 .or. - + ( rnorm2 .le. 1.0d-10 .and. iter .ne. 0 ) ) - + .and. iter .ge. 4 ) ) then - - inform = 0 - - if ( iprint .ge. 4 ) then - write(*, 990) inform - write(10,990) inform - end if - - go to 500 - - end if - -C if the maximum number of iterations was achieved then stop - - if ( iter .ge. max(4, maxit) ) then - - inform = 8 - - if ( iprint .ge. 4 ) then - write(*, 998) inform - write(10,998) inform - end if - - go to 500 - - end if - -C ================================================================== -C Compute direction -C ================================================================== - - if ( iter .eq. 0 ) then - - do i = 1,nind - d(i) = - r(i) - end do - - dnorm2 = rnorm2 - dtr = - rnorm2 - - else - - beta = rnorm2 / rnorm2prev - - do i = 1,nind - d(i) = - r(i) + beta * d(i) - end do - - dnorm2 = rnorm2 - 2.0d0 * beta * ( dtr + alpha * dtw ) + - + beta ** 2 * dnorm2 - dtr = - rnorm2 + beta * ( dtr + alpha * dtw ) - - end if - -C Force d to be a descent direction of q(s), i.e., -C <\nabla q(s), d> = = \le 0. - - if ( dtr .gt. 0.0d0 ) then - - do i = 1,nind - d(i) = - d(i) - end do - dtr = - dtr - - end if - -C ================================================================== -C Compute d^T H d -C ================================================================== - -C w = A d - - if ( htvtype .eq. 0 ) then - call calchd(nind,ind,x,d,g,n,x,m,lambda,rho,w,y,sterel,steabs, - + inform) - - else if ( htvtype .eq. 1 ) then - call calchddiff(nind,ind,x,d,g,n,x,m,lambda,rho,gtype,w,y, - + sterel,steabs,inform) - end if - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - end if - -C Compute d^T w and ||w||^2 - - dtw = 0.0d0 - do i = 1,nind - dtw = dtw + d(i) * w(i) - end do - -C ================================================================== -C Compute maximum step -C ================================================================== - -C amax1 > 0 and amax1n < 0 are the values of alpha such that -C ||s + alpha * d||_2 or ||s + alpha * d||_\infty = delta - - dts = 0.0d0 - do i = 1,nind - dts = dts + d(i) * s(i) - end do - -C Euclidian-norm trust radius - - if ( trtype .eq. 0 ) then - - aa = dnorm2 - bb = 2.0d0 * dts - cc = snorm2 - delta ** 2 - dd = sqrt( bb ** 2 - 4.0d0 * aa * cc ) - - amax1 = ( - bb + dd ) / ( 2.0d0 * aa ) - amax1n = ( - bb - dd ) / ( 2.0d0 * aa ) - -C Sup-norm trust radius - - else if ( trtype .eq. 1 ) then - - amax1 = infabs - amax1n = -infabs - - do i = 1,nind - if ( d(i) .gt. 0.0d0 ) then - amax1 = min( amax1, ( delta - s(i) ) / d(i) ) - amax1n = max( amax1n, ( - delta - s(i) ) / d(i) ) - else if ( d(i) .lt. 0.0d0 ) then - amax1 = min( amax1, ( - delta - s(i) ) / d(i) ) - amax1n = max( amax1n, ( delta - s(i) ) / d(i) ) - end if - end do - - end if - -C amax2 > 0 and amax2n < 0 are the maximum and the minimum values of -C alpha such that l - x <= s + alpha * d <= u - x, respectively - - amax2 = infabs - amax2n = - infabs - - do i = 1,nind - if ( d(i) .gt. 0.0d0 ) then -C if (u(i).lt.infrel) then - amax2x = ( u(i) - x(i) - s(i) ) / d(i) - if ( amax2x .lt. amax2 ) then - amax2 = amax2x - rbdposaind = i - rbdposatype = 2 - end if -C end if -C if (l(i).gt.-infrel) then - amax2nx = ( l(i) - x(i) - s(i) ) / d(i) - if ( amax2nx .gt. amax2n ) then - amax2n = amax2nx - rbdnegaind = i - rbdnegatype = 1 - end if -C end if - else if ( d(i) .lt. 0.0d0 ) then -C if (l(i).gt.-infrel) then - amax2x = ( l(i) - x(i) - s(i) ) / d(i) - if ( amax2x .lt. amax2 ) then - amax2 = amax2x - rbdposaind = i - rbdposatype = 1 - end if -C end if -C if (u(i).lt.infrel) then - amax2nx = ( u(i) - x(i) - s(i) ) / d(i) - if ( amax2nx .gt. amax2n ) then - amax2n = amax2nx - rbdnegaind = i - rbdnegatype = 2 - end if -C end if - end if - end do - -C Compute amax as the minimum among amax1 and amax2, and amaxn as -C the minimum among amax1n and amax2n. Moreover change amaxn by -C - amaxn to have amax and amaxn as maximum steps along d direction -C (and not -d in the case of amaxn) - - amax = min( amax1 , amax2 ) - amaxn = max( amax1n, amax2n ) - -C ================================================================== -C Compute the step (and the quadratic functional value at the new -C point) -C ================================================================== - - qprev = q - -C If d^T H d > 0 then take the conjugate gradients step - - if ( dtw .gt. 0.0d0 ) then - - alpha = min( amax, rnorm2 / dtw ) - - q = q + 0.5d0 * alpha ** 2 * dtw + alpha * dtr - -C If d^T H d <= 0 and function f is nearly quadratic then take the -C point with the minimum functional value (q) among the current one -C and the ones which are at the boundary, i.e., the best one between -C q(s), q(s + amax*d) and q(s + amaxn*d). - - else - - qamax = q + 0.5d0 * amax ** 2 * dtw + amax * dtr - -C If we are at iteration zero then take the maximum positive -C step in the minus gradient direction - - if ( iter .eq. 0 ) then - - alpha = amax - q = qamax - -C If we are not in the first iteration then if function f is -C nearly quadratic and q(s + amax * d) or q(s + amaxn * d) is -C smaller than q(s), go to the best point in the boundary - - else - - qamaxn = q + 0.5d0 * amaxn ** 2 * dtw + amaxn * dtr - - if ( nearlyq .and. - + ( qamax .lt. q .or. qamaxn .lt. q ) ) then - - if ( qamax .lt. qamaxn ) then - alpha = amax - q = qamax - else - alpha = amaxn - q = qamaxn - end if - -C Else, stop at the current point - - else - - inform = 7 - - if ( iprint .ge. 4 ) then - write(*, 997) inform - write(10,997) inform - end if - - go to 500 - - end if - - end if - end if - -C ================================================================== -C Compute new s -C ================================================================== - - do i = 1,nind - sprev(i) = s(i) - s(i) = s(i) + alpha * d(i) - end do - - snorm2prev = snorm2 - snorm2 = snorm2 + alpha ** 2 * dnorm2 + 2.0d0 * alpha * dts - -C ================================================================== -C Compute the residual r = H s + g -C ================================================================== - - rnorm2prev = rnorm2 - - do i = 1,nind - r(i) = r(i) + alpha * w(i) - end do - - rnorm2 = norm2s(nind,r) - -C ================================================================== -C Increment number of iterations -C ================================================================== - - iter = iter + 1 - -C ================================================================== -C Print information of this iteration -C ================================================================== - - if ( iprint .ge. 4 ) then - write(*, 984) iter,sqrt(rnorm2),sqrt(snorm2),q - write(10,984) iter,sqrt(rnorm2),sqrt(snorm2),q - end if - -C ================================================================== -C Test other stopping criteria -C ================================================================== - -C Test angle condition - - gts = 0.0d0 - do i = 1,nind - gts = gts + g(i) * s(i) - end do - - if ( gts .gt. 0.0d0 .or. - + gts ** 2 .lt. theta ** 2 * gnorm2 * snorm2 ) then - - do i = 1,nind - s(i) = sprev(i) - end do - - snorm2 = snorm2prev - - q = qprev - - inform = 3 - - if ( iprint .ge. 4 ) then - write(*, 993) inform - write(10,993) inform - end if - - go to 500 - - end if - -C If we are in the boundary of the box also stop - - if ( alpha .eq. amax2 .or. alpha .eq. amax2n ) then - - if ( alpha .eq. amax2 ) then - rbdind = rbdposaind - rbdtype = rbdposatype - else ! if (alpha.eq.amax2n) then - rbdind = rbdnegaind - rbdtype = rbdnegatype - end if - - if ( rbdtype .eq. 1 ) then - rbdtypea = 'lower' - else ! if (rbdtype.eq.2) then - rbdtypea = 'upper' - end if - - inform = 2 - - if ( iprint .ge. 4 ) then - write(*, 992) inform,ind(rbdind),rbdtypea - write(10,992) inform,ind(rbdind),rbdtypea - end if - - go to 500 - - end if - -C If we are in the boundary of the trust region then stop - - if ( alpha .eq. amax1 .or. alpha .eq. amax1n ) then - - inform = 1 - - if ( iprint .ge. 4 ) then - write(*, 991) inform - write(10,991) inform - end if - - go to 500 - - end if - -C If two consecutive iterates are much close then stop - - samep = .true. - do i = 1,nind - if ( abs( alpha * d(i) ) .gt. - + max( epsrel * abs( s(i) ), epsabs ) ) then - samep = .false. - end if - end do - - if ( samep ) then - - inform = 6 - - if ( iprint .ge. 4 ) then - write(*, 996) inform - write(10,996) inform - end if - - go to 500 - - end if - -C Test whether we performed many iterations without good progress of -C the quadratic model - -C if (abs( q - qprev ) .le. max( epsrel * abs( qprev ), epsabs ) ) -C +then - -C itnqmp = itnqmp + 1 - -C if ( itnqmp .ge. maxitnqmp ) then - -C inform = 4 - -C if ( iprint .ge. 4 ) then -C write(*,994) inform,itnqmp -C write(10,994) inform,itnqmp -C end if - -C go to 500 - -C endif - -C else -C itnqmp= 0 -C endif - -C Test whether we performed many iterations without good progress of -C the quadratic model - - currprog = qprev - q - bestprog = max( currprog, bestprog ) - - if ( currprog .le. epsnqmp * bestprog ) then - - itnqmp = itnqmp + 1 - - if ( itnqmp .ge. maxitnqmp ) then - inform = 4 - - if ( iprint .ge. 4 ) then - write(*, 994) inform,itnqmp,epsnqmp,bestprog - write(10,994) inform,itnqmp,epsnqmp,bestprog - end if - - go to 500 - endif - - else - itnqmp = 0 - endif - -C ================================================================== -C Iterate -C ================================================================== - - go to 100 - -C ================================================================== -C End of main loop -C ================================================================== - -C ================================================================== -C Return -C ================================================================== - - 500 continue - -C Print final information - - if ( iprint .ge. 4 ) then - write(*, 985) min0(nind,ncomp),(s(i),i=1,min0(nind,ncomp)) - write(10,985) min0(nind,ncomp),(s(i),i=1,min0(nind,ncomp)) - end if - - return - -C Non-executable statements - - 980 format(/,6x,'Conjugate gradients (maxit= ',I7,' acc= ',1PD11.4, - *')') - 981 format(6x,'Using Euclidian trust region (delta= ',1PD11.4, - *')') - 982 format(6x,'Using sup-norm trust region (delta= ',1PD11.4,')') - 983 format(6x,'Unknown trust-region type') - 984 format(6x,'CG iter= ',I5,' rnorm: ',1PD11.4,' snorm= ',1PD11.4, - *' q= ',1PD11.4) - 985 format(/,6x,'Truncated Newton direction (first ',I6, - *' components): ',/,1(6x,6(1PD11.4,1x))) - 990 format(6x,'Flag of CG = ',I3,' (Convergence with small residual)') - 991 format(6x,'Flag of CG = ',I3, - *' (Convergence to the trust region boundary)') - 992 format(6x,'Flag of CG = ',I3, - *' (Convergence to the boundary of the box constraints,',/,6x, - *'taking step >= 1, variable ',I6,' will reaches its ',A5, - *' bound)') - 993 format(6x,'Flag of CG = ',I3, - *' (The next CG iterate will not satisfy the angle condition)') - 994 format(6x,'Flag of CG = ',I3, - *' (Not enough progress in the quadratic model. This means',/,6x, - *'that the progress of the last ',I7,' iterations was smaller ', - *'than ',/,6x,1PD11.4,' times the best progress (',1PD11.4,')') - 996 format(6x,'Flag of CG = ',I3, - *' (Very near consecutive iterates)') - 997 format(6x,'Flag of CG= ',I3, - *' (d such that d^T H d = 0 and g^T d = 0 was found)') - 998 format(6x,'Flag of CG = ',I3,' (Too many GC iterations)') - 1000 format(6x,'Flag of CG = ',I3,' Fatal Error') - - end - -C ***************************************************************** -C ***************************************************************** - subroutine tnls(nind,ind,n,x,m,lambda,rho,l,u,f,g,d,amax,rbdtype, - +rbdind,nint,next,mininterp,maxextrap,fmin,maxfc,gtype,iprint,fcnt, - +gcnt,intcnt,exgcnt,exbcnt,inform,xplus,xtmp,xbext,gamma,beta, - +sigma1,sigma2,sterel,steabs,epsrel,epsabs,infrel,infabs) - - implicit none - -C SCALAR ARGUMENTS - integer exbcnt,exgcnt,fcnt,gcnt,gtype,inform,intcnt,iprint,m, - + maxextrap,maxfc,mininterp,n,nind,rbdind,rbdtype - double precision amax,beta,epsabs,epsrel,f,fmin,gamma,infabs, - + infrel,next,nint,sigma1,sigma2,steabs,sterel - -C ARRAY ARGUMENTS - integer ind(nind) - double precision d(n),g(n),l(n),lambda(m),rho(m),u(n),x(n), - + xbext(n),xplus(n),xtmp(n) - -C This subroutine implements the line search used in the Truncated -C Newton direction. -C -C On Entry -C -C nind integer -C number of free variables (this is thee dimension in -C which this subroutine will work) -C -C ind integer ind(n) -C array which contains, in the first nind positions, the -C identifiers of the free variables -C -C n integer -C dimension of the full space -C -C x double precision x(n) -C current point -C -C The first nind positions of x contains the free variables -C x_ind(1), x_ind(2), ..., x_ind(nind). -C -C m integer -C lambda double precision lambda(m) -C rho double precision rho(m) -C These three parameters are not used nor modified by -C GENCAN and they are passed as arguments to the user- -C defined subroutines evalal and evalnal to compute the -C objective function and its gradient, respectively. -C Clearly, in an Augmented Lagrangian context, if GENCAN is -C being used to solve the bound-constrainted subproblems, m -C would be the number of constraints, lambda the Lagrange -C multipliers approximation and rho the penalty parameters -C -C l double precision l(nind) -C lower bounds on x. It components are ordered in the -C same way as x and g. -C -C u double precision u(nind) -C upper bounds on x. It components are ordered in the -C same way as x, g and l. -C -C f double precision -C functional value at x -C -C g double precision g(n) -C gradient vector at x -C -C It also contains in the first nind positions the -C components g_ind(1), g_ind(2), ..., g_ind(nind). -C -C IMPORTANT: the linear algebra of this subroutine lies in -C a space of dimension nind. The value of the full -C dimension n, the non-free variables (which are at the end -C of array x) and its gradient components (which are at the -C end of array g) are also used and updated any time the -C gradient is being computed. -C -C d double precision d(nind) -C descent direction -C -C amax double precision -C -C rbdtype integer -C -C rbdind integer -C -C nint double precision -C constant for the interpolation. See the description of -C sigma1 and sigma2 above. Sometimes we take as a new -C trial step the previous one divided by nint -C -C RECOMMENDED: nint = 2.0 -C -C next double precision -C constant for the extrapolation -C when extrapolating we try alpha_new = alpha * next -C -C RECOMMENDED: next = 2.0 -C -C mininterp integer -C constant for testing if, after having made at least -C mininterp interpolations, the steplength is so small. -C In that case failure of the line search is declared (may -C be the direction is not a descent direction due to an -C error in the gradient calculations) -C -C RECOMMENDED: mininterp = 4 -C -C maxextrap integer -C constant to limit the number of extrapolations -C -C RECOMMENDED: maxextrap = 1000 (a big number) -C -C fmin double precision -C functional value for the stopping criteria f <= fmin -C -C maxfc integer -C maximum number of functional evaluations -C -C gtype integer -C type of gradient calculation -C gtype = 0 means user suplied evalg subroutine, -C gtype = 1 means central difference approximation. -C -C RECOMMENDED: gtype = 0 -C -C (provided you have the evalg subroutine) -C -C iprint integer -C Commands printing. Nothing is printed if iprint is -C smaller than 2. If iprint is greater than or equal to -C 2, GENCAN iterations information is printed. If iprint -C is greater than or equal to 3, line searches and -C Conjugate Gradients information is printed. -C -C RECOMMENDED: iprint = 2 -C -C CONSTRAINTS: allowed values are just 2 or 3. -C -C xplus double precision xplus(nind) -C xtmp double precision xtmp(nind) -C xbext double precision xbext(nind) -C working vectors -C -C gamma double precision -C constant for the Armijo criterion -C f(x + alpha d) <= f(x) + gamma * alpha * <\nabla f(x),d> -C -C RECOMMENDED: gamma = 10^{-4} -C -C beta double precision -C constant for the beta condition < beta -C * . If (xk + dk) satisfies the Armijo condition -C but does not satisfy the beta condition then the point is -C accepted, but if it satisfied the Armijo condition and -C also satisfies the beta condition then we know that there -C is the possibility for a successful extrapolation -C -C RECOMMENDED: beta = 0.5 -C -C sigma1 double precision -C sigma2 double precision -C constant for the safeguarded interpolation -C if alpha_new \notin [sigma1, sigma*alpha] then we take -C alpha_new = alpha / nint -C -C RECOMMENDED: sigma1 = 0.1 and sigma2 = 0.9 -C -C sterel double precision -C steabs double precision -C this constants mean a ``relative small number'' and ``an -C absolute small number'' for the increments in finite -C difference approximations of derivatives -C -C RECOMMENDED: epsrel = 10^{-7}, epsabs = 10^{-10} -C -C epsrel double precision -C epsabs double precision -C infrel double precision -C infabs double precision -C this constants mean a ``relative small number'', ``an -C absolute small number'', and ``infinite or a very big -C number''. Basically, a quantity A is considered -C negligible with respect to another quantity B if -C |A| < max ( epsrel * |B|, epsabs ) -C -C RECOMMENDED: epsrel = 10^{-10}, epsabs = 10^{-20}, -C infrel = 10^{+20}, infabs = 10^{+99} -C -C On Return -C -C x double precision x(n) -C new current point -C -C f double precision -C functional value at x -C -C g double precision g(n) -C gradient vector at x -C -C fcnt integer -C number of functional evaluations used in this line search -C -C gcnt integer -C number of gradient evaluations used in this line search -C -C intcnt integer -C number of interpolations -C -C exgcnt integer -C number of good extrapolations -C -C exbcnt integer -C number of bad extrapolations -C -C inform integer -C This output parameter tells what happened in this -C subroutine, according to the following conventions: -C -C 0 = convergence with an Armijo-like criterion -C (f(xnew) <= f(x) + 1.0d-4 * alpha * ); -C -C 4 = the algorithm stopped because the functional value -C is very small (f <= fmin); -C -C 6 = so small step in the line search. After having made -C at least mininterp interpolations, the steplength -C becames small. ``small steplength'' means that we are -C at point x with direction d and step alpha, and, for -C all i, -C -C |alpha * d(i)| .le. max ( epsrel * |x(i)|, epsabs ). -C -C In that case failure of the line search is declared -C (may be the direction is not a descent direction -C due to an error in the gradient calculations). Use -C mininterp > maxfc for inhibit this criterion; -C -C 8 = it was achieved the maximum allowed number of -C function evaluations (maxfc); -C -C < 0 = error in evalf or evalg subroutines. - -C LOCAL SCALARS - logical samep - integer extrap,i,interp - double precision alpha,atmp,fbext,fplus,ftmp,gptd,gtd - -C ================================================================== -C Initialization -C ================================================================== - -C ================================================================== -C Compute directional derivative -C ================================================================== - - gtd = 0.0d0 - do i = 1,nind - gtd = gtd + g(i) * d(i) - end do - -C ================================================================== -C Compute first trial -C ================================================================== - - alpha = min( 1.0d0, amax ) - - do i = 1,nind - xplus(i) = x(i) + alpha * d(i) - end do - - if ( alpha .eq. amax ) then - if ( rbdtype .eq. 1 ) then - xplus(rbdind) = l(rbdind) - else ! if (rbdtype.eq.2) then - xplus(rbdind) = u(rbdind) - end if - end if - - call calcf(nind,ind,xplus,n,x,m,lambda,rho,fplus,inform) - fcnt = fcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - -C Print initial information - - if ( iprint .ge. 4 ) then - write(*, 980) amax - write(*, 999) alpha,fplus,fcnt - - write(10,980) amax - write(10,999) alpha,fplus,fcnt - end if - -C ================================================================== -C Test Armijo and beta-condition and decide for accepting the trial -C point, interpolate or extrapolate. -C ================================================================== - - if ( amax .gt. 1.0d0 ) then - -C x + d belongs to the interior of the feasible set - if ( iprint .ge. 4 ) then - write(*, *) ' x+d belongs to int of the feasible set' - write(10,*) ' x+d belongs to int of the feasible set' - end if - -C Verify Armijo - - if ( fplus .le. f + gamma * alpha * gtd ) then - -C Armijo condition holds - if ( iprint .ge. 4 ) then - write(*, *) ' Armijo condition holds' - write(10,*) ' Armijo condition holds' - end if - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,xplus,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,xplus,n,x,m,lambda,rho,g, - + sterel,steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - gptd = 0.0d0 - do i = 1,nind - gptd = gptd + g(i) * d(i) - end do - -C Verify directional derivative (beta condition) - - if ( gptd .lt. beta * gtd ) then - -C Extrapolate - if ( iprint .ge. 4 ) then - write(*, *)' The beta-condition does not hold' - write(*, *)' We will extrapolate' - write(10,*)' The beta-condition does not hold' - write(10,*)' We will extrapolate' - end if - -C f and x before extrapolation - fbext = fplus - - do i = 1,nind - xbext(i) = xplus(i) - end do - - go to 100 - - else - -C Step = 1 was ok, finish the line search - if ( iprint .ge. 4 ) then - write(*, *) ' The beta condition is also true' - write(*, *) ' Line search is over' - write(10,*) ' The beta condition is also true' - write(10,*) ' Line search is over' - end if - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - - inform = 0 - - if ( iprint .ge. 4 ) then - write(*, 990) inform - write(10,990) inform - end if - - go to 500 - - end if - - else - -C Interpolate - if ( iprint .ge. 4 ) then - write(*, *) ' Armijo does not hold' - write(*, *) ' We will interpolate' - write(10,*) ' Armijo does not hold' - write(10,*) ' We will interpolate' - end if - - go to 200 - - end if - - else - -C x + d does not belong to the feasible set (amax <= 1) - if ( iprint .ge. 4 ) then - write(*, *) ' x+d does not belong to box-interior' - write(10,*) ' x+d does not belong to box-interior' - end if - - if ( fplus .lt. f ) then - -C Extrapolate - if ( iprint .ge. 4 ) then - write(*, *) ' f(x+d) < f(x)' - write(*, *) ' We will extrapolate' - write(10,*) ' f(x+d) < f(x)' - write(10,*) ' We will extrapolate' - end if - -C f and x before extrapolation - fbext = fplus - - do i = 1,nind - xbext(i) = xplus(i) - end do - - go to 100 - - else - -C Interpolate - if ( iprint .ge. 4 ) then - write(*, *) ' f(x+d) >= f(x)' - write(*, *) ' We will interpolate' - write(10,*) ' f(x+d) >= f(x)' - write(10,*) ' We will interpolate' - end if - - go to 200 - - end if - - end if - - -C ================================================================== -C Extrapolation -C ================================================================== - - 100 continue - - extrap = 0 - -C Test f going to -inf - - 120 if ( fplus .le. fmin ) then - -C Finish the extrapolation with the current point - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - - if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - if ( f .lt. fbext ) then - exgcnt = exgcnt + 1 - else - exbcnt = exbcnt + 1 - end if - - end if - - inform = 4 - - if ( iprint .ge.3 ) then - write(*, 994) inform - write(10,994) inform - end if - - go to 500 - - end if - -C Test maximum number of functional evaluations - - if ( fcnt .ge. maxfc ) then - -C Finish the extrapolation with the current point - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - -C If extrap=0 and amax>1 the gradient was computed for testing -C the beta condition and it is not necessary to compute it again - if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - if ( f .lt. fbext ) then - exgcnt = exgcnt + 1 - else - exbcnt = exbcnt + 1 - end if - - end if - - inform = 8 - - if ( iprint .ge. 4 ) then - write(*, 998) inform - write(10,998) inform - end if - - go to 500 - - end if - -C Test if the maximum number of extrapolations was exceeded - - if ( extrap .ge. maxextrap ) then - -C Finish the extrapolation with the current point - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - -C If extrap=0 and amax>1 the gradient was computed for testing -C the beta condition and it is not necessary to compute it again - if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - if ( f .lt. fbext ) then - exgcnt = exgcnt + 1 - else - exbcnt = exbcnt + 1 - end if - - end if - - inform = 7 - - if ( iprint .ge. 4 ) then - write(*, 997) inform - write(10,997) inform - end if - - go to 500 - - end if - -C Chose new step - - if ( alpha .lt. amax .and. next * alpha .gt. amax ) then - atmp = amax - else - atmp = next * alpha - end if - -C Compute new trial point - - do i = 1,nind - xtmp(i) = x(i) + atmp * d(i) - end do - - if ( atmp .eq. amax ) then - if ( rbdtype .eq. 1 ) then - xtmp(rbdind) = l(rbdind) - else ! if ( rbdtype .eq. 2 ) then - xtmp(rbdind) = u(rbdind) - end if - end if - -C Project - - if ( atmp .gt. amax ) then - do i = 1,nind - xtmp(i) = max( l(i), min( xtmp(i), u(i) ) ) - end do - end if - -C Test if this is not the same point as the previous one. -C This test is performed only when alpha > amax. - - if( alpha .gt. amax ) then - - samep = .true. - do i = 1,nind - if ( abs( xtmp(i) - xplus(i) ) .gt. - + max( epsrel * abs( xplus(i) ), epsabs ) ) then - samep = .false. - end if - end do - - if ( samep ) then - -C Finish the extrapolation with the current point - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - -C If extrap=0 and amax>1 the gradient was computed for -C testing the beta condition and it is not necessary to -C compute it again - if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g, - + sterel,steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - if ( f .lt. fbext ) then - exgcnt = exgcnt + 1 - else - exbcnt = exbcnt + 1 - end if - - end if - - inform = 0 - - if ( iprint .ge. 4 ) then - write(*, 990) inform - write(10,990) inform - end if - - go to 500 - - end if - - end if - -C Evaluate function - - call calcf(nind,ind,xtmp,n,x,m,lambda,rho,ftmp,inform) - fcnt = fcnt + 1 - - if ( inform .lt. 0 ) then - -C if ( iprint .ge. 4 ) then -C write(*, 1000) inform -C write(10,1000) inform -C end if - -C return - -C If the objective function is not well defined in an -C extrapolated point, we discard all the extrapolated points -C and return to a safe region (where the point before -C starting the extrapolations is) - - f = fbext - - do i = 1,nind - x(i) = xbext(i) - end do - -C If extrap=0 and amax>1 the gradient was computed for testing -C the beta condition and it is not necessary to compute it again - if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - exbcnt = exbcnt + 1 - - end if - - inform = 0 - - if ( iprint .ge. 4 ) then - write(*, 1010) inform - write(10,1010) inform - end if - - go to 500 - - end if - -C Print information of this iteration - - if ( iprint .ge. 4 ) then - write(*, 999) atmp,ftmp,fcnt - write(10,999) atmp,ftmp,fcnt - end if - -C If the functional value decreases then set the current point and -C continue the extrapolation - - if ( ftmp .lt. fplus ) then - - alpha = atmp - - fplus = ftmp - - do i = 1,nind - xplus(i) = xtmp(i) - end do - - extrap = extrap + 1 - - go to 120 - -C If the functional value does not decrease then discard the last -C trial and finish the extrapolation with the previous point - - else - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - -C If extrap=0 and amax>1 the gradient was computed for testing -C the beta condition and it is not necessary to compute it again - if ( extrap .ne. 0 .or. amax .le. 1.0d0 ) then - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - if ( f .lt. fbext ) then - exgcnt = exgcnt + 1 - else - exbcnt = exbcnt + 1 - end if - - end if - - inform = 0 - - if ( iprint .ge.3 ) then - write(*, 990) inform - write(10,990) inform - end if - - go to 500 - - end if -C ================================================================== -C End of extrapolation -C ================================================================== - -C ================================================================== -C Interpolation -C ================================================================== - - 200 continue - - intcnt = intcnt + 1 - - interp = 0 - - 210 continue - -C Test f going to -inf - - if ( fplus .le. fmin ) then - -C Finish the interpolation with the current point - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - inform = 4 - - if ( iprint .ge. 4 ) then - write(*, 994) inform - write(10,994) inform - end if - - go to 500 - - end if - -C Test maximum number of functional evaluations - - if ( fcnt .ge. maxfc ) then - -C As this is an abrupt termination then the current point of the -C interpolation may be worst than the initial one - -C If the current point is better than the initial one then -C finish the interpolation with the current point else discard -C all we did inside this line search and finish with the initial -C point - - if ( fplus .lt. f ) then - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - end if - - inform = 8 - - if ( iprint .ge. 4 ) then - write(*, 998) inform - write(10,998) inform - end if - - go to 500 - - end if - -C Test Armijo condition - - if ( fplus .le. f + gamma * alpha * gtd ) then - -C Finish the line search - - f = fplus - - do i = 1,nind - x(i) = xplus(i) - end do - - if ( gtype .eq. 0 ) then - call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) - else if ( gtype .eq. 1 ) then - call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g,sterel, - + steabs,inform) - end if - gcnt = gcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - - inform = 0 - - if ( iprint .ge. 4 ) then - write(*, 990) inform - write(10,990) inform - end if - - go to 500 - - end if - -C Compute new step - - interp = interp + 1 - - if ( alpha .lt. sigma1 ) then - alpha = alpha / nint - - else - atmp = ( - gtd * alpha **2 ) / - + (2.0d0 * ( fplus - f - alpha * gtd ) ) - - if ( atmp .lt. sigma1 .or. atmp .gt. sigma2 * alpha ) then - alpha = alpha / nint - - else - alpha = atmp - end if - end if - -C Compute new trial point - - do i = 1,nind - xplus(i) = x(i) + alpha * d(i) - end do - - call calcf(nind,ind,xplus,n,x,m,lambda,rho,fplus,inform) - fcnt = fcnt + 1 - - if ( inform .lt. 0 ) then - - if ( iprint .ge. 4 ) then - write(*, 1000) inform - write(10,1000) inform - end if - - return - - end if - -C Print information of this iteration - - if ( iprint .ge. 4 ) then - write(*, 999) alpha,fplus,fcnt - write(10,999) alpha,fplus,fcnt - end if - -C Test whether at least mininterp interpolations were made and two -C consecutive iterates are much close - - samep = .true. - do i = 1,nind - if ( abs( alpha * d(i) ) .gt. - + max( epsrel * abs( x(i) ), epsabs ) ) then - samep = .false. - end if - end do - - if ( interp .ge. mininterp .and. samep ) then - -C As this is an abrupt termination then the current point of the -C interpolation may be worst than the initial one - -C If the current point is better than the initial one then -C finish the interpolation with the current point else discard -C all we did inside this line search and finish with the initial -C point - -C if ( fplus .lt. f ) then - -C f = fplus - -C do i = 1,nind -C x(i) = xplus(i) -C end do - -C if ( gtype .eq. 0 ) then -C call calcg(nind,ind,x,n,x,m,lambda,rho,g,inform) -C else if ( gtype .eq. 1 ) then -C call calcgdiff(nind,ind,x,n,x,m,lambda,rho,g, -c + sterel,steabs,inform) -C end if -C gcnt = gcnt + 1 - -C if ( inform .lt. 0 ) then - -C if ( iprint .ge. 4 ) then -C write(*, 1000) inform -C write(10,1000) inform -C end if - -C return - -C end if - -C end if - -C The previous lines were commented because, as it is been used, -C this subroutine must return with the initial point in case of -C finding a very small interpolation step. From that initial -C point, something different will be tried. - - inform = 6 - - if ( iprint .ge. 4 ) then - write(*, 996) inform - write(10,996) inform - end if - - go to 500 - - end if - -C Else, iterate - - go to 210 -C ================================================================== -C End of interpolation -C ================================================================== - - 500 continue - -C ================================================================== -C Return -C ================================================================== - - return - -C Non-executable statements - - 980 format(/,6X,'TN Line search (alphamax= ',1PD11.4,')') - 999 format(6X,'Alpha= ',1PD11.4,' F= ',1PD11.4,' FE= ',I5) - 990 format(6X,'Flag of TN Line search= ',I3, - + ' (Convergence with an Armijo-like criterion)') - 994 format(6X,'Flag of TN Line search= ',I3, - + ' (Small functional value, smaller than ',/, - + 6X,'parameter fmin)') - 996 format(6X,'Flag of TN Line search= ',I3, - + ' (Too small step in the interpolation)') - 997 format(6X,'Flag of TN Line search= ',I3, - + ' (Too many extrapolations)') - 998 format(6X,'Flag of TN Line search= ',I3, - + ' (Too many functional evaluations)') - 1000 format(6X,'Flag of TN Line search = ',I3,' Fatal Error') - 1010 format(6X,'Flag of TN Line search= ',I3, - + ' (Fatal Error in an extrapolated point)') - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine calcf(nind,ind,x,n,xc,m,lambda,rho,f,inform) - - implicit none - -C SCALAR ARGUMENTS - integer nind,n,m,inform - double precision f - -C ARRAY ARGUMENTS - integer ind(nind) - double precision x(n),xc(n),lambda(m),rho(m) - -C This subroutines computes the objective function. -C -C It is called from the reduced space (dimension nind), expands the -C point x where the function will be evaluated and call the -C subroutine evalf to compute the objective function Finally, -C shrinks vector x to the reduced space. -C -C About subroutines named calc[something]. The subroutines whos -C names start with ``calc'' work in (are called from) the reduced -C space. Their tasks are (i) expand the arguments to the full space, -C (ii) call the corresponding ``eval'' subroutine (which works in -C the full space), and (iii) shrink the parameters again and also -C shrink a possible output of the ``eval'' subroutine. Subroutines -C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. -C The corresponding subroutines in the full space are the user -C defined subroutines evalf, evalg and evalhd. - -C LOCAL SCALARS - integer i - -C Complete x - - do i = nind + 1,n - x(i) = xc(i) - end do - -C Expand x to the full space - - call expand(nind,ind,n,x) - -C Compute f calling the user supplied subroutine evalf - - call evalal(n,x,m,lambda,rho,f,inform) - -C Shrink x to the reduced space - - call shrink(nind,ind,n,x) - - return - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine calcg(nind,ind,x,n,xc,m,lambda,rho,g,inform) - - implicit none - -C SCALAR ARGUMENTS - integer nind,n,m,inform - -C ARRAY ARGUMENTS - integer ind(nind) - double precision x(n),xc(n),lambda(m),rho(m),g(n) - -C This subroutine computes the gradient vector g of the objective -C function. -C -C It is called from the reduced space (dimension nind), expands the -C point x where the gradient will be evaluated and calls the user -C supplied subroutine evalg to compute the gradient vector. Finally, -C shrinks vectors x and g to the reduced space. -C -C About subroutines named calc[something]. The subroutines whos -C names start with ``calc'' work in (are called from) the reduced -C space. Their tasks are (i) expand the arguments to the full space, -C (ii) call the corresponding ``eval'' subroutine (which works in -C the full space), and (iii) shrink the parameters again and also -C shrink a possible output of the ``eval'' subroutine. Subroutines -C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. -C The corresponding subroutines in the full space are the user -C defined subroutines evalf, evalg and evalhd. - -C LOCAL SCALARS - integer i - -C Complete x - - do i = nind + 1,n - x(i) = xc(i) - end do - -C Expand x to the full space - - call expand(nind,ind,n,x) - -C Compute the gradient vector calling the user supplied subroutine -C evalg - - call evalnal(n,x,m,lambda,rho,g,inform) - -C Shrink x and g to the reduced space - - call shrink(nind,ind,n,x) - call shrink(nind,ind,n,g) - - return - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine calcgdiff(nind,ind,x,n,xc,m,lambda,rho,g,sterel,steabs, - +inform) - - implicit none - -C SCALAR ARGUMENTS - integer nind,n,m,inform - double precision sterel,steabs - -C ARRAY ARGUMENTS - integer ind(nind) - double precision x(n),xc(n),lambda(m),rho(m),g(n) - -C This subroutine approximates the gradient vector g of the -C objective function in the reduced space using central finite -C differences. -C -C It is called from the reduced space (dimension nind), expands the -C point x where the gradient will be estimated and calls evalf -C subroutine (to evaluate the objective function) 2 * nind times. -C Finally, shrinks vectors x and g to the reduced space. -C -C About subroutines named calc[something]. The subroutines whos -C names start with ``calc'' work in (are called from) the reduced -C space. Their tasks are (i) expand the arguments to the full space, -C (ii) call the corresponding ``eval'' subroutine (which works in -C the full space), and (iii) shrink the parameters again and also -C shrink a possible output of the ``eval'' subroutine. Subroutines -C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. -C The corresponding subroutines in the full space are the user -C defined subroutines evalf, evalg and evalhd. - -C LOCAL SCALARS - integer i,indi - double precision fminus,fplus,step,tmp - -C Complete x - - do i = nind + 1,n - x(i) = xc(i) - end do - -C Expand x to the full space - - call expand(nind,ind,n,x) - -C Approximate the gradient vector by central finite differences - - do i = 1,nind - indi = ind(i) - - tmp = x(indi) - step = max( steabs, sterel * abs( tmp ) ) - - x(indi) = tmp + step - call evalal(n,x,m,lambda,rho,fplus,inform) - if ( inform .lt. 0 ) then - return - end if - - x(indi) = tmp - step - call evalal(n,x,m,lambda,rho,fminus,inform) - if ( inform .lt. 0 ) then - return - end if - - g(indi) = ( fplus - fminus ) / ( 2.0d0 * step ) - x(indi) = tmp - end do - -C Shrink x and g to the reduced space - - call shrink(nind,ind,n,x) - call shrink(nind,ind,n,g) - - return - - end - - -C ****************************************************************** -C ****************************************************************** - - subroutine calchd(nind,ind,x,d,g,n,xc,m,lambda,rho,hd,xtmp,sterel, - +steabs,inform) - - implicit none - -C SCALAR ARGUMENTS - integer inform,m,n,nind - double precision steabs,sterel - -C ARRAY ARGUMENTS - integer ind(nind) - double precision d(n),g(n),hd(n),lambda(m),rho(m),x(n),xc(n), - + xtmp(n) - -C This subroutine computes the product Hessian times vector d. As it -C is called from the reduced space, it expands vectors x and d, -C calls the user supplied subroutine evalhd to compute the Hessian -C times vector d product, and shrinks vectors x, d and hd. -C -C About subroutines named calc[something]. The subroutines whos -C names start with ``calc'' work in (are called from) the reduced -C space. Their tasks are (i) expand the arguments to the full space, -C (ii) call the corresponding ``eval'' subroutine (which works in -C the full space), and (iii) shrink the parameters again and also -C shrink a possible output of the ``eval'' subroutine. Subroutines -C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. -C The corresponding subroutines in the full space are the user -C defined subroutines evalf, evalg and evalhd. - -C LOCAL SCALARS - integer i - -C Complete d with zeroes - - do i = nind + 1,n - d(i) = 0.0d0 - end do - -C Complete x - - do i = nind + 1,n - x(i) = xc(i) - end do - -C Expand x and d to the full space - - call expand(nind,ind,n,x) - call expand(nind,ind,n,d) - call expand(nind,ind,n,g) - -C Compute the Hessian times vector d product calling the user -C supplied subroutine evalhd - - call evalhd(n) - -C Shrink x, d and hd to the reduced space - - call shrink(nind,ind,n,x) - call shrink(nind,ind,n,d) - call shrink(nind,ind,n,g) - call shrink(nind,ind,n,hd) - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine calchddiff(nind,ind,x,d,g,n,xc,m,lambda,rho,gtype,hd, - +xtmp,sterel,steabs,inform) - - implicit none - -C SCALAR ARGUMENTS - integer gtype,inform,m,n,nind - double precision steabs,sterel - -C ARRAY ARGUMENTS - integer ind(nind) - double precision d(n),g(n),hd(n),lambda(m),rho(m),x(n),xc(n), - + xtmp(n) - -C This subroutine computes the Hessian times vector d product by -C means of a ``directional finite difference''. The idea is that, at -C the current point x, the product H d is the limit of -C -C [ Gradient(x + t d) - Gradient(x) ] / t -C -C In this implementation we use -C -C t = max(steabs, sterel ||x||_\infty) / ||d||_\infty -C -C provided that d is not equal 0, of course. -C -C So, we evaluate the Gradient at the auxiliary point x + t d and -C use the quotient above to approximate H d. To compute the gradient -C vector at the auxiliary point it is used evalg or evalgdiff -C depending on gtype parameter. -C -C About subroutines named calc[something]. The subroutines whos -C names start with ``calc'' work in (are called from) the reduced -C space. Their tasks are (i) expand the arguments to the full space, -C (ii) call the corresponding ``eval'' subroutine (which works in -C the full space), and (iii) shrink the parameters again and also -C shrink a possible output of the ``eval'' subroutine. Subroutines -C of this type are: calcf, calcg, calchd, calcgdiff and calchddiff. -C The corresponding subroutines in the full space are the user -C defined subroutines evalf, evalg and evalhd. - -C On Entry -C -C n integer -C order of the x -C -C x double precision x(n) -C point for which Hessian(x) times d will be approximated -C -C d double precision d(n) -C vector for which the Hessian times vetor product will -C be approximated -C -C g double precision g(n) -C gradient at x -C -C xtmp double precision xtmp(n) -C working vector -C -C sterel double precision -C steabs double precision -C these constants mean a ``relative small number'' and -C ``an absolute small number'' -C -C On Return -C -C hd double precision hd(n) -C approximation of H d - -C LOCAL SCALARS - integer flag,i,indi - double precision dsupn,step,tmp,xsupn - - inform = 0 - -C Compute incremental quotients step - - xsupn = 0.0d0 - dsupn = 0.0d0 - do i = 1,nind - xsupn = max( xsupn, abs( x(i) ) ) - dsupn = max( dsupn, abs( d(i) ) ) - end do - -c Safeguard added by LM - if(dsupn.lt.1.d-20) dsupn = 1.d-20 - - step = max( sterel * xsupn, steabs ) / dsupn - -C Set the point at which the gradient will be evaluated - - do i = 1,nind - xtmp(i) = x(i) + step * d(i) - end do - -C Evaluate the gradient at xtmp = x + step * d - - if ( gtype .eq. 0 ) then - -C Complete xtmp - - do i = nind + 1,n - xtmp(i) = xc(i) - end do - -C Expand xtmp to the full space - - do i = nind,1,-1 - indi = ind(i) - if ( i .ne. indi ) then - tmp = xtmp(indi) - xtmp(indi) = xtmp(i) - xtmp(i) = tmp - end if - end do - -c Compute the gradient at xtmp = x + step * d - - call evalnal(n,xtmp,m,lambda,rho,hd,flag) - -C Shrink hd to the reduced space - - do i= 1, nind - indi= ind(i) - if (i.ne.indi) then - tmp = hd(indi) - hd(indi) = hd(i) - hd(i) = tmp - end if - end do - - else if ( gtype .eq. 1 ) then - - call calcgdiff(nind,ind,xtmp,n,xc,m,lambda,rho,hd,sterel, - + steabs,inform) - - end if - -C Compute incremental quotients - - do i = 1,nind - hd(i) = ( hd(i) - g(i) ) / step - end do - - return - - end - - -C ****************************************************************** -C ****************************************************************** - - subroutine shrink(nind,ind,n,v) - - implicit none - -C SCALAR ARGUMENTS - integer n,nind - -C ARRAY ARGUMENTS - integer ind(nind) - double precision v(n) - -C This subroutine shrinks vector v from the full dimension space -C (dimension n) to the reduced space (dimension nind). -C -C On entry: -C -C nind integer -C dimension of the reduced space -C -C ind integer ind(nind) -C components ind(1)-th, ..., ind(nind)-th are the -C components that belong to the reduced space -C -C n integer -C dimension of the full space -C -C v double precision v(n) -C vector to be shrinked -C -C On Return -C -C v double precision v(n) -C shrinked vector - -C LOCAL SCALARS - integer i,indi - double precision tmp - - do i = 1,nind - indi = ind(i) - if ( i .ne. indi ) then - tmp = v(indi) - v(indi) = v(i) - v(i) = tmp - end if - end do - - return - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine expand(nind,ind,n,v) - - implicit none - -C SCALAR ARGUMENTS - integer n, nind - -C ARRAY ARGUMENTS - integer ind(nind) - double precision v(n) - -C This subroutine expands vector v from the reduced space -C (dimension nind) to the full space (dimension n). -C -C On entry: -C -C nind integer -C dimension of the reduced space -C -C ind integer ind(nind) -C components ind(1)-th, ..., ind(nind)-th are the -C components that belong to the reduced space -C -C n integer -C dimension of the full space -C -C v double precision v(n) -C vector to be expanded -C -C On Return -C -C v double precision v(n) -C expanded vector - -C LOCAL SCALARS - integer i,indi - double precision tmp - - do i = nind,1,- 1 - indi = ind(i) - if ( i .ne. indi ) then - tmp = v(indi) - v(indi) = v(i) - v(i) = tmp - end if - end do - - return - - end - -C ****************************************************************** -C ****************************************************************** - - subroutine evalnaldiff(n,x,m,lambda,rho,g,sterel,steabs,inform) - - implicit none - -C SCALAR ARGUMENTS - integer n,m,inform - double precision sterel,steabs - -C ARRAY ARGUMENTS - double precision x(n),lambda(m),rho(m),g(n) - -C Approximates the gradient vector g(x) of the objective function by -C central finite differences. This subroutine, which works in the -C full space, is prepared to replace the subroutine evalnal (to -C evaluate the gradient vector) in the case of the lastest have not -C being provided by the user. -C -C On entry: -C -C n integer -C number of variables -C -C x double precision x(n) -C current point -C -C m integer -C lambda double precision lambda(m) -C rho double precision rho(m) -C These three parameters are not used nor modified by -C GENCAN and they are passed as arguments to the user- -C defined subroutines evalal and evalnal to compute the -C objective function and its gradient, respectively. -C Clearly, in an Augmented Lagrangian context, if GENCAN is -C being used to solve the bound-constrainted subproblems, m -C would be the number of constraints, lambda the Lagrange -C multipliers approximation and rho the penalty parameters -C -C sterel double precision -C See below -C -C steabs double precision -C This constants mean a ''relative small number'' and ''an -C absolute small number'' for the increments in finite -C difference approximations of derivatives -C -C RECOMMENDED: epsrel = 1.0d-07 and epsabs = 1.0d-10 -C -C CONSTRAINTS: sterel >= steabs > 0 -C -C On Return -C -C g double precision g(n) -C approximation of the gradient vector at x -C -C inform integer -C 0 = no errors, -C < 0 = there was an error in the gradient calculation. - -C LOCAL SCALARS - integer j - double precision tmp,step,fplus,fminus - - inform = 0 - - do j = 1,n - tmp = x(j) - step = max( steabs, sterel * abs( tmp ) ) - - x(j) = tmp + step - call evalal(n,x,m,lambda,rho,fplus,inform) - if ( inform .lt. 0 ) then - return - end if - - x(j) = tmp - step - call evalal(n,x,m,lambda,rho,fminus,inform) - if ( inform .lt. 0 ) then - return - end if - - g(j) = ( fplus - fminus ) / ( 2.0d0 * step ) - x(j) = tmp - end do - - return - - end - -C ***************************************************************** -C ***************************************************************** - - double precision function norm2s(n,x) - - implicit none - -C SCALAR ARGUMENTS - integer n - -C ARRAY ARGUMENTS - double precision x(n) - -C This subroutine computes the squared Euclidian norm of an -C n-dimensional vector. -C -C On entry: -C -C n integer -C dimension -C -C x double precision x(n) -C vector -C -C On return: -C -C The function return the squared Euclidian norm of the -C n-dimensional vector x. - - external hsldnrm2 - double precision hsldnrm2 - - norm2s = hsldnrm2(n,x,1) ** 2 - - return - - end - -C ****************************************************************** -C ****************************************************************** - - DOUBLE PRECISION FUNCTION HSLDNRM2(N,DX,INCX) - DOUBLE PRECISION ZERO,ONE - PARAMETER (ZERO=0.0D0,ONE=1.0D0) - DOUBLE PRECISION CUTLO,CUTHI - PARAMETER (CUTLO=8.232D-11,CUTHI=1.304D19) - INTEGER INCX,N - DOUBLE PRECISION DX(*) - DOUBLE PRECISION HITEST,SUM,XMAX - INTEGER I,J,NN - INTRINSIC DABS,DSQRT,FLOAT - IF (N.GT.0) GO TO 10 - HSLDNRM2 = ZERO - GO TO 300 - 10 CONTINUE - SUM = ZERO - NN = N*INCX - I = 1 - 20 CONTINUE - 30 IF (DABS(DX(I)).GT.CUTLO) GO TO 85 - XMAX = ZERO - 50 IF (DX(I).EQ.ZERO) GO TO 200 - IF (DABS(DX(I)).GT.CUTLO) GO TO 85 - GO TO 105 - 100 I = J - SUM = (SUM/DX(I))/DX(I) - 105 XMAX = DABS(DX(I)) - GO TO 115 - 70 IF (DABS(DX(I)).GT.CUTLO) GO TO 75 - 110 IF (DABS(DX(I)).LE.XMAX) GO TO 115 - SUM = ONE + SUM* (XMAX/DX(I))**2 - XMAX = DABS(DX(I)) - GO TO 200 - 115 SUM = SUM + (DX(I)/XMAX)**2 - GO TO 200 - 75 SUM = (SUM*XMAX)*XMAX - 85 HITEST = CUTHI/DFLOAT(N) - DO 95 J = I,NN,INCX - IF (DABS(DX(J)).GE.HITEST) GO TO 100 - SUM = SUM + DX(J)**2 - 95 END DO - HSLDNRM2 = DSQRT(SUM) - GO TO 300 - 200 CONTINUE - I = I + INCX - IF (I.LE.NN) GO TO 20 - HSLDNRM2 = XMAX*DSQRT(SUM) - 300 CONTINUE - RETURN - END - -C ****************************************************************** -C ****************************************************************** -C -C Report of modifications. -C -C February 18th, 2005. -C -C 1) An unsed format statement, previously used to automaticaly -C generates some tables, was deleted. -C -C 2) An unmateched parenthesis was corrected in the format -C statement used to stop GENCAN due to a small step in a line search. -C -C February 16th, 2005. -C -C 1) The evalhd subroutine used by default in GENCAN is now the one -C implemented in calchddiff, which approximates the Hessian-vector -C product by incremental quotients. The implementation used to -C overcome the non twice continuously differentiability of the -C classical (PHR) Augmented Lagrangian function is now part of -C ALGENCAN (and not GENCAN). So, to use GENCAN inside ALGENCAN, -C htvtype argument must be set equal to 0 (ZERO). -C -C 2) The commented version of the empty function evalhd that must -C be added when GENCAN is beinf used stand-alone was wrong. The -C arguments declarations had been copied from evalnal. It was -C corrected. -C -C November 10th, 2004. -C -C 1) After several test, all references to nonmontone line search -C schemes were deleted. -C -C September 28th, 2004. -C -C 1) Subroutines were checked an some absent arguments explanations -C were added -C -C 2) Some calling sequences were modified to group related arguments -C -C 3) Arguments and local variables declarations were reordered in -C alphabetical order. -C -C 3) Shrink and expand subroutines were modified to deal with just -C one vector at a time. In this way, they are now being called from -C calc* subroutines. -C -C September 27th, 2004. -C -C 1) All comments were arranged to fit into the 72-columns format -C -C 2) Unused variable goth, which was prepared to indicate whether -C the Hessian matrix have been evaluated at the current point, was -C deleted from CG subroutine. -C -C 3) A spell check was used to correct the comments -C -C September 21th, 2004. -C -C 1) In the stopping criterion where the progress in the objective -C function is verified, ''itnfp .ge. maxitnfp'' was changed for -C ''itnfp .gt. maxitnfp'', to make the choice maxitnfp equal to 1 -C sounds reasonable. -C -C 2) Moreover, the previous chance came from the addition in the -C comments of GENCAN of the ''constraints'' information which makes -C clear to the user the values each argument may assume. -C -C 3) In the calculations of the first ''trust-radius'' for Conjugate -C Gradients, ''if( udelta0 .lt. 0.d0 ) then'' was changed by ''if -C ( udelta0 .le. 0.0d0 ) then'' to also make the default GENCAN -C choice of this initial trust-radius in the case of the user have -C been setted udelta = 0 by mistake. -C -C 4) The same for ucgmaxit. -C -C 5) In the line search subroutines spgls and tnls, ''if ( interp -C .gt. mininterp .and. samep ) then'' was changes by ''.ge.''. -C -C 6) Some comments of GENCAN arguments were re-written. -C -C September 16th, 2004. -C -C 1) With the reconfiguration of the calc* subroutines (see (1) -C below) there were a number of redundant parameters in calchd and -C evalhd subroutines. These parameters were eliminated. -C -C September 13th, 2004. -C -C 1) Subroutines named calc* that work in the reduced space always -C call the corresponding eval* subroutine. As it was, calcg (that -C computes the gradient in the reduced space) called evalg or -C evalgdiff depending on gtype parameter. The same was for calchd. -C Now, calcg calls evalg, calchd calls evalhd, and calchddiff (new) -C approximates the Hessian times vector product by incremental -C quotients calling calcg or calcgdiff depending on gtype parameter. -C An improvement of this modification is that calcg does not call -C evalg or evalgdiff (both work in the full space) any more but it -C approximates the gradient vector in the reduced space (by central -C finite differences) calling 2 * nind times evalf subroutine. -C -C 2) Some comments were added inside evalg and evalhd user supplied -C subroutines alerting about the relation of these subroutines and -C the parameters gtype and htvtype, respectively. -C -C 3) Description of tnls subroutine was slightly modified. -C -C 4) The description of htvtype parameter in gencan was again -C slightly modified. -C -C 5) With the introduction of the parameter lambda (that in the -C context of Augmented Lagrangians is used to store the -C approximation of the Lagrange multipliers) the name of the -C variable used for spectral steplength was changed from lambda to -C lamspg. In addition, lammax was changed to lspgma and lammin to -C lspgmi. -C -C 6) Modifications introduced in June 15th, 2004 and May 5th, 2004 -C were, in fact, made in this version on September 13th, 2004. -C -C June 15th, 2004. -C -C 1) The fmin stopping criterion and the maximum number of -C functional evaluation stopping criterion were erroneously being -C tested before the main loop. It was just redundant and, for this -C reason, deleted. -C -C May 5th, 2004. -C -C 1) Incorporated into an Augmented Lagrangian framework. -C -C a) evalf and evalg were renamed as evalal and evalnal, -C respectively. -C -C b) m,lambda,rho were added as parameters of the subroutines evalal -C and evalnal, and, as a consequence, as parameters of almost all -C the other subroutines. -C -C 2) The comment of htvtype parameter of gencan was in portuguese -C and it was translated into english. -C -C 3) A nonmonotone version of gencan is starting to be studied. -C Parameters p and lastfv(0:p-1) were added to gencan, spgls, and -C tnls to allow a nonmonotone line search. Array lastfv is now -C been updated for saving the last p functional values and the -C nonmonotone line searches are been done in a SPG or a -C Truncated Newton direction. p = 1 means monotone line search -C and is recommended until this study finish. -C -C April 13th, 2004. -C -C 1) The modifications introduced in the occasion of the IRLOC -C development and re-development (October 21th, 2003 and February -C 19th, 2003, respectively) were in fact made in this version on -C April 13th, 2004. The motivation to do this was to unify two -C parallel and different version of GENCAN (created, obviously, by -C mistake). -C -C 2) The complete reference of the GENCAN paper was finally added. -C -C May 14th, 2003. -c -C 1) The way amax2 and amax2n were being computing may caused a -C segmentation fault. Its initialization was changed from infty and -C -infty to 1.0d+99 and -1.0d+99, respectively. Using infty, when -C combined with a big trust region radius, the final value of amax2 -C or amax2n may cause the impression that a bound is being attained, -C when it is not. "Redundant" ifs inside the amax2 and anax2n -C calculation were deleted. It should considered the possibility of -C using two constants, namely, bignum = 1.0d+20 and infty = 1.0d+99, -C instead of just infty. -C -C Modification introduced in October 21, 2003 in occasion of the -C IRLOC re-development: -C -C 1) The stooping criteria related to functional value smaller than -C fmin and exhaustion of maximum allowed number of functional -C evaluations have been done after the line search. And the -C questions were done as "if line search flag is equal to 4" or "if -C line search flag is equal to 8". But it was wrong in the case, for -C example, inside the line search, a functional value such that f <= -C fmin and the Armijo criterion was satisfied. In such case, the -C line search flag was being setted to 0 and not to 4. And gencan -C did not stop by the fmin criterion. Now, both stooping criteria -C are tested at the begining of the main gencan loop and just the -C stooping criteria by small line search step is tested after the -C line search. -C -C Modification introduced in February 19, 2003 in occasion of the -C IRLOC development: -C -C 1) The description of epsnfp parameter of GENCAN was modified. It -C was written that to inhibit the related stopping criterion (lack -C of function progress) it was necessary just set epsnfp = 0 when -C it is also necessary to set maxitnfp = maxit. it was added in the -C explanation. -C -C 2) In the explanation at the beginning of GENCAN it was written -C that cgscre parameter should be double precision. This comment was -C wrong. The correct type for cgscre parameter is integer. -C -C Modifications introduced near April 1st 2003 in occasion of the -C PHR and inequality-constraints Augmented Lagrangian methods -C development: -C -C 1) The use of iprint was redefined and iprint2 was deleted. -C -C 2) The way to detect no progress in the log of the projected -C gradient norm was changed. As it was, ''no progress'' means no -C reduction in the projected gradient norm over M iterations. -C But this criterion implicitly assumed that the projected -C gradient norm must decrease monotonously. Is it is clearly not -C true, the criterion was changed by a non-monotone decrease -C criterion. Now, progress means that the projected gradient -C norm is, at each iteration, smaller than the maximum over the -C last M iterations. And "no progress" means the it does not -C occurs during not smaller than the -C -C 3 ) The computation of qamaxn inside cg subroutine was in the -C wrong place (it was being used before computed) and it may was -C the reason for which the option nearlyq = .true. never worked -C properly. With this correction this option should be tested again. -C -C On September 29th, 2004, we did a new test using the 41 bound -C constrained problems with quadratic objective function from the -C CUTE collection. The behaviour of GENCAN setting nearly equal -C to true or false was indistinguishable. The test did not -C include the different choices for the maximum number of CG -C iterations being restricted to evaluate the different -C alternatives for the case of finding a direction d such that -C d^t H d <= 0. As a conclusion of this experiment we continue -C recommending as a default choice to set nearlyq equal to false. -C -C Modifications introduced from March 1st to March 21th of 2002 -C in occasion of the ISPG development: -C -C 1) Comments of some new parameters introduced in the previous -C modification -C -C 2) As it was, in the first iteration of GENCAN (when kappa takes -C value equal 1) and for one-dimensional faces, cgmaxit(the maximum -C number of Conjugate Gradient iterations to compute the internal to -C the face truncated-Newton direction) was being 0. As it is -C obviously wrong, we add a max between what was being computed and -C one to allow at least one CG iteration. -C -C 3) Parameter inform in subroutines evalf, evalg and evalhd -C supplied by the user was added -C -C Modifications introduced from May 31th to November 2nd of 2001 -C in occasion of the ALGENCAN development: -C -C Fixed bugs: -C -C 1) The first spectral steplength was not been projected in the -C [lspgmi,lspgma] interval. -C -C 2) The conjugate gradients accuracy (cgeps) which is linearly -C dependent of the Euclidian norm of the projected gradient, was -C also not been projected in the interval [cgepsi,cgepsf]. -C -C 3) Conjugate gradients said that it was being used an Euclidian -C norm trust region when it has really being used an infinite norm -C trust region and viceversa. -C -C 4) Sometimes, the analytic gradient has been used although the -C user choose the finite differences option. -C -C Modifications: -C -C 1) To avoid roundoff errors, an explicit detection of at least one -C variable reaching its bound when a maximum step is being made was -C added. -C -C 2) The way in which two points were considered very similar in, -C for example, the interpolations and the extrapolations (which was -C dependent of the infinity norm of the points) showed to be very -C scale dependent. A new version which test the difference -C coordinate to coordinate was done. In this was the calculus of the -C current point x and the descent direction sup-norm is not done any -C more. -C -C 3) The same constants epsrel and epsabs were used as small -C relative and absolute values for, for example, detecting similar -C points and for finite differences. Now, epsrel and epsabs are used -C for detecting similar points (and the recommended values are -C 10^{-10} and 10^{-20}, respectively) and new constants sterel and -C steabs were introduced for finite differences (and the recommended -C values are 10^{-7} and 10^{-10}, respectively). -C -C 4) Two new stopping criteria for CG were added: (i) we stop if -C two consecutive iterates are too close; and (ii) we also -C stop if there is no enough quadratic model progress during -C maxitnqmp iterations. -C -C 5) The linear relation between the conjugate gradient accuracy -C and the norm of the projected gradient can be computed using -C the Euclidian- and the sup-norm of the projected gradient (only -C Euclidian norm version was present in the previous version. The -C linear relation is such that the CG accuracy is cgepsi when the -C projected gradient norm value is equal to the value corresponding -C to the initial guess and the CG accuracy is cgepsf when the -C projected gradient norm value is cgrelf). -C -C 6) Inside Conjugate Gradients, the Euclidian-norm is been computed -C using an algorithm developed by C.L.LAWSON, 1978 JAN 08. Numerical -C experiments showed that the performance of GENCAN depends -C basically on the conjugate gradients performance and stopping -C criteria and that the conjugate gradients depends on the way the -C Euclidian-norm is been computed. These things deserve further -C research. -C -C 7) In the Augmented Lagrangian algorithm ALGENCAN, which uses -C GENCAN to solve the bounded constrained subproblems, the maximum -C number of Conjugate Gradients iterations (cgmaxit), which in this -C version is linearly dependent of the projected gradient norm, was -C set to 2 * (# of free variables). As CG is not using restarts we -C do not know very well what this means. On the other hand, the -C accuracy (given by cgeps) continues being more strict when we are -C near to the solution and less strict when we ar far from the -C solution. -c -C 8) Many things in the output were changed. From c47ab2485f42bbf0f5c46b6e6cf2ec34a6bc3b15 Mon Sep 17 00:00:00 2001 From: "Federico E. Benelli" Date: Wed, 21 Dec 2022 23:04:32 -0300 Subject: [PATCH 4/4] fpm compatiblity --- CMakeLists.txt | 76 ++++++++++++------------ Makefile | 157 +++++++++++++++++++++++++------------------------ 2 files changed, 117 insertions(+), 116 deletions(-) diff --git a/CMakeLists.txt b/CMakeLists.txt index ca6bbe5..4d33196 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -14,44 +14,44 @@ endif() # Build the executable add_executable(packmol - exit_codes.f90 - cenmass.f90 - gencan.f - pgencan.f90 - initial.f90 - title.f90 - setsizes.f90 - getinp.f90 - strlength.f90 - output.f90 - checkpoint.f90 - writesuccess.f90 - fparc.f90 - gparc.f90 - gwalls.f90 - comprest.f90 - comparegrad.f90 - packmol.f90 - polartocart.f90 - resetboxes.f90 - tobar.f90 - setijk.f90 - setibox.f90 - restmol.f90 - swaptype.f90 - swaptypemod.f90 - ahestetic.f90 - heuristics.f90 - flashsort.f90 - jacobi.f90 - random.f90 - sizes.f90 - usegencan.f90 - compute_data.f90 - flashmod.f90 - computef.f90 - computeg.f90 - input.f90 + src/exit_codes.f90 + src/cenmass.f90 + src/gencan.f + src/pgencan.f90 + src/initial.f90 + src/title.f90 + src/setsizes.f90 + src/getinp.f90 + src/strlength.f90 + src/output.f90 + src/checkpoint.f90 + src/writesuccess.f90 + src/fparc.f90 + src/gparc.f90 + src/gwalls.f90 + src/comprest.f90 + src/comparegrad.f90 + app/packmol.f90 + src/polartocart.f90 + src/resetboxes.f90 + src/tobar.f90 + src/setijk.f90 + src/setibox.f90 + src/restmol.f90 + src/swaptype.f90 + src/swaptypemod.f90 + src/ahestetic.f90 + src/heuristics.f90 + src/flashsort.f90 + src/jacobi.f90 + src/random.f90 + src/sizes.f90 + src/usegencan.f90 + src/compute_data.f90 + src/flashmod.f90 + src/computef.f90 + src/computeg.f90 + src/input.f90 ) # Installation directive diff --git a/Makefile b/Makefile index c9c3789..cf6ff29 100644 --- a/Makefile +++ b/Makefile @@ -14,12 +14,13 @@ # If you want to compile with some specific fortran compiler, you must # change the line below to the path of your fortran compiler. # -FORTRAN=$(FC) +FORTRAN=/usr/bin/gfortran # # Change the flags of the compilation if you want: # FLAGS= -O3 --fast-math -march=native -funroll-loops - +SRCDIR= src +MAINDIR= app ################################################################### # # # Generally no modifications are required after this. # @@ -114,85 +115,85 @@ devel : $(oall) # modules = exit_codes.o sizes.o compute_data.o usegencan.o input.o flashmod.o \ swaptypemod.o ahestetic.o -exit_codes.o : exit_codes.f90 - @$(FORTRAN) $(FLAGS) -c exit_codes.f90 -sizes.o : sizes.f90 - @$(FORTRAN) $(FLAGS) -c sizes.f90 -compute_data.o : compute_data.f90 sizes.o - @$(FORTRAN) $(FLAGS) -c compute_data.f90 -input.o : input.f90 sizes.o - @$(FORTRAN) $(FLAGS) -c input.f90 -flashmod.o : flashmod.f90 sizes.o - @$(FORTRAN) $(FLAGS) -c flashmod.f90 -usegencan.o : usegencan.f90 sizes.o - @$(FORTRAN) $(FLAGS) -c usegencan.f90 -swaptypemod.o : swaptypemod.f90 - @$(FORTRAN) $(FLAGS) -c swaptypemod.f90 -ahestetic.o : ahestetic.f90 - @$(FORTRAN) $(FLAGS) -c ahestetic.f90 +exit_codes.o : $(SRCDIR)/exit_codes.f90 + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/exit_codes.f90 +sizes.o : $(SRCDIR)/sizes.f90 + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/sizes.f90 +compute_data.o : $(SRCDIR)/compute_data.f90 sizes.o + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/compute_data.f90 +input.o : $(SRCDIR)/input.f90 sizes.o + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/input.f90 +flashmod.o : $(SRCDIR)/flashmod.f90 sizes.o + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/flashmod.f90 +usegencan.o : $(SRCDIR)/usegencan.f90 sizes.o + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/usegencan.f90 +swaptypemod.o : $(SRCDIR)/swaptypemod.f90 + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/swaptypemod.f90 +ahestetic.o : $(SRCDIR)/ahestetic.f90 + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/ahestetic.f90 # # Code compiled only for all versions # -cenmass.o : cenmass.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c cenmass.f90 -initial.o : initial.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c initial.f90 -title.o : title.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c title.f90 -setsizes.o : setsizes.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c setsizes.f90 -getinp.o : getinp.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c getinp.f90 -strlength.o : strlength.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c strlength.f90 -output.o : output.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c output.f90 -checkpoint.o : checkpoint.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c checkpoint.f90 -writesuccess.o : writesuccess.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c writesuccess.f90 -fparc.o : fparc.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c fparc.f90 -gparc.o : gparc.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c gparc.f90 -gwalls.o : gwalls.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c gwalls.f90 -comprest.o : comprest.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c comprest.f90 -comparegrad.o : comparegrad.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c comparegrad.f90 -packmol.o : packmol.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c packmol.f90 -polartocart.o : polartocart.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c polartocart.f90 -resetboxes.o : resetboxes.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c resetboxes.f90 -tobar.o : tobar.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c tobar.f90 -setijk.o : setijk.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c setijk.f90 -setibox.o : setibox.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c setibox.f90 -restmol.o : restmol.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c restmol.f90 -swaptype.o : swaptype.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c swaptype.f90 -heuristics.o : heuristics.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c heuristics.f90 -flashsort.o : flashsort.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c flashsort.f90 -jacobi.o : jacobi.f90 - @$(FORTRAN) $(FLAGS) -c jacobi.f90 -pgencan.o : pgencan.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c pgencan.f90 -gencan.o : gencan.f - @$(FORTRAN) $(GENCANFLAGS) -c gencan.f -random.o : random.f90 - @$(FORTRAN) $(FLAGS) -c random.f90 -computef.o : computef.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c computef.f90 -computeg.o : computeg.f90 $(modules) - @$(FORTRAN) $(FLAGS) -c computeg.f90 +cenmass.o : $(SRCDIR)/cenmass.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/cenmass.f90 +initial.o : $(SRCDIR)/initial.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/initial.f90 +title.o : $(SRCDIR)/title.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/title.f90 +setsizes.o : $(SRCDIR)/setsizes.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/setsizes.f90 +getinp.o : $(SRCDIR)/getinp.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/getinp.f90 +strlength.o : $(SRCDIR)/strlength.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/strlength.f90 +output.o : $(SRCDIR)/output.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/output.f90 +checkpoint.o : $(SRCDIR)/checkpoint.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/checkpoint.f90 +writesuccess.o : $(SRCDIR)/writesuccess.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/writesuccess.f90 +fparc.o : $(SRCDIR)/fparc.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/fparc.f90 +gparc.o : $(SRCDIR)/gparc.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/gparc.f90 +gwalls.o : $(SRCDIR)/gwalls.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/gwalls.f90 +comprest.o : $(SRCDIR)/comprest.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/comprest.f90 +comparegrad.o : $(SRCDIR)/comparegrad.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/comparegrad.f90 +packmol.o : app/packmol.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c app/packmol.f90 +polartocart.o : $(SRCDIR)/polartocart.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/polartocart.f90 +resetboxes.o : $(SRCDIR)/resetboxes.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/resetboxes.f90 +tobar.o : $(SRCDIR)/tobar.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/tobar.f90 +setijk.o : $(SRCDIR)/setijk.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/setijk.f90 +setibox.o : $(SRCDIR)/setibox.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/setibox.f90 +restmol.o : $(SRCDIR)/restmol.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/restmol.f90 +swaptype.o : $(SRCDIR)/swaptype.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/swaptype.f90 +heuristics.o : $(SRCDIR)/heuristics.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/heuristics.f90 +flashsort.o : $(SRCDIR)/flashsort.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/flashsort.f90 +jacobi.o : $(SRCDIR)/jacobi.f90 + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/jacobi.f90 +pgencan.o : $(SRCDIR)/pgencan.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/pgencan.f90 +gencan.o : $(SRCDIR)/gencan.f + @$(FORTRAN) $(GENCANFLAGS) -c $(SRCDIR)/gencan.f +random.o : $(SRCDIR)/random.f90 + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/random.f90 +computef.o : $(SRCDIR)/computef.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/computef.f90 +computeg.o : $(SRCDIR)/computeg.f90 $(modules) + @$(FORTRAN) $(FLAGS) -c $(SRCDIR)/computeg.f90 # # Clean build files #