292 lines
9.4 KiB
Fortran
292 lines
9.4 KiB
Fortran
program qpso
|
|
|
|
implicit none
|
|
include "mpif.h"
|
|
|
|
integer maxiter, maxpop, maxparms
|
|
parameter (maxiter = 10000)
|
|
parameter (maxpop = 2048)
|
|
parameter (maxparms = 512)
|
|
|
|
integer i, j,k, npop, nparms, niter, gInx, nfunc(maxpop)
|
|
integer nfuncall(maxpop)
|
|
integer ntries, np, myid, ierr, start_iter
|
|
integer pft(maxparms)
|
|
double precision gbest(maxparms)
|
|
double precision mbest(maxparms)
|
|
double precision feval, beta_l, beta_u, beta
|
|
double precision betapro(maxparms), pupdate(maxparms)
|
|
double precision pbest(maxpop, maxparms)
|
|
double precision pbestall(maxpop, maxparms)
|
|
double precision f_x(maxpop), x(maxpop, maxparms)
|
|
double precision xall(maxpop, maxparms)
|
|
double precision f_pbest(maxpop), f_pbestall(maxpop), f_gbest
|
|
double precision gpar(maxiter,maxparms)
|
|
double precision gobj(maxiter)
|
|
double precision pmin(maxparms), pmax(maxparms)
|
|
double precision fi(maxparms), u(maxparms), v(maxparms)
|
|
logical isvalid, restart
|
|
character(len=4) popst
|
|
character(len=100) mymachine, dummy, parm_name(maxparms), case_name, thisfmt
|
|
character(len=100) parm_list, constraints, qpso_in(4)
|
|
|
|
!------- user-tunable QPSO algorithm parameters ----------------
|
|
|
|
open(unit = 8, file='qpso_input.txt')
|
|
do i = 1,100
|
|
read(8,*, end=5), qpso_in
|
|
if (trim(qpso_in(1)) == 'npop') read(qpso_in(3),*) npop
|
|
if (trim(qpso_in(1)) == 'niter') read(qpso_in(3),*) niter
|
|
if (trim(qpso_in(1)) == 'beta_l') read(qpso_in(3),*) beta_l
|
|
if (trim(qpso_in(1)) == 'beta_u') read(qpso_in(3),*) beta_u
|
|
if (trim(qpso_in(1)) == 'restart') read(qpso_in(3),*) restart
|
|
if (trim(qpso_in(1)) == 'machine') mymachine=trim(qpso_in(3))
|
|
if (trim(qpso_in(1)) == 'case') case_name=trim(qpso_in(3))
|
|
if (trim(qpso_in(1)) == 'parm_list') parm_list=trim(qpso_in(3))
|
|
if (trim(qpso_in(1)) == 'constraints') constraints=trim(qpso_in(3))
|
|
end do
|
|
|
|
5 continue
|
|
close(8)
|
|
print*, '# of particles: ', npop
|
|
print*, '# of iterations: ', niter
|
|
print*, 'beta_l: ', beta_l
|
|
print*, 'beta_u: ', beta_u
|
|
print*, 'Is a restart run:', restart
|
|
print*, 'Machine: ', mymachine
|
|
print*, 'Case: ', case_name
|
|
print*, 'Parameter file: ', parm_list
|
|
print*, 'Constraints dir: ', constraints
|
|
!---------------------------------------------------------------
|
|
|
|
call mpi_init(ierr)
|
|
call mpi_comm_size(mpi_comm_world, np, ierr)
|
|
call mpi_comm_rank(mpi_comm_world, myid, ierr)
|
|
|
|
!get parameter information from the parm_list file
|
|
if (myid .eq. 0) then
|
|
open(unit = 8, status='old', file = trim(parm_list))
|
|
nparms=0
|
|
do i=1,maxparms
|
|
read(8,*, end=10) parm_name(i), pft(i), pmin(i), pmax(i)
|
|
nparms = nparms+1
|
|
end do
|
|
end if
|
|
|
|
10 continue
|
|
if (myid .eq. 0) then
|
|
close(8)
|
|
print*, nparms, ' Parameters optimized'
|
|
end if
|
|
|
|
!broadcast parameter info to other procs
|
|
call mpi_bcast(nparms, 1, mpi_integer, 0, mpi_comm_world, ierr)
|
|
call mpi_bcast(pmin, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
|
call mpi_bcast(pmax, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
|
|
|
|
|
nfunc(:) = 0 !keep track of total function evaluations
|
|
|
|
x(:,:) = 0d0
|
|
f_x(:) = 0d0
|
|
f_pbest(:) = 0d0
|
|
|
|
if (restart .eqv. .false.) then
|
|
do i=myid+1,npop,np
|
|
!randomize starting locations
|
|
call init_random_seed
|
|
call random_number(u)
|
|
x(i,:) = pmin + (pmax-pmin) * u
|
|
f_x(i) = feval(x(i,:), nparms, i, mymachine, parm_list, constraints, &
|
|
case_name)
|
|
nfunc(i) = nfunc(i)+1
|
|
f_pbest(i) = f_x(i)
|
|
end do
|
|
|
|
call mpi_allreduce(x, xall, maxparms*maxpop, mpi_double, mpi_sum, &
|
|
mpi_comm_world, ierr)
|
|
call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
|
|
mpi_comm_world, ierr)
|
|
pbestall = xall
|
|
|
|
!initialize pbest and gbest
|
|
if (myid .eq. 0) then
|
|
gInx = 1
|
|
do i=2,npop
|
|
if (f_pbestall(i) .lt. f_pbestall(gInx)) gInx = i
|
|
end do
|
|
gbest = pbestall(gInx,:)
|
|
f_gbest = f_pbestall(gInx)
|
|
end if
|
|
call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
|
call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
|
|
start_iter = 1
|
|
else
|
|
!load restart information
|
|
if (myid .eq. 0) then
|
|
open(unit=8, file='./qpso_restart_' // trim(case_name) // '.txt')
|
|
read(8,*) start_iter
|
|
do j=1,npop
|
|
read(8,*) xall(j,1:nparms)
|
|
read(8,*) pbestall(j,1:nparms)
|
|
read(8,*) f_pbestall(j)
|
|
end do
|
|
read(8,*) gbest(1:nparms)
|
|
read(8,*) f_gbest
|
|
end if
|
|
xall=pbestall
|
|
call mpi_bcast(xall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
|
|
call mpi_bcast(pbestall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
|
|
call mpi_bcast(f_pbestall, maxpop, mpi_double, 0, mpi_comm_world, ierr)
|
|
call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
|
|
call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
|
|
end if
|
|
|
|
|
|
|
|
!QPSO algorithm
|
|
do i=start_iter,niter
|
|
if (myid .eq. 0) print*, 'Iteration', i
|
|
beta = beta_u - (beta_u-beta_l)*i/niter
|
|
!compute mean of best parameters (all procs)
|
|
do k=1, nparms
|
|
mbest(k) = sum(pbestall(1:npop,k))/npop
|
|
end do
|
|
!print*, mbest(1:nparms)
|
|
!MPI over population
|
|
x(:,:) = 0d0
|
|
pbest(:,:) = 0d0
|
|
f_pbest(:) = 0d0
|
|
do j = myid+1,npop,np
|
|
isvalid = .false.
|
|
ntries = 0
|
|
do while (isvalid .eqv. .false.)
|
|
call random_number(fi)
|
|
call random_number(u)
|
|
call random_number(v)
|
|
|
|
isvalid=.true.
|
|
do k=1,nparms
|
|
pupdate = fi(k)*pbestall(j,k) + (1-fi(k))*gbest(k)
|
|
betapro = beta * abs(mbest(k)-xall(j,k))
|
|
|
|
x(j,k) = pupdate(k)+((-1d0)**ceiling(0.5+v(k)))*betapro(k)*(-log(u(k)))
|
|
|
|
if (ntries .le. 1e5) then
|
|
if (x(j,k) .lt. pmin(k) .or. x(j,k) .gt. pmax(k)) isvalid=.false.
|
|
else
|
|
if (x(j,k) .lt. pmin(k)) x(j,k) = pmin(k)
|
|
if (x(j,k) .gt. pmax(k)) x(j,k) = pmax(k)
|
|
end if
|
|
end do
|
|
ntries = ntries+1
|
|
end do
|
|
|
|
!run the model to get the cost function
|
|
f_x(j) = feval(x(j,:),nparms, j, mymachine, parm_list, constraints, case_name)
|
|
nfunc(j) = nfunc(j)+1
|
|
|
|
if (f_x(j) .lt. f_pbestall(j)) then
|
|
pbest(j,:) = x(j,:)
|
|
f_pbest(j) = f_x(j)
|
|
else
|
|
pbest(j,:) = pbestall(j,:)
|
|
f_pbest(j) = f_pbestall(j)
|
|
end if
|
|
end do
|
|
|
|
call mpi_allreduce(pbest, pbestall, maxparms*maxpop, mpi_double, mpi_sum, &
|
|
mpi_comm_world, ierr)
|
|
call mpi_allreduce(x, xall, maxpop, mpi_double, mpi_sum, &
|
|
mpi_comm_world, ierr)
|
|
call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
|
|
mpi_comm_world, ierr)
|
|
|
|
!update overall best (all procs)
|
|
do j=1,npop
|
|
if (f_pbestall(j) .lt. f_gbest) then
|
|
gbest = pbestall(j,:)
|
|
f_gbest = f_pbestall(j)
|
|
end if
|
|
end do
|
|
|
|
!save info from this iteration
|
|
gpar(i,:) = gbest
|
|
gobj(i) = f_gbest
|
|
call mpi_allreduce(nfunc,nfuncall, maxpop, mpi_integer, mpi_sum, &
|
|
mpi_comm_world, ierr)
|
|
if (myid .eq. 0) then
|
|
open(unit=8, file='qpso_best_' // trim(case_name) // '.txt')
|
|
write(8,*), 'Iteration', i
|
|
write(8,*), 'Objective function:', gobj(i)
|
|
do k=1,nparms
|
|
write(8,'(A,1x,I2,1x,g13.6)') trim(parm_name(k)), pft(k), gpar(i,k)
|
|
end do
|
|
close(8)
|
|
if (i .eq. 1) then
|
|
open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt')
|
|
else
|
|
open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt', &
|
|
status='old', position='append', action='write')
|
|
end if
|
|
write(10,*) i, sum(nfuncall) , gobj(i)
|
|
close(10)
|
|
|
|
!write the restart file
|
|
write(popst, '(I4)') nparms
|
|
thisfmt = '(' // trim(popst) // '(g13.6,1x))'
|
|
open(unit=11, file = 'qpso_restart_' // trim(case_name) // '.txt')
|
|
write(11,'(I4)') i !current iteration number
|
|
do j=1,npop
|
|
write(11,fmt=trim(thisfmt)) xall(j,1:nparms) !current parameters for each population
|
|
write(11,fmt=trim(thisfmt)) pbestall(j,1:nparms) !best parameters for each population
|
|
write(11,'(g13.6)') f_pbestall(j) !best objective function for each population
|
|
end do
|
|
write(11,fmt=trim(thisfmt)) gbest(1:nparms) !overall best parameters
|
|
write(11,'(g13.6)') f_gbest !overall best objectivefunction
|
|
close(11)
|
|
end if
|
|
end do
|
|
call mpi_finalize(ierr)
|
|
|
|
end program qpso
|
|
|
|
|
|
!Function to evaluate the CLM/ALM model
|
|
double precision function feval(parms, nparms, thispop, mymachine, parm_list, &
|
|
constraints, case_name)
|
|
|
|
integer nparms, i, thispop
|
|
double precision parms(500), trueparms(4)
|
|
double precision mydata(1000), model(1000), sse(1000)
|
|
double precision temp(1000), par(1000)
|
|
character(len=6) thispopst
|
|
character(len=100) mymachine, parm_list, constraints, case_name, thisline
|
|
|
|
|
|
write(thispopst, '(I6)') 100000+thispop
|
|
|
|
!write the parameters to file
|
|
open(unit=9, file='./parm_data_files/parm_data_' // thispopst(2:6))
|
|
do i=1,nparms
|
|
write(9,*) parms(i)
|
|
end do
|
|
close(9)
|
|
|
|
!Call python workflow to set up and launch model simulation
|
|
call system('sleep ' // thispopst(2:6)) !do not start all at once
|
|
call system('python UQ_runens.py --ens_num ' // thispopst(2:6) // &
|
|
' --parm_list ' // trim(parm_list) // ' --parm_data ./parm_data_files/' // &
|
|
'parm_data_' // thispopst(2:6) // ' --constraints ' // trim(constraints) // &
|
|
' --machine ' // trim(mymachine) // ' --case ' // trim(case_name))
|
|
|
|
!get the sum of squared errors
|
|
open(unit=9, file='./ssedata/mysse_' // thispopst(2:6) // '.txt')
|
|
read(9,*) feval
|
|
close(9)
|
|
call system('sleep 20')
|
|
|
|
return
|
|
|
|
end function feval
|