diff --git a/astero/private/adipls_support.f90 b/astero/private/adipls_support.f90 index 6fcffa082..7dbdcd4b2 100644 --- a/astero/private/adipls_support.f90 +++ b/astero/private/adipls_support.f90 @@ -287,8 +287,7 @@ subroutine store_model_for_adipls (s, add_atmosphere, do_redistribute_mesh, ierr ivers = 0 ! It's not clear what this does in fgong_amdl - call fgong_amdl( & - cgrav, nn_in, iconst, ivar, ivers, global_data, point_data, data, aa, nn, ierr) + call fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, global_data, point_data, data, aa, nn, ierr) deallocate(global_data, point_data) if (ierr /= 0) then @@ -682,8 +681,7 @@ subroutine read_and_store(iriche, iturpr, cgrav) write(*,*) 'read_and_store failed in read_fgong_file' call mesa_error(__FILE__,__LINE__) end if - call fgong_amdl( & - cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn, ierr) + call fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn, ierr) if (ierr /= 0) then write(*,*) 'read_and_store failed in fgong_amdl' call mesa_error(__FILE__,__LINE__) @@ -726,8 +724,8 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) ! test for singular centre and/or surface - sincen=aa1(1,1).eq.0 - sinsur=data(7).ge.0 + sincen=aa1(1,1) == 0 + sinsur=data(7) >= 0 nsin=0 if (sincen) nsin=nsin+1 if (sinsur) nsin=nsin+1 @@ -735,7 +733,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) ! test for inclusion of g/(g tilde) idata8 = int(data(8)+0.1) - if (mod(idata8/10,10).eq.2) then + if (mod(idata8/10,10) == 2) then iggt = 1 iturpr=8 else @@ -746,13 +744,13 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) ! test for number of nonsingular points - if (iriche.ne.1.or.mod(nn-nsin,2).eq.1) then + if (iriche /= 1.or.mod(nn-nsin,2) == 1) then nshift=0 else nshift=1 end if nnr=nn - if (nshift.ne.0) then + if (nshift /= 0) then nn=nn-nshift end if @@ -772,7 +770,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) end do else do n=1,nnr - if (n.eq.1) then + if (n == 1) then n1=1 else n1=n+nshift @@ -788,16 +786,16 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) ! set g/gtilde (=1 in models without turbulent pressure) - if (iturpr.eq.1) then + if (iturpr == 1) then do n=1,nn - if (x(n).lt.0.999) then + if (x(n) < 0.999) then ggt=1 else ggt=1./(x(n)*x(n)*x(n)*aa(1,n)) end if aa(10,n)=ggt end do - else if (iggt.eq.1) then + else if (iggt == 1) then do n=1,nn aa(10,n)=aa(6,n) end do @@ -815,8 +813,7 @@ subroutine store_amdl(nn_in, iriche, iturpr, data, aa, x, nn, ierr) end subroutine store_amdl - subroutine fgong_amdl( & - cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn, ierr) + subroutine fgong_amdl(cgrav, nn_in, iconst, ivar, ivers, glob, var, data, aa, nn, ierr) ! derived from fgong-amdl.d.f real(dp), intent(in) :: cgrav integer, intent(in) :: nn_in, iconst, ivar, ivers @@ -834,7 +831,7 @@ subroutine fgong_amdl( & ierr = 0 nn = nn_in - if (var(1,1).gt.var(1,nn)) then + if (var(1,1) > var(1,nn)) then nn1=nn+1 do i=1,ivar do n=1,nn @@ -846,7 +843,7 @@ subroutine fgong_amdl( & end do end if - if (var(1,1).gt.1.d6) then + if (var(1,1) > 1.d6) then do i=1,ivar do n=1,nn var1(i,n+1)=var(i,n) @@ -895,7 +892,7 @@ subroutine fgong_amdl( & aa(4,1)=var(10,1) aa(5,1)=0 aa(6,1)=3.d0 - if (aa(5,nn).le.10) then + if (aa(5,nn) <= 10) then nn=nn-1 !write(6,*) 'Chop off outermost point' end if @@ -903,7 +900,7 @@ subroutine fgong_amdl( & data(2)=glob(2) data(3)=var(4,1) data(4)=var(5,1) - if (glob(11).lt.0.and.glob(11).gt.-10000) then + if (glob(11) < 0.and.glob(11) > -10000) then data(5)=-glob(11)/var(10,1) data(6)=-glob(12) else @@ -911,7 +908,7 @@ subroutine fgong_amdl( & d2amax=0.d0 do n=2,nn d2amax=max(d2amax,aa(5,n)/x(n)**2) - if (x(n).ge.0.05d0) exit + if (x(n) >= 0.05d0) exit end do data(6)=d2amax+data(5) !write(6,140) data(5), data(6) diff --git a/astero/private/astero_support.f90 b/astero/private/astero_support.f90 index b6fe1195b..0be7ffdc3 100644 --- a/astero/private/astero_support.f90 +++ b/astero/private/astero_support.f90 @@ -71,7 +71,7 @@ subroutine get_one_el_info( & real(dp) :: nu_obs, dist_j, nu, dist, min_dist, min_freq, & R, G, M, sig_fac, b, sum_1, sum_2, sum_3, empty(0) - integer :: min_dist_j, min_order, n, cnt, int_empty(0) + integer :: min_dist_j, min_order, n, cnt, int_empty(0), int_empty2(0) integer :: nsel, itrsig, nsig real(dp) :: els1, dels, sig1, sig2, dfsig integer :: num_l0_terms, k, i, j @@ -162,7 +162,7 @@ subroutine get_one_el_info( & call set_to_closest(freq_target(0,:), & model_freq(0,:), empty, empty, & model_inertia(0,:), empty, empty, & - model_order(0,:), int_empty, int_empty, ierr) + model_order(0,:), int_empty, int_empty2, ierr) model_freq_alt_up(0,:) = model_freq(0,:) model_inertia_alt_up(0,:) = model_inertia(0,:) diff --git a/kap/private/op_load.f b/kap/private/op_load.f index ea274dfa5..3f47884da 100644 --- a/kap/private/op_load.f +++ b/kap/private/op_load.f @@ -22,29 +22,27 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - -c FORTRAN 90 module for calculation of radiative accelerations, -c based on the Opacity Project (OP) code "OPserver". -c See CHANGES_HU for changes made to the original code. -c -c Haili Hu 2010 -c + +! FORTRAN 90 module for calculation of radiative accelerations, +! based on the Opacity Project (OP) code "OPserver". +! See CHANGES_HU for changes made to the original code. +! +! Haili Hu 2010 + module op_load use math_lib use op_def logical :: have_loaded_op = .false. - + contains -C****************************************************************** +!****************************************************************** subroutine op_dload(path, cache_filename, ierr) implicit none character (len=*), intent(in) :: path, cache_filename integer, intent(out) :: ierr - - - - + + integer,parameter :: ipz=28 real :: am,amm,delp,dpack integer :: ios,it,ite11,ite22,ite33,itt,itte1,itte2,itte3,izz,jne,ite @@ -56,7 +54,7 @@ subroutine op_dload(path, cache_filename, ierr) real :: dv,dv1 integer :: cache_version - + common /mesh/ ntotv,dv,dv1,umesh,semesh ! common /atomdata/ ! common/atomdata/ ite1,ite2,ite3,jn1(91),jn2(91),jne3,umin,umax,ntot, @@ -64,59 +62,57 @@ subroutine op_dload(path, cache_filename, ierr) ! + ne2(17,91,25),fion(-1:28,28,91,25),np(17,91,25),kp1(17,91,25), ! + kp2(17,91,25),kp3(17,91,25),npp(17,91,25),mx(33417000), ! + yy1(33417000),yy2(120000000),nx(19305000),yx(19305000) -! - + integer,dimension(ipe) :: ifl,iflp character num(0:9)*1,zlab(ipe)*3,tlab*6,zlabp(ipe)*3 DATA NUM/'0','1','2','3','4','5','6','7','8','9'/ integer :: kz(17) - data kz/1, 2, 6, 7, 8, 10, 11, 12, 13, 14, 16, 18, 20, 24, 25, 26, 28/ + data kz/1, 2, 6, 7, 8, 10, 11, 12, 13, 14, 16, 18, 20, 24, 25, 26, 28/ save /mesh/ !HH: put common block in static memory -c + integer :: nx_temp(nptot) real :: y_temp(nptot) integer :: nx_index, left_n, right_n, n_index real :: left_val, right_val, cross_section, slope - - if(allocated(yy2) .eqv. .false.) then + + if (allocated(yy2) .eqv. .false.) then ! yy2 actually needs 29,563 x 10,000 length ALLOCATE(yy2(30000*10000),nx(19305000),yx(19305000),stat=ierr) - if(ierr/=0) return + if (ierr/=0) return yy2=0.0 nx=0.0 yx=0.0 ! write(*,*) "ierr",ierr end if - - + + ierr=0 if (have_loaded_op) return - + !$omp critical (critial_do_op_dload) - + if (have_loaded_op) goto 1001 - + !path = '../OP4STARS_1.3' !call getenv("oppath", path) !if (len(trim(path)) == 0) then - ! write(6,*) 'Define environmental variable oppath (directory of OP data)' + ! write(6,*) 'Define environmental variable oppath (directory of OP data)' ! stop !endif ios = 0 - open(1,file=trim(cache_filename),action='read', - > status='old',iostat=ios,form='unformatted') + open(1,file=trim(cache_filename),action='read',status='old',iostat=ios,form='unformatted') if (ios == 0) then write(*,*) 'reading OP cache file ' // trim(cache_filename) - read(1,iostat=ios) cache_version, ntotv,dv,dv1,umesh, - > ite1,ite2,ite3,jn1,jn2,jne3,umin,umax,ntotp,nc,nf,int,epatom,oplnck, ne1p, - > ne2p,fionp,np,kp1,kp2,kp3,npp,yy2,nx,yx + read(1,iostat=ios) cache_version,ntotv,dv,dv1,umesh, + > ite1,ite2,ite3,jn1,jn2,jne3,umin,umax,ntotp,nc,nf,int,epatom,oplnck, ne1p, + > ne2p,fionp,np,kp1,kp2,kp3,npp,yy2,nx,yx write(*,*) 'done reading OP cache file' close(1) - if (cache_version .ne. op_cache_version) then + if (cache_version /= op_cache_version) then write(*,*) 'wrong version of OP cache' write(*,*) 'cache file path is set by op_mono_data_cache_filename' write(*,*) 'perhaps cache is shared between different MESA versions' @@ -142,14 +138,14 @@ subroutine op_dload(path, cache_filename, ierr) zlab(n)='m'//num(kz(n)/10)//num(kz(n)-10*(kz(n)/10)) iflp(n)=70+n zlabp(n)='a'//num(kz(n)/10)//num(kz(n)-10*(kz(n)/10)) - enddo + end do write(*,*) 'loading OP mono data...' -C READ INDEX FILES -C FIRST FILE +! READ INDEX FILES +! FIRST FILE NN=1 -c print*,' Opening '//'./'//zlab(1)//'.index' +! print*,' Opening '//'./'//zlab(1)//'.index' OPEN(1,FILE=trim(path)//'/'//ZLAB(1)//'.index',STATUS='OLD', + iostat=ios) if (ios /= 0) then @@ -163,27 +159,27 @@ subroutine op_dload(path, cache_filename, ierr) READ(1,*)NC,NF READ(1,*)DPACK CLOSE(1) - IF(IZZ.NE.KZ(1))then + if (IZZ /= KZ(1)) then write(6,6001)zlab(1),izz,nn,kz(1) ierr=1 goto 1001 endif NTOTP=NF - IF(NTOTP.GT.nptot)then + if (NTOTP > nptot) then write(6,6002)ntotp,nptot - ierr=2 + ierr=2 goto 1001 endif INT(1)=1 - IF(ITTE3.NE.ITE3)then + if (ITTE3 /= ITE3) then write(6,6077)ite3,itte3,nn ierr=3 goto 1001 endif -c ITE1=MAX(ITE1,ITTE1) -c ITE2=MIN(ITE2,ITTE2) -C -c READ MESH FILES +! ITE1=MAX(ITE1,ITTE1) +! ITE2=MIN(ITE2,ITTE2) +! +! READ MESH FILES OPEN(1,FILE=trim(path)//'/'//ZLAB(1)//'.mesh',status='old', + form='unformatted',iostat=ios) if (ios /= 0) then @@ -191,17 +187,17 @@ subroutine op_dload(path, cache_filename, ierr) ierr = -1 goto 1001 end if - READ(1)DV,NTOTV,(UMESH(N),N=1,NTOTV) + READ(1)DV,NTOTV,(UMESH(N),N=1,NTOTV) umin=umesh(1) umax=umesh(ntotv) DV1=DV - CLOSE(1) -C -C GET MESH FOR SCREEN + CLOSE(1) +! +! GET MESH FOR SCREEN CALL IMESH(UMESH,NTOTV) -C -C SUBSEQUENT FILES - DO 40 N=2,ipe +! +! SUBSEQUENT FILES + DO N=2,ipe NN=N OPEN(1,FILE=trim(path)//'/'//ZLAB(N)//'.index', + STATUS='OLD') @@ -211,35 +207,35 @@ subroutine op_dload(path, cache_filename, ierr) READ(1,*)NC,NF READ(1,*)DPACK CLOSE(1) - IF(ITE33.NE.ITE3)then + if (ITE33 /= ITE3) then write(6,6077)ite3,ite33,nn ierr=4 goto 1001 endif -c ITE1=MAX(ITE1,ITE11) -c ITE2=MIN(ITE2,ITE22) - IF(IZZ.NE.KZ(N))then +! ITE1=MAX(ITE1,ITE11) +! ITE2=MIN(ITE2,ITE22) + if (IZZ /= KZ(N)) then write(6,6001)zlab(n),izz,nn,kz(nn) ierr=5 goto 1001 endif NTOTT=NF - IF(NTOTT.GT.NTOTP)then + if (NTOTT > NTOTP) then write(6,6006)nn,ntott,ntotp ierr=6 goto 1001 endif -c!! IF(UMIN.NE.UMINN.OR.UMAX.NE.UMAXX) GOTO 1003 !! +! !! if (UMIN /= UMINN.OR.UMAX /= UMAXX) GOTO 1003 !! INT(N)=NTOTP/NTOTT - IF(INT(N)*NTOTT.NE.NTOTP)then + if (INT(N)*NTOTT /= NTOTP) then WRITE(6,6009)NN,NTOTT,NTOTP ierr=7 goto 1001 endif - IF(INT(N).NE.1)WRITE(6,6007)N,INT(N) -c -c READ MESH FILES -c + if (INT(N) /= 1)WRITE(6,6007)N,INT(N) +! +! READ MESH FILES +! OPEN(1,FILE=trim(path)//'/'//ZLAB(N)//'.mesh', + status='old',form='unformatted',iostat=ios) if (ios /= 0) then @@ -248,26 +244,26 @@ subroutine op_dload(path, cache_filename, ierr) goto 1001 end if READ(1)DV - IF(DV.NE.DV1)THEN + if (DV /= DV1) then ! PRINT*,' OP: N=',N,', DV=',DV,' NOT EQUAL TO DV1=',DV1 ierr=8 goto 1001 ENDIF CLOSE(1) - 40 CONTINUE -C -C START TEMPERATURE LOOP -C + END DO +! +! START TEMPERATURE LOOP +! ncount2=0 ncount3=0 do it=ite1,ite2,ite3 -c -C OPEN FILES -c +! +! OPEN FILES +! TLAB='.'//NUM(IT/100)//NUM(IT/10-10*(IT/100))// + NUM(IT-10*(IT/10)) do n=1,ipe -c IF(SKIP(N))GOTO 70 +! if (SKIP(N))GOTO 70 NN=N OPEN(IFL(N),FILE=trim(path)//'/'//ZLAB(N)//TLAB, + FORM='UNFORMATTED',STATUS='OLD',iostat=ios) @@ -276,7 +272,7 @@ subroutine op_dload(path, cache_filename, ierr) ierr = -1 goto 1001 end if - if(n.gt.2) then + if (n > 2) then OPEN(IFLP(N),FILE=trim(path)//'/'//ZLABP(N)//TLAB, + FORM='UNFORMATTED',STATUS='OLD',iostat=ios) if (ios /= 0) then @@ -285,42 +281,42 @@ subroutine op_dload(path, cache_filename, ierr) goto 1001 end if endif - enddo -C READ HEADINGS + end do +! READ HEADINGS NN=1 READ(IFL(1))IZZ,ITE,AM,UM,UX,NCCC,NFFF,DelP,JNE1,JNE2,JNE3 do n=2,ipe -c IF(SKIP(N))GOTO 80 +! if (SKIP(N))GOTO 80 NN=N READ(IFL(N))IZZ,ITE,AM,UM,UX,NC,NF,DelP,JNE11,JNE22,JNE33 - if(n.gt.2) read(iflp(n)) - IF(JNE33.NE.JNE3)then + if (n > 2) read(iflp(n)) + if (JNE33 /= JNE3) then write(6,6099)jne3,jne33,nn ierr=9 goto 1001 endif JNE1=MAX(JNE1,JNE11) JNE2=MIN(JNE2,JNE22) - enddo + end do itt=(it-ite1)/2+1 jn1(itt)=jne1 jn2(itt)=jne2 -C -c WRITE(98,9802)ITE,JNE1,JNE2,JNE3 -C -C START DENSITY LOOP -C +! +! WRITE(98,9802)ITE,JNE1,JNE2,JNE3 +! +! START DENSITY LOOP +! do n=1,ipe do jn=jne1,jne2,jne3 jnn=(jn-jne1)/2+1 -C -C START LOOP ON ELEMENTS -C +! +! START LOOP ON ELEMENTS +! 95 READ(IFL(N))JNE,EPATOM(n,itt,jnn),OPLNCK(n,itt,jnn),ORSS, + NE1P(n,itt,jnn),NE2P(n,itt,jnn), + (FIONP(NE,n,itt,jnn),NE=NE1P(n,itt,jnn),NE2P(n,itt,jnn)) read(ifl(n))np(n,itt,jnn) - if(np(n,itt,jnn).gt.0)then + if (np(n,itt,jnn) > 0) then read(ifl(n))(nx_temp(k),y_temp(k),k=1,np(n,itt,jnn)) do nx_index = 2, np(n,itt,jnn) left_val = y_temp(nx_index-1) @@ -328,14 +324,14 @@ subroutine op_dload(path, cache_filename, ierr) left_n = nx_temp(nx_index-1) right_n = nx_temp(nx_index) slope = (right_val - left_val)/float(right_n - left_n) - + do n_index = left_n, right_n cross_section = left_val + (n_index-left_n)*slope yy2(ncount2 + n_index) = cross_section - enddo + end do yy2(ncount2 + left_n) = left_val yy2(ncount2 + right_n) = right_val - enddo + end do kp2(n, itt, jnn) = ncount2 ncount2 = ncount2 + ntotp else @@ -343,51 +339,50 @@ subroutine op_dload(path, cache_filename, ierr) kp2(n,itt,jnn)=ncount2 ncount2=ncount2+ntotp endif - if(n.gt.2) then + if (n > 2) then read(iflp(n))ja,npp(n,itt,jnn) - if(npp(n,itt,jnn).gt.0) then + if (npp(n,itt,jnn) > 0) then read(iflp(n))(nx(k+ncount3),yx(k+ncount3),k=1,npp(n,itt,jnn)) kp3(n,itt,jnn)=ncount3 ncount3=ncount3+npp(n,itt,jnn) endif endif - enddo - enddo -c -c write(6,610)it -c write(6,*)'ncount1 = ',ncount1 -c write(6,*)'ncount2 = ',ncount2 -c write(6,*)'ncount3 = ',ncount3 -c -C CLOSE FILES -c - DO 150 N=1,ipe - CLOSE(IFL(N)) + end do + end do + +! write(6,610)it +! write(6,*)'ncount1 = ',ncount1 +! write(6,*)'ncount2 = ',ncount2 +! write(6,*)'ncount3 = ',ncount3 +! +! CLOSE FILES + + do N=1,ipe + close(IFL(N)) close(iflp(n)) - 150 CONTINUE -c - enddo - + end do + + end do + write(*,*) 'done loading OP mono data' have_loaded_op = .true. - + !write(*,*)'ncount1 = ',ncount1 !write(6,*)'ncount2 = ',ncount2 !write(6,*)'ncount3 = ',ncount3 ios = 0 - open(1, file=trim(cache_filename), iostat=ios, - > action='write', form='unformatted') + open(1, file=trim(cache_filename), iostat=ios, action='write', form='unformatted') if (ios == 0) then write(*,*) 'write ' // trim(cache_filename) write(1) op_cache_version, ntotv,dv,dv1,umesh, - > ite1,ite2,ite3,jn1,jn2,jne3,umin,umax,ntotp,nc,nf,int,epatom,oplnck, ne1p, - > ne2p,fionp,np,kp1,kp2,kp3,npp,yy2,nx,yx + > ite1,ite2,ite3,jn1,jn2,jne3,umin,umax,ntotp,nc,nf,int,epatom,oplnck, ne1p, + > ne2p,fionp,np,kp1,kp2,kp3,npp,yy2,nx,yx close(1) end if - + 1001 continue -C pre-calculate semesh +! pre-calculate semesh do n = 1, nptot u = umesh(n) semesh(n) = 1.d0 - exp(dble(-u)) @@ -396,7 +391,6 @@ subroutine op_dload(path, cache_filename, ierr) !$omp end critical (critial_do_op_dload) - return 610 format(10x,'Done IT= ',i3) 1004 WRITE(6,6004)ZLAB(NN),TLAB @@ -413,7 +407,7 @@ subroutine op_dload(path, cache_filename, ierr) 6009 FORMAT(' OP: N=',I5,', NTOTT=',I10,', NTOT=',I10/ + ' NTOT NOT MULTIPLE OF NTOTT') c6012 FORMAT(/10X,'ERROR, SEE WRITE(6,6012)'/ -c + 10X,'IT=',I3,', JN=',I3,', N=',I3,', JNE=',I3/) +! + 10X,'IT=',I3,', JN=',I3,', N=',I3,', JNE=',I3/) 6077 FORMAT(//5X,'OP: DISCREPANCY IN ITE3'/10X,I5,' READ FROM UNIT 5'/ + 10X,I5,' FROM INDEX FILE ELEMENT',I5) 6099 FORMAT(//5X,'OP: DISCREPANCY IN JNE3'/10X,I5,' READ FOR N=1'/ @@ -426,53 +420,53 @@ subroutine op_dload(path, cache_filename, ierr) stop end subroutine op_dload -c*********************************************************************** +!*********************************************************************** SUBROUTINE IMESH(UMESH,NTOT) -C + DIMENSION UMESH(nptot) COMMON/CIMESH/U(100),AA(nptot),BB(nptot),IN(nptot),ITOT,NN save /cimesh/ - + UMIN=UMESH(1) UMAX=UMESH(NTOT) -c + II=100 A=(II*UMIN-UMAX)/REAL(II-1) B=(UMAX-UMIN)/REAL(II-1) DO I=1,II U(I)=A+B*I - ENDDO -c + end do + ib=2 ub=u(ib) ua=u(ib-1) d=ub-ua ibb=0 do n=2,ntot - if(umesh(n).gt.ub)then + if (umesh(n) > ub) then ua=ub ib=ib+1 ub=u(ib) d=ub-ua - if(umesh(n).gt.ub)then + if (umesh(n) > ub) then nn=n-1 ibb=ib-1 goto 1 - endif - endif + endif + endif in(n)=ib aa(n)=(ub-umesh(n))/d bb(n)=(umesh(n)-ua)/d - enddo -c + end do + 1 ib=ibb do n=nn+1,ntot ib=ib+1 in(n)=ib u(ib)=umesh(n) - enddo + end do itot=ib -c + return end SUBROUTINE IMESH @@ -484,9 +478,9 @@ subroutine msh(dv, ntot, umesh, semesh, uf, dscat) real, intent(out) :: umesh(:), semesh(:) ! (nptot) integer :: i, k, ntotv real :: dvp, dv1, umin, umax, umeshp(nptot), semeshp(nptot) - common /mesh/ ntotv, dvp, dv1, umeshp, semeshp - save /mesh/ -c + common /mesh/ ntotv, dvp, dv1, umeshp, semeshp + save /mesh/ + ntot = ntotv dv = dvp do i=1,ntot @@ -496,89 +490,88 @@ subroutine msh(dv, ntot, umesh, semesh, uf, dscat) semesh(i) = semeshp(i) end do -c umin = umesh(1) umax = umesh(ntot) dscat = (umax - umin)*0.01 do i = 0, 100 uf(i) = umin + i*dscat - enddo -c + end do + return -c + end subroutine msh - + subroutine solve(u,v,z,uz,ierr) integer, intent(inout) :: ierr dimension u(4) -c -c If P(R) = u(1) u(2) u(3) u(4) -c for R = -3 -1 1 3 -c then a cubic fit is: - P(R)=( + +! If P(R) = u(1) u(2) u(3) u(4) +! for R = -3 -1 1 3 +! then a cubic fit is: + P(R)=( + 27*(u(3)+u(2))-3*(u(1)+u(4)) +R*( + 27*(u(3)-u(2))-(u(4)-u(1)) +R*( + -3*(u(2)+u(3))+3*(u(4)+u(1)) +R*( + -3*(u(3)-u(2))+(u(4)-u(1)) ))))/48. -c First derivative is: - PP(R)=( +! First derivative is: + PP(R)=( + 27*(u(3)-u(2))-(u(4)-u(1))+ 2*R*( + -3*(u(2)+u(3))+3*(u(4)+u(1)) +3*R*( + -3*(u(3)-u(2))+(u(4)-u(1)) )))/48. -c + ! ierr = 0 -c Find value of z giving P(z)=v -c First estimate +! Find value of z giving P(z)=v +! First estimate z=(2.*v-u(3)-u(2))/(u(3)-u(2)) -c Newton-Raphson iterations +! Newton-Raphson iterations do k=1,10 uz=pp(z) d=(v-p(z))/uz z=z+d - if(abs(d).lt.1.e-4)return - enddo -c + if (abs(d) < 1.e-4) return + end do + ! print*,' Not converged after 10 iterations in SOLVE' ! print*,' v=',v ! DO N=1,4 ! PRINT*,' N, U(N)=',N,U(N) -! ENDDO +! end do ierr = 10 return ! stop -c + end subroutine solve -c*********************************************************************** +!*********************************************************************** SUBROUTINE BRCKR(T,FNE,RION,NION,U,NFREQ,SF, ierr) integer, intent(inout) :: ierr -C -C CODE FOR COLLECTIVE EFFECTS ON THOMSON SCATTERING. -C METHOD OF D.B. BOERCKER, AP. J., 316, L98, 1987. -C -C INPUT:- -C T=TEMPERATURTE IN K -C FNE=ELECTRON DENSITY IN CM**(-3) -C ARRAY RION (DIMENSIONED FOR 30 IONS). -C RION(IZ) IS NUMBER OF IONS WITH NET CHARGE IZ. -C NORMALISATION OF RION IS OF NO CONSEQUENCE. -C NION=NUMBER OF IONS INCLUDED. -C ARRAY U (DIMENSIONED FOR 1000). VALUES OF (H*NU/K*T). -C NFREQ=NUMBER OF FREQUENCY POINTS. -C -C OUTPUT:- -C ARRAY SF, GIVING FACTORS BY WHICH THOMSON CROSS SECTION -C SHOULD BE MULTIPLIED TO ALLOW FOR COLLECTIVE EFFECTS. -C -C MODIFFICATIONS:- -C (1) REPLACE (1.-Y) BY EXP(-Y) TO AVOID NEGATIVE FACTORS FOR -C HIGHLY-DEGENERATE CASES. -C (2) INCLUDE RELATIVISTIC CORRECTION. -C +! +! CODE FOR COLLECTIVE EFFECTS ON THOMSON SCATTERING. +! METHOD OF D.B. BOERCKER, AP. J., 316, L98, 1987. +! +! INPUT:- +! T=TEMPERATURTE IN K +! FNE=ELECTRON DENSITY IN CM**(-3) +! ARRAY RION (DIMENSIONED FOR 30 IONS). +! RION(IZ) IS NUMBER OF IONS WITH NET CHARGE IZ. +! NORMALISATION OF RION IS OF NO CONSEQUENCE. +! NION=NUMBER OF IONS INCLUDED. +! ARRAY U (DIMENSIONED FOR 1000). VALUES OF (H*NU/K*T). +! NFREQ=NUMBER OF FREQUENCY POINTS. +! +! OUTPUT:- +! ARRAY SF, GIVING FACTORS BY WHICH THOMSON CROSS SECTION +! SHOULD BE MULTIPLIED TO ALLOW FOR COLLECTIVE EFFECTS. +! +! MODIFFICATIONS:- +! (1) REPLACE (1.-Y) BY EXP(-Y) TO AVOID NEGATIVE FACTORS FOR +! HIGHLY-DEGENERATE CASES. +! (2) INCLUDE RELATIVISTIC CORRECTION. +! PARAMETER (IPZ=28,IPNC=100) DIMENSION RION(IPZ),U(0:IPNC),SF(0:IPNC) -C + AUNE=1.48185E-25*FNE AUT=3.16668E-6*T C1=-1.0650E-4*AUT @@ -590,17 +583,17 @@ SUBROUTINE BRCKR(T,FNE,RION,NION,U,NFREQ,SF, ierr) 11 R=FMH(W)/V A=0. B=0. - DO 20 I=1,NION + DO I=1,NION A=A+I*RION(I) B=B+I**2*RION(I) - 20 CONTINUE + END DO X=R+B/A -C + Y=.353553*W C=1.1799E5*X*AUNE/(AUT*AUT*AUT) - DO 30 N=0,NFREQ + DO N=0,NFREQ D=C/U(N)**2 - IF(D.GT.5.)THEN + if (D > 5.) then D=-2./D F=2.666667*(1.+D*(.7+D*(.55+.341*D))) ELSE @@ -610,20 +603,20 @@ SUBROUTINE BRCKR(T,FNE,RION,NION,U,NFREQ,SF, ierr) DELTA=.375*R*F/X SF(N)=(1.-R*DELTA-Y*FUNS(W))* + (1.+U(N)*(C1+U(N)*(C2+U(N)*C3))) !SAMPSON CORRECTION - 30 CONTINUE -C + END DO + RETURN -C + 600 FORMAT(5X,'NOT CONVERGED IN LOOP 10 OF BRCKR'/ + 5X,'T=',1P,E10.2,', FNE=',E10.2) -C + END SUBROUTINE BRCKR -C*********************************************************************** +!*********************************************************************** FUNCTION FUNS(A) -C - IF(A.LE.0.001)THEN +! + if (A <= 0.001) then FUNS=1. - ELSEIF(A.LE.0.01)THEN + elseif (A <= 0.01) then FUNS=(1.+A*(-1.0886+A*(1.06066+A*1.101193)))/ + (1.+A*(0.35355+A*(0.19245+A+0.125))) ELSE @@ -636,16 +629,16 @@ FUNCTION FUNS(A) ENDIF RETURN END FUNCTION FUNS -C*********************************************************************** +!*********************************************************************** FUNCTION FMH(W) -C -C CALCULATES FD INTERGAL I_(-1/2)(ETA). INCLUDES FACTOR 1/GAMMA(1/2). -C ETA=LOG(W) -C - IF(W.LE.2.718282)THEN +! +! CALCULATES FD INTERGAL I_(-1/2)(ETA). INCLUDES FACTOR 1/GAMMA(1/2). +! ETA=LOG(W) +! + if (W <= 2.718282) then FMH=W*(1+W*(-.7070545+W*(-.3394862-W*6.923481E-4)) + /(1.+W*(1.2958546+W*.35469431))) - ELSEIF(W.LE.54.59815)THEN + elseif (W <= 54.59815) then X=LOG(dble(W)) FMH=(.6652309+X*(.7528360+X*.6494319)) + /(1.+X*(.8975007+X*.1153824)) @@ -655,81 +648,81 @@ FUNCTION FMH(W) FMH=SQRT(X)*(1.1283792+(Y*(-.4597911+Y*(2.286168-Y*183.6074))) + /(1.+Y*(-10.867628+Y*384.61501))) ENDIF -C + RETURN END FUNCTION FMH -C*********************************************************************** +!*********************************************************************** SUBROUTINE FDETA(X,ETA, ierr) -C -C GIVEN X=N_e/P_e, CALCULATES FERMI-DIRAC ETA -C USE CHEBYSHEV FITS OF W.J. CODY AND H.C. THACHER, -C MATHS. OF COMP., 21, 30, 1967. -C +! +! GIVEN X=N_e/P_e, CALCULATES FERMI-DIRAC ETA +! USE CHEBYSHEV FITS OF W.J. CODY AND H.C. THACHER, +! MATHS. OF COMP., 21, 30, 1967. +! integer, intent(inout) :: ierr DIMENSION D(2:12) DATA D/ + 3.5355339E-01, 5.7549910E-02, 5.7639604E-03, 4.0194942E-04, + 2.0981899E-05, 8.6021311E-07, 2.8647149E-08, 7.9528315E-10, + 1.8774422E-11, 3.8247505E-13, 6.8427624E-15/ -C + integer n,k -c -! ierr = 0 + +! ierr = 0 a=x*0.88622693 -c - IF(X.LT.1)THEN + + if (X < 1) then v=x S=V U=V - DO 10 N=2,12 + DO N=2,12 S=S*V SS=S*D(N) U=U+SS - IF(ABS(SS).LT.1.E-6*U)GOTO 11 - 10 CONTINUE + if (ABS(SS) < 1.E-6*U)GOTO 11 + END DO ! PRINT*,' COMPLETED LOOP 10 IN FDETA' ierr = 11 return ! STOP 11 ETA=LOG(dble(U)) -c + ELSE - if(a.lt.2)then + if (a < 2) then E=LOG(dble(X)) else e=pow(1.5d0*a,2d0/3d0) endif - do 20 k=1,10 + do k=1,10 CALL FDF1F2(E,F1,F2) DE=(A-F2)*2./F1 E=E+DE - if(abs(dE).lt.1.e-4*abs(E))goto 21 - 20 continue + if (abs(dE) < 1.e-4*abs(E))goto 21 + end do ! print*,' completed loop 20 IN FDETA' ierr = 12 return ! stop 21 ETA=E -c + ENDIF -C + RETURN END SUBROUTINE FDETA -C*********************************************************************** +!*********************************************************************** SUBROUTINE FDF1F2(ETA,F1,F2) -C -C CALCULATES FD INTEGRALS F1, F2=F(-1/2), F(+1/2) -C USE CHEBYSHEV FITS OF W.J. CODY AND H.C. THACHER, -C MATHS. OF COMP., 21, 30, 1967. -C - IF(ETA.LE.1)THEN +! +! CALCULATES FD INTEGRALS F1, F2=F(-1/2), F(+1/2) +! USE CHEBYSHEV FITS OF W.J. CODY AND H.C. THACHER, +! MATHS. OF COMP., 21, 30, 1967. +! + if (ETA <= 1) then X=exp(dble(ETA)) F1=X*(1.772454+X*(-1.2532215+X*(-0.60172359-X*0.0012271551))/ + (1.+X*(1.2958546+X*0.35469431))) F2=X*(0.88622693+X*(-0.31329180+X*(-0.14275695- + X*0.0010090890))/ + (1.+X*(0.99882853+X*0.19716967))) - ELSEIF(ETA.LE.4)THEN + elseif (ETA <= 4) then X=ETA F1=(1.17909+X*(1.334367+X*1.151088))/ + (1.+X*(0.8975007+X*0.1153824)) @@ -744,7 +737,7 @@ SUBROUTINE FDF1F2(ETA,F1,F2) + Y*290.433403))/ + (1.+Y*(5.69335697+Y*322.149800))) ENDIF -C + RETURN END SUBROUTINE FDF1F2 @@ -760,25 +753,25 @@ subroutine screen2(ft,fne,rion,epa,ntot,umin,umax,umesh,p) data twopi/6.283185/ COMMON/CIMESH/U(100),AA(nptot),BB(nptot),IN(nptot),ITOT,NN save /cimesh/ -c + rydt=ft/157894. aune=1.48185e-25*fne -c -c get alp2=1/(Debye)**2 + +! get alp2=1/(Debye)**2 b=0 do i=1,ipz b=b+rion(i)*i**2 - enddo + end do alp2=(5.8804e-19)*fne*b/(epa*ft) - if(alp2/ft.lt.5e-8)return !!!!!!!!!!! -c + if (alp2/ft < 5e-8) return !!!!!!!!!!! + c=1.7337*aune/sqrt(rydt) -c + do i=1,itot w=u(i)*rydt f(i)=0. - do 1 k=1,ipz - if(rion(k).le.0.01)goto 1 + do k=1,ipz + if (rion(k) <= 0.01) cycle crz=c*rion(k)*k**2 ff=0 do j=1,3 @@ -790,22 +783,22 @@ subroutine screen2(ft,fne,rion,epa,ntot,umin,umax,umesh,p) q=(1./x2-1./x1+LOG(dble(x1/x2)))* + (fkp*(1.-exp(dble(-twopi*k/fkp))))/(fk*(1.-exp(dble(-twopi*k/fk)))) ff=ff+wt(j)*q - enddo + end do f(i)=f(i)+crz*ff - 1 continue - enddo -c + end do + end do + p(1)=f(1) do n=2,nn w=umesh(n)*rydt p(n)=p(n)+(aa(n)*f(in(n)-1)+bb(n)*f(in(n)))/(w*w*w) - enddo + end do do n=nn+1,ntot w=umesh(n)*rydt p(n)=p(n)+f(in(n))/(w*w*w) - enddo -c + end do + return - end subroutine screen2 + end subroutine screen2 end module op_load diff --git a/kap/private/op_osc.f b/kap/private/op_osc.f index 295f5325d..fc3772067 100644 --- a/kap/private/op_osc.f +++ b/kap/private/op_osc.f @@ -22,7 +22,7 @@ ! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ! ! *********************************************************************** - + module op_osc use math_lib use op_def @@ -30,44 +30,44 @@ module op_osc use kap_def, only: kap_test_partials, kap_test_partials_val, kap_test_partials_dval_dx contains -c*********************************************************************** +!*********************************************************************** subroutine abund(nel, izz, fa, flmu, nkz) implicit none integer, intent(in) :: nel, izz(ipe) real, intent(in) :: fa(ipe) real, intent(out) :: flmu integer, intent(out) :: nkz(ipe) -c local variables +! local variables integer :: k, k1, k2, m real :: amamu(ipe), fmu -c -c Get k1,get amamu(k) - do k = 1, nel + +! Get k1,get amamu(k) + do k = 1, nel do m = 1, ipe - if(izz(k).eq.kz(m))then + if (izz(k) == kz(m)) then amamu(k) = amass(m) nkz(k) = m goto 1 endif - enddo + end do print*,' k=',k,', izz(k)=',izz(k) print*,' kz(m) not found' stop - 1 continue - enddo -c -c Mean atomic weight = fmu + 1 continue + end do + +! Mean atomic weight = fmu fmu = 0. do k = 1, nel fmu = fmu + fa(k)*amamu(k) - enddo -c + end do + fmu = fmu*1.660531e-24 ! Convert to cgs flmu = log10(dble(fmu)) -c + return end subroutine abund -c********************************************************************** +!********************************************************************** subroutine xindex(flt, ilab, xi, ih, i3, ierr) implicit none integer, intent(in) :: i3 @@ -77,16 +77,16 @@ subroutine xindex(flt, ilab, xi, ih, i3, ierr) integer, intent(out) :: ierr integer :: i, ih2 real :: x -c + ierr = 0 - if(flt.lt.3.5) then + if (flt < 3.5) then ierr = 102 return - elseif(flt.gt.8.) then + elseif (flt > 8.) then ierr = 102 return endif -c + x = 40.*flt/real(i3) ih2 = x ih2 = max(ih2, 140/i3+2) @@ -94,46 +94,45 @@ subroutine xindex(flt, ilab, xi, ih, i3, ierr) do i = 0, 5 ih(i) = ih2 + i - 2 ilab(i) = i3*ih(i) - enddo + end do xi = 2.*(x-ih2) - 1 -c + return end subroutine xindex -c********************************************************************** - subroutine jrange(ih, jhmin, jhmax, i3) +!********************************************************************** + subroutine jrange(ih, jhmin, jhmax, i3) implicit none integer, intent(in) :: ih(0:5), i3 - integer, intent(out) :: jhmin, jhmax + integer, intent(out) :: jhmin, jhmax integer :: i -c + jhmin = 0 jhmax = 1000 do i = 0, 5 jhmin = max(jhmin, js(ih(i)*i3)/i3) jhmax = min(jhmax, je(ih(i)*i3)/i3) - enddo -c + end do + return end subroutine jrange -c********************************************************************** +!********************************************************************** subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih, + flrho, flt, xi, flne, flmu, flr, epa, uy, i3, ierr) use op_load, only : solve implicit none - integer, intent(in) :: ilab(0:5), nel, nkz(ipe), jhmin, - > ih(0:5), i3 + integer, intent(in) :: ilab(0:5), nel, nkz(ipe), jhmin, ih(0:5), i3 integer, intent(inout) :: jhmax integer, intent(out) :: ierr real, intent(in) :: fa(ipe), flt, xi, flmu real,intent(out) :: flne, uy, epa real, intent(inout) :: flrho -c local variables +! local variables integer :: i, j, n, jh, jm, itt, jne, jnn - real :: flrmin, flrmax, flr(4,4), uyi(4), efa(0:5, 7:118), + real :: flrmin, flrmax, flr(4,4), uyi(4), efa(0:5, 7:118), : flrh(0:5, 7:118), u(4), flnei(4), y, zeta, efa_temp -c declare variables in common block, by default: real (a-h, o-z), integer (i-n) +! declare variables in common block, by default: real (a-h, o-z), integer (i-n) ! integer :: ite1, ite2, ite3, jn1, jn2, jne3, ntot, nc, nf, int, -! : ne1, ne2, np, kp1, kp2, kp3, npp, mx, nx +! : ne1, ne2, np, kp1, kp2, kp3, npp, mx, nx ! real :: umin, umax, epatom, oplnck, fion, yy1, yy2, yx ! common /atomdata/ ite1,ite2,ite3,jn1(91),jn2(91),jne3,umin,umax,ntot, ! + nc,nf,int(17),epatom(17,91,25),oplnck(17,91,25),ne1(17,91,25), @@ -141,204 +140,204 @@ subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih, ! + kp2(17,91,25),kp3(17,91,25),npp(17,91,25),mx(33417000), ! + yy1(33417000),yy2(120000000),nx(19305000),yx(19305000) ! save /atomdata/ -c -c efa(i,jh)=sum_n epa(i,jh,n)*fa(n) -c flrh(i,jh)=log10(rho(i,jh)) -c -c Get efa +! +! efa(i,jh)=sum_n epa(i,jh,n)*fa(n) +! flrh(i,jh)=log10(rho(i,jh)) +! +! Get efa do i = 0, 5 itt = (ilab(i)-ite1)/2 + 1 do jne = jn1(itt), jn2(itt), i3 jnn = (jne-jn1(itt))/2 + 1 jh = jne/i3 efa_temp = 0. - do n = 1, nel + do n = 1, nel efa_temp = efa_temp + epatom(nkz(n), itt, jnn)*fa(n) - enddo !n - efa(i, jh) = efa_temp - enddo !jne - enddo !i -c -c Get range for efa.gt.0 + end do !n + efa(i, jh) = efa_temp + end do !jne + end do !i + +! Get range for efa > 0 do i = 0, 5 do jh = jhmin, jhmax - if(efa(i, jh) .le. 0.)then + if (efa(i, jh) <= 0.) then jm = jh - 1 goto 3 endif - enddo + end do goto 4 3 jhmax = MIN(jhmax, jm) 4 continue - enddo -c -c Get flrh + end do + +! Get flrh do jh = jhmin,jhmax do i = 0,5 flrh(i, jh) = flmu + 0.25*i3*jh - log10(dble(efa(i,jh))) - enddo - enddo -c -c Find flrmin and flrmax + end do + end do + +! Find flrmin and flrmax flrmin = -1000 flrmax = 1000 do i = 0, 5 flrmin = max(flrmin, flrh(i,jhmin)) flrmax = min(flrmax, flrh(i,jhmax)) - enddo -c -c Check range of flrho - if(flrho .lt. flrmin .or. flrho .gt. flrmax)then + end do + +! Check range of flrho + if (flrho < flrmin .or. flrho > flrmax) then ierr = 101 return endif -c -c Interpolations in j for flne + +! Interpolations in j for flne do jh = jhmin, jhmax - if(flrh(2,jh) .gt. flrho)then + if (flrh(2,jh) > flrho) then jm = jh - 1 goto 5 endif - enddo + end do print*,' Interpolations in j for flne' print*,' Not found, i=',i stop 5 jm=max(jm,jhmin+1) jm=min(jm,jhmax-2) -c + do i = 1, 4 do j = 1, 4 u(j) = flrh(i, jm+j-2) flr(i,j) = flrh(i, jm+j-2) - enddo + end do call solve(u, flrho, zeta, uyi(i), ierr) if (ierr /= 0) return y = jm + 0.5*(zeta+1) flnei(i) = .25*i3*y - enddo -c -c Interpolations in i + end do + +! Interpolations in i flne = fint(flnei, xi) uy = fint(uyi, xi) -c Get epa - epa = exp10(dble(flne + flmu - flrho)) -c +! Get epa + epa = exp10(dble(flne + flmu - flrho)) + return -c + 601 format(' For flt=',1p,e11.3,', flrho=',e11.3,' is out of range'/ - + ' Allowed range for flrho is ',e11.3,' to ',e11.3) + + ' Allowed range for flrho is ',e11.3,' to ',e11.3) end subroutine findne -c*********************************************************************** +!*********************************************************************** subroutine yindex(jhmin, jhmax, flne, jh, i3, eta) implicit none integer, intent(in) :: jhmin, jhmax, i3 real, intent(in) :: flne integer, intent(out) :: jh(0:5) real, intent(out) :: eta -c local variables +! local variables integer :: j, k real :: y -c + y = 4.*flne/real(i3) j = y j = max(j,jhmin+2) j = min(j,jhmax-3) do k = 0, 5 jh(k) = j + k - 2 - enddo + end do eta = 2.*(y-j)-1 -c + return end subroutine yindex -c*********************************************************************** +!*********************************************************************** subroutine findux(flr, xi, eta, ux) implicit none real, intent(in) :: flr(4, 4), xi, eta real, intent(out) :: ux -c local variables - integer :: i, j +! local variables + integer :: i, j real :: uxj(4), u(4) -c + do j = 1, 4 do i = 1, 4 u(i) = flr(i, j) - enddo + end do uxj(j) = fintp(u, xi) - enddo + end do ux = fint(uxj, eta) -c + return - end subroutine findux -c********************************************************************** + end subroutine findux +!********************************************************************** subroutine rd(nel, nkz, izz, ilab, jh, n_tot, ff, rr, i3, umesh, fac) implicit none - integer, intent(in) :: nel, nkz(ipe), izz(ipe), ilab(0:5), - > jh(0:5), n_tot, i3 + integer, intent(in) :: nel, nkz(ipe), izz(ipe), ilab(0:5), + > jh(0:5), n_tot, i3 real, intent(in) :: umesh(nptot) real(dp), intent(in) :: fac(nel) real, intent(out) :: ff(:,:,0:,0:) ! (nptot, ipe, 6, 6) real, intent(out) :: rr(28, ipe, 0:5, 0:5) -c local variables +! local variables integer :: i, j, k, l, m, n, itt, jnn, izp, ne1, ne2, ne, ib, ia real :: fion(-1:28), yb, ya, d -c declare variables in common block (instead of by default: real (a-h, o-z), integer (i-n)) +! declare variables in common block (instead of by default: real (a-h, o-z), integer (i-n)) ! integer :: ite1, ite2, ite3, jn1, jn2, jne3, ntot, nc, nf, int, -! : ne1p, ne2p, np, kp1, kp2, kp3, npp, mx, nx -! real :: umin, umax, epatom, oplnck, fionp, yy1, yy2, yx +! : ne1p, ne2p, np, kp1, kp2, kp3, npp, mx, nx +! real :: umin, umax, epatom, oplnck, fionp, yy1, yy2, yx ! common /atomdata/ ite1,ite2,ite3,jn1(91),jn2(91),jne3,umin,umax,ntot, ! + nc,nf,int(17),epatom(17,91,25),oplnck(17,91,25),ne1p(17,91,25), ! + ne2p(17,91,25),fionp(-1:28,28,91,25),np(17,91,25),kp1(17,91,25), ! + kp2(17,91,25),kp3(17,91,25),npp(17,91,25),mx(33417000), -! + yy1(33417000),yy2(120000000),nx(19305000),yx(19305000) +! + yy1(33417000),yy2(120000000),nx(19305000),yx(19305000) ! save /atomdata/ -c -c i=temperature inex -c j=density index -c k=frequency index -c n=element index -c Get: -c mono opacity cross-section ff(k,n,i,j) -c modified cross-section for selected element, ta(k,i,j) -c -c Initialisations +! +! i=temperature inex +! j=density index +! k=frequency index +! n=element index +! Get: +! mono opacity cross-section ff(k,n,i,j) +! modified cross-section for selected element, ta(k,i,j) +! +! Initialisations rr=0. ff=0. -c -c Start loop on i (temperature index) + +! Start loop on i (temperature index) do i = 0, 5 - itt = (ilab(i) - ite1)/2 + 1 + itt = (ilab(i) - ite1)/2 + 1 do j = 0, 5 - jnn = (jh(j)*i3 - jn1(itt))/2 + 1 -c Read mono opacities + jnn = (jh(j)*i3 - jn1(itt))/2 + 1 +! Read mono opacities do n = 1, nel izp = izz(n) ne1 = ne1p(nkz(n), itt, jnn) ne2 = ne2p(nkz(n), itt, jnn) do ne = ne1, ne2 fion(ne) = fionp(ne, nkz(n), itt, jnn) - enddo + end do do ne = ne1, min(ne2, izp-2) rr(izp-1-ne, n, i, j) = fion(ne) - enddo - + end do + do k = 1, n_tot ff(k, n, i, j) = yy2(k+kp2(nkz(n), itt, jnn)) - enddo - + end do + if (fac(n) /= 1d0) then do k = 1, size(ff,dim=1) ff(k,n,i,j) = fac(n)*ff(k,n,i,j) end do end if - enddo !n - enddo !j - enddo !i -c + end do !n + end do !j + end do !i + return -c + end subroutine rd -c*********************************************************************** - subroutine ross(flmu, dv, ntot,rs, rossl) +!*********************************************************************** + subroutine ross(flmu, dv, ntot,rs, rossl) implicit none integer, intent(in) :: ntot real, intent(in) :: flmu, dv, rs(nptot, 0:5, 0:5) @@ -346,347 +345,346 @@ subroutine ross(flmu, dv, ntot,rs, rossl) integer :: i, j, n real(dp) :: drs, dd, oross real :: fmu, tt -c -c oross=cross-section in a.u. -c rossl=log10(ROSS in cgs) + +! oross=cross-section in a.u. +! rossl=log10(ROSS in cgs) do i = 0, 5 do j = 0, 5 drs = 0.d0 do n = 1, ntot dd = 1.d0/rs(n, i, j) drs = drs + dd - enddo + end do oross = 1.d0/(drs*dv) - rossl(i, j) = log10(oross) - 16.55280d0 - flmu !log10(fmu) - enddo !j - enddo !i -c + rossl(i, j) = log10(oross) - 16.55280d0 - flmu !log10(fmu) + end do !j + end do !i + return end subroutine ross -c*********************************************************************** +!*********************************************************************** subroutine mix(ntot, nel, fa, ff, rs, rr, rion) implicit none integer, intent(in) :: ntot, nel real, intent(in) :: ff(nptot, ipe, 0:5, 0:5), fa(ipe), rr(28, 17, 0:5, 0:5) real, intent(out) :: rs(nptot, 0:5, 0:5), rion(28, 0:5, 0:5) -c local variables +! local variables integer :: i, j, k, n, m real :: rs_temp, rion_temp -c + do i = 0, 5 do j = 0, 5 do n = 1, ntot !rs_temp = ff(n,1,i,j)*fa(1) !do k = 2, nel ! rs_temp = rs_temp + ff(n,k,i,j)*fa(k) - !enddo - !rs(n,i,j) = rs_temp + !end do + !rs(n,i,j) = rs_temp rs(n, i, j) = dot_product(ff(n,1:nel,i,j),fa(1:nel)) - enddo + end do do m = 1, 28 !rion_temp = rr(m, 1, i, j)*fa(1) !do k = 2, nel ! rion_temp = rion_temp + rr(m,k,i,j)*fa(k) - !enddo + !end do !rion(m,i,j) = rion_temp rion(m,i,j) = dot_product(rr(m,1:nel,i,j),fa(1:nel)) - enddo - enddo - enddo -c + end do + end do + end do + return end subroutine mix -C*********************************************************************** +!*********************************************************************** subroutine interp(nel, rossl, xi, eta, g, i3, ux, uy, gx, gy) implicit none integer, intent(in) :: nel, i3 real, intent(in) :: ux, uy, xi, eta real, intent(out) :: gx, gy, g -c local variables +! local variables integer :: i, j, l real :: V(4), U(4), vyi(4) real :: x3(3), fx3!, fxxy(0:5, 0:5), fyxy(0:5, 0:5) -c pointers and targets - real, target :: fx(0:5, 0:5), fy(0:5, 0:5), fxy(0:5, 0:5), fyx(0:5, 0:5), +! pointers and targets + real, target :: fx(0:5, 0:5), fy(0:5, 0:5), fxy(0:5, 0:5), fyx(0:5, 0:5), : fxx(0:5, 0:5), fyy(0:5, 0:5), rossl(0:5, 0:5) - real, pointer :: f3(:), fin(:, :), finx(:, :), finy(:, :) -c -c interpolation of g (=rosseland mean opacity) -c Use refined techniques of bi-cubic spline interpolation (Seaton 1993): + real, pointer :: f3(:), fin(:, :), finx(:, :), finy(:, :) +! +! interpolation of g (=rosseland mean opacity) +! Use refined techniques of bi-cubic spline interpolation (Seaton 1993): ! call deriv(rossl, fx, fy, fxy) ! call interp2(rossl, fx, fy, fxy, xi, eta, g, gx, gy) ! gy = 0.5*gy/uy ! gx = (80./real(i3))*(0.5*gx-gy*ux) -c Alternatively, use interpolation techniques by M.-A. Dupret to ensure smooothness required -c for pulsation studies: +! Alternatively, use interpolation techniques by M.-A. Dupret to ensure smooothness required +! for pulsation studies: do i = 0, 3 x3(1) = i x3(2) = i+1 - x3(3) = i+2 + x3(3) = i+2 do j = 1, 4 f3 => rossl(i:i+2, j) call deriv3(f3, x3, fx3) fx(i+1, j) = fx3 - enddo - enddo + end do + end do do i = 0, 3 x3(1) = i x3(2) = i+1 - x3(3) = i+2 - do j = 1, 4 + x3(3) = i+2 + do j = 1, 4 f3 => rossl(j, i:i+2) call deriv3(f3, x3, fx3) fy(j, i+1) = fx3 - enddo - enddo + end do + end do do i = 1, 2 x3(1) = i x3(2) = i+1 - x3(3) = i+2 + x3(3) = i+2 do j = 2, 3 f3 => fx(i:i+2, j) call deriv3(f3, x3, fx3) fxx(i+1, j) = fx3 - enddo - enddo + end do + end do do i = 1, 2 x3(1) = i x3(2) = i+1 - x3(3) = i+2 + x3(3) = i+2 do j = 2, 3 f3 => fx(j, i:i+2) call deriv3(f3, x3, fx3) fxy(j, i+1) = fx3 - enddo - enddo + end do + end do do i = 1, 2 x3(1) = i x3(2) = i+1 - x3(3) = i+2 + x3(3) = i+2 do j = 2, 3 f3 => fy(i:i+2, j) call deriv3(f3, x3, fx3) fyx(i+1, j) = fx3 - enddo - enddo + end do + end do do i = 1, 2 x3(1) = i x3(2) = i+1 - x3(3) = i+2 + x3(3) = i+2 do j = 2, 3 f3 => fy(j, i:i+2) call deriv3(f3, x3, fx3) fyy(j, i+1) = fx3 - enddo - enddo -! call deriv(rossl, fx, fy, fxy) -! call deriv(fx, fxx, fxy, fxxy) -! call deriv(fy, fyx, fyy, fyxy) + end do + end do +! call deriv(rossl, fx, fy, fxy) +! call deriv(fx, fxx, fxy, fxxy) +! call deriv(fy, fyx, fyy, fyxy) fin => rossl(2:3, 2:3) finx => fx(2:3, 2:3) finy => fy(2:3, 2:3) - call interp3(fin, finx, finy, xi, eta, g) + call interp3(fin, finx, finy, xi, eta, g) fin => fx(2:3, 2:3) finx => fxx(2:3, 2:3) - finy => fxy(2:3, 2:3) - call interp3(fin, finx, finy, xi, eta, gx) + finy => fxy(2:3, 2:3) + call interp3(fin, finx, finy, xi, eta, gx) fin => fy(2:3, 2:3) finx => fyx(2:3, 2:3) - finy => fyy(2:3, 2:3) - call interp3(fin, finx, finy, xi, eta, gy) + finy => fyy(2:3, 2:3) + call interp3(fin, finx, finy, xi, eta, gy) gy = 0.5*gy/uy gx = (80./real(i3))*(0.5*gx-gy*ux) -c + RETURN - end subroutine interp -C************************************** + end subroutine interp +!************************************** function fint(u,r) dimension u(4) -c -c If P(R) = u(1) u(2) u(3) u(4) -c for R = -3 -1 1 3 -c then a cubic fit is: - P(R)=( + +! If P(R) = u(1) u(2) u(3) u(4) +! for R = -3 -1 1 3 +! then a cubic fit is: + P(R)=( + 27*(u(3)+u(2))-3*(u(1)+u(4)) +R*( + 27*(u(3)-u(2))-(u(4)-u(1)) +R*( + -3*(u(2)+u(3))+3*(u(4)+u(1)) +R*( + -3*(u(3)-u(2))+(u(4)-u(1)) ))))/48. -c +! fint=p(r) -c +! return end function fint -c*********************************************************************** +!*********************************************************************** function fintp(u,r) dimension u(4) -c -c If P(R) = u(1) u(2) u(3) u(4) -c for R = -3 -1 1 3 -c then a cubic fit to the derivative is: - PP(R)=( + +! If P(R) = u(1) u(2) u(3) u(4) +! for R = -3 -1 1 3 +! then a cubic fit to the derivative is: + PP(R)=( + 27*(u(3)-u(2))-(u(4)-u(1)) +2.*R*( + -3*(u(2)+u(3))+3*(u(4)+u(1)) +3.*R*( + -3*(u(3)-u(2))+(u(4)-u(1)) )))/48. -c + fintp=pp(r) -c + return end function fintp -C -c*********************************************************************** + +!*********************************************************************** SUBROUTINE DERIV(f, fx, fy, fxy) -C + real, intent(in) :: f(0:5, 0:5) - real, intent(out) :: fx(0:5, 0:5), fy(0:5, 0:5), fxy(0:5, 0:5) + real, intent(out) :: fx(0:5, 0:5), fy(0:5, 0:5), fxy(0:5, 0:5) real :: C(6) -C -C GET FX - DO 70 J = 0, 5 + +! GET FX + DO J = 0, 5 L=0 - DO 50 I = 0, 5 + DO I = 0, 5 L=L+1 C(L)=F(I,J) - 50 CONTINUE + END DO CALL GET(C,L) L=0 - DO 60 I = 0, 5 + DO I = 0, 5 L = L + 1 FX(I, J) = C(L) - 60 CONTINUE - 70 CONTINUE -C -C GET FY - DO 100 I = 0, 5 + END DO + END DO + +! GET FY + DO I = 0, 5 L=0 - DO 80 J = 0, 5 + DO J = 0, 5 L = L + 1 C(L) = F(I, J) - 80 CONTINUE + END DO CALL GET(C,L) L=0 - DO 90 J = 0, 5 + DO J = 0, 5 L = L + 1 FY(I,J) = C(L) - 90 CONTINUE - 100 CONTINUE -C -C GET FXY - DO 130 I = 0, 5 + END DO + END DO + +! GET FXY + DO I = 0, 5 L = 0 - DO 110 J = 0, 5 + DO J = 0, 5 L = L + 1 C(L) = FX(I, J) - 110 CONTINUE + END DO CALL GET(C,L) L=0 - DO 120 J = 0, 5 + DO J = 0, 5 L = L + 1 FXY(I,J) = C(L) - 120 CONTINUE - 130 CONTINUE -c + END DO + END DO + RETURN -C + END SUBROUTINE DERIV -CC****************************************************************** -C +!****************************************************************** +! SUBROUTINE GET(F,N) -C -C SIMPLIFIED CODE FOR SPLINE COEFFICIENTS, FOR CASE OF INTERVALS -C OF UNITY. -C RETURNS DERIVATIVES OF ORIGINAL F IN LOCATION F -C -c REVISED 5.5.95 -C +! +! SIMPLIFIED CODE FOR SPLINE COEFFICIENTS, FOR CASE OF INTERVALS +! OF UNITY. +! RETURNS DERIVATIVES OF ORIGINAL F IN LOCATION F +! +! REVISED 5.5.95 +! PARAMETER (IPI=6) DIMENSION F(IPI),D(IPI),T(IPI) -C - IF(N.LE.0)THEN + + if (N <= 0) then WRITE(6,*)' Error in SUBROUTINE GET: N=',N STOP - ELSEIF(N.EQ.1)THEN + elseif (N == 1) then F(1)=0. RETURN - ELSEIF(N.EQ.2)THEN + elseif (N == 2) then F(1)=F(2)-F(1) F(2)=F(1) RETURN - ELSEIF(N.EQ.3)THEN + elseif (N == 3) then FP1=.5*(-3.*F(1)+4.*F(2)-F(3)) FPN=.5*(F(1)-4.*F(2)+3.*F(3)) ELSE FP1=(-11.*F(1)+18.*F(2)-9.*F(3)+2.*F(4))/6. FPN=(11.*F(N)-18.*F(N-1)+9.*F(N-2)-2.*F(N-3))/6. ENDIF -C + D(1)=-.5 T(1)=.5*(-F(1)+F(2)-FP1) -C - DO 10 J=2,N-1 + + DO J=2,N-1 D(J)=-1./(4.+D(J-1)) T(J)=-D(J)*(F(J-1)-2.*F(J)+F(J+1)-T(J-1)) - 10 CONTINUE -C + END DO + D(N)=(FPN+F(N-1)-F(N)-T(N-1))/(2.+D(N-1)) -C - DO 20 J=N-1,1,-1 + + DO J=N-1,1,-1 D(J)=D(J)*D(J+1)+T(J) - 20 CONTINUE -C - DO 30 J=2,N-1 + END DO + + DO J=2,N-1 F(J)=-F(J)+F(J+1)-2.*D(J)-D(J+1) - 30 CONTINUE + END DO F(1)=FP1 F(N)=FPN -C + RETURN END SUBROUTINE GET -C -c*********************************************************************** + +!*********************************************************************** subroutine INTERP2(f, fx, fy, fxy, xi, eta, g, gx, gy) real, intent(in) :: eta, xi, f(0:5, 0:5), fx(0:5, 0:5), fy(0:5, 0:5), fxy(0:5, 0:5) real, intent(out) :: g, gx, gy integer :: i , j real :: x, y, B(16) -C -C FUNCTION DEFINITIONS FOR CUBIC EXPANSION -C +! +! FUNCTION DEFINITIONS FOR CUBIC EXPANSION +! FF(S,T)= B( 1)+T*(B( 2)+T*(B( 3)+T*B( 4))) + +S*( B( 5)+T*(B( 6)+T*(B( 7)+T*B( 8))) + +S*( B( 9)+T*(B(10)+T*(B(11)+T*B(12))) + +S*( B(13)+T*(B(14)+T*(B(15)+T*B(16))) ))) -C + FFX(S,T)= B( 5)+T*(B( 6)+T*(B( 7)+T*B( 8))) + +S*( 2*(B( 9)+T*(B(10)+T*(B(11)+T*B(12)))) + +S*( 3*(B(13)+T*(B(14)+T*(B(15)+T*B(16)))) )) -C + FFY(S,T)= B( 2)+S*(B( 6)+S*(B(10)+S*B(14))) + +T*( 2*(B( 3)+S*(B( 7)+S*(B(11)+S*B(15)))) + +T*( 3*(B( 4)+S*(B( 8)+S*(B(12)+S*B(16)))) )) -C -C + Y = (eta + 5.)/2. - X = (xi + 5.)/2. + X = (xi + 5.)/2. ! i = floor(x) ! j = floor(y) I = X + 1.E-5 - IF(ABS(X-I).LE.1.E-5) X = I + if (ABS(X-I) <= 1.E-5) X = I J = Y + 1.E-5 - IF(ABS(Y-J).LE.1.E-5) Y = J -C -C INTERPOLATE -C -C GIVEN FUNCTIONS AND DERIVATIVES AT GRID POINTS, COMPUTE COEFFICIENTS. + if (ABS(Y-J) <= 1.E-5) Y = J +! +! INTERPOLATE +! +! GIVEN FUNCTIONS AND DERIVATIVES AT GRID POINTS, COMPUTE COEFFICIENTS. B(1)=F(I,J) B(2)=FY(I,J) B(3)=3*(-F(I,J)+F(I,J+1))-2*FY(I,J)-FY(I,J+1) B(4)=2*(F(I,J)-F(I,J+1))+FY(I,J)+FY(I,J+1) -C + B(5)=FX(I,J) B(6)=FXY(I,J) B(7)=3*(-FX(I,J)+FX(I,J+1))-2*FXY(I,J)-FXY(I,J+1) B(8)=2*(FX(I,J)-FX(I,J+1))+FXY(I,J)+FXY(I,J+1) -C + B(9)=3*(-F(I,J)+F(I+1,J))-2*FX(I,J)-FX(I+1,J) B(10)=3*(-FY(I,J)+FY(I+1,J))-2*FXY(I,J)-FXY(I+1,J) B(11)=9*(F(I,J)-F(I+1,J)+F(I+1,J+1)-F(I,J+1)) @@ -700,7 +698,7 @@ subroutine INTERP2(f, fx, fy, fxy, xi, eta, g, gx, gy) + +3*(-FY(I,J)+FY(I+1,J)+FY(I+1,J+1)-FY(I,J+1)) + +2*(-FX(I+1,J)+FX(I+1,J+1)-FXY(I,J)-FXY(I,J+1)) + -FXY(I+1,J)-FXY(I+1,J+1) -C + B(13)=2*(F(I,J)-F(I+1,J))+FX(I,J)+FX(I+1,J) B(14)=2*(FY(I,J)-FY(I+1,J))+FXY(I,J)+FXY(I+1,J) B(15)=6*(-F(I,J)+F(I+1,J)-F(I+1,J+1)+F(I,J+1)) @@ -712,9 +710,9 @@ subroutine INTERP2(f, fx, fy, fxy, xi, eta, g, gx, gy) + +2*(FX(I,J)+FX(I+1,J)-FX(I+1,J+1)-FX(I,J+1) + +FY(I,J)-FY(I+1,J)-FY(I+1,J+1)+FY(I,J+1)) + +FXY(I,J)+FXY(I+1,J)+FXY(I+1,J+1)+FXY(I,J+1) -C -C GET G=LOG10(ROSS), DGDT=d LOG10(ROSS)/d LOG10(T), -C DGDRHO=d LOG10(ROSS)/d LOG10(RHO) +! +! GET G=LOG10(ROSS), DGDT=d LOG10(ROSS)/d LOG10(T), +! DGDRHO=d LOG10(ROSS)/d LOG10(RHO) U = X - I V = Y - J G = FF(U, V) @@ -723,39 +721,39 @@ subroutine INTERP2(f, fx, fy, fxy, xi, eta, g, gx, gy) ! DGDT=(1./CT)*FFX(U,V)-(3./CN)*FFY(U,V) ! DGDRHO=(1./CN)*FFY(U,V) RETURN -C + END SUBROUTINE INTERP2 -c************************************************************* -c This subroutine estimates the partial derivative of a function -c as described in the PhD thesis by M.-A. Dupret. +!************************************************************* +! This subroutine estimates the partial derivative of a function +! as described in the PhD thesis by M.-A. Dupret. subroutine deriv3(f, x, fx) real, intent(in) :: f(3), x(3) real, intent(out) :: fx real :: a, a1, a2, b, x1, x2 -c + x1 = (f(3)- f(2))/(x(3)-x(2)) x2 = (f(2)-f(1))/(x(2)-x(1)) b = abs(x1/x2) a = (2.*x(2) - x(1) - x(3))/((x(2)-x(1))*(x(2)-x(3))) a1 = (x(2)-x(3))/((x(1)-x(3))*(x(1)-x(2))) a2 = (x(2)-x(1))/((x(3)-x(2))*(x(3)-x(1))) - if (b .ge. 0.2 .and. b .le. 5.) then + if (b >= 0.2 .and. b <= 5.) then fx = a*f(2) + a1*f(1) + a2*f(3) else if (abs(x1) f(1:ntot,i,j) -! enddo +! end do ! do m=1,28 rr => rion(1:28,i,j) -! enddo +! end do call screen2(ft,fne,rr,epa,ntot,umin,umax,umesh,p) ! do k=1,ntot ! f(k,i,j)=p(k) -! enddo - enddo - enddo -C +! end do + end do + end do + return end subroutine screen1 -c*********************************************************************** +!*********************************************************************** end module op_osc diff --git a/num/make/makefile_base b/num/make/makefile_base index fc6e43232..32b1569c3 100644 --- a/num/make/makefile_base +++ b/num/make/makefile_base @@ -69,26 +69,21 @@ nodeps : $(.DEFAULT_GOAL) # # COMPULATION RULES -#COMPILE_LEGACY = $(filter-out -std=f2008, $(COMPILE_TO_TEST)) -COMPILE_LEGACY = $(filter-out -std=f2008, $(COMPILE_TO_DEPLOY)) -std=legacy +COMPILE = $(COMPILE_TO_DEPLOY) $(FCfixed) -COMPILE = $(COMPILE_LEGACY) $(FCfixed) - -COMPILE_FREE = $(COMPILE_LEGACY) $(FCfree) +COMPILE_FREE = $(COMPILE_TO_DEPLOY) $(FCfree) #COMPILE_XTRA = $(COMPILE_NO_CHECKS) $(FCfixed) -c COMPILE_XTRA = $(COMPILE_BASIC) $(FCopt) $(FCfixed) -c -COMPILE_LEGACY_XTRA = $(filter-out -std=f2008, $(COMPILE_XTRA)) -std=legacy - COMPILE_CMD = $(COMPILE) mod_bobyqa.o mod_newuoa.o mod_dop853.o mod_dopri5.o mod_dc_decsol.o mod_rosenbrock.o : %.o : %.f ifneq ($(QUIET),) - @echo COMPILE_LEGACY_XTRA $< - @$(COMPILE_LEGACY_XTRA) $< + @echo COMPILE_XTRA $< + @$(COMPILE_XTRA) $< else - $(COMPILE_LEGACY_XTRA) $< + $(COMPILE_XTRA) $< endif %.o : %.mod diff --git a/num/private/decomc.dek b/num/private/decomc.dek index 8fd2bdf15..685ef4a59 100644 --- a/num/private/decomc.dek +++ b/num/private/decomc.dek @@ -10,6 +10,10 @@ #include "mtx_decsolc.dek" #include "mtx_decsolcs.dek" end interface + integer :: m1, m2, nm1, lde1, ijob + integer :: mle, mue, mbjac, mbb, mdiag, mdiff, mbdiag + integer :: nzmax, isparse, lcd, lrd, lid + integer :: ierr, ip2(nm1), n, ldjac, ldmas, mlmas, mumas integer :: ia(*), ja(nzmax) ! ia(n+1) when used; ia(2) when not. double precision :: sparse_jac(nzmax) double precision :: sar(nzmax), sai(nzmax) @@ -19,10 +23,6 @@ double precision :: fjac(ldjac,n), fmas(ldmas,nm1) double precision :: e2r(lde1,nm1), e2i(lde1,nm1) double precision :: br(n), bi(n), alphn, betan - integer :: ierr, ip2(nm1), n, ldjac, ldmas, mlmas, mumas - integer :: m1, m2, nm1, lde1, ijob - integer :: mle, mue, mbjac, mbb, mdiag, mdiff, mbdiag - integer :: nzmax, isparse, lcd, lrd, lid ! LOCALS integer :: i, j, k, jm1, mm, imle, ib, hint @@ -313,6 +313,10 @@ #include "mtx_decsolc.dek" #include "mtx_decsolcs.dek" end interface + integer :: m1, m2, nm1, lde1, ijob + integer :: mle, mue, mbjac, mbb, mdiag, mdiff, mbdiag + integer :: nzmax, isparse, lcd, lrd, lid + integer :: ierr, ip2(nm1), n, ldjac, ldmas, mlmas, mumas integer :: ia(:) ! (n+1) integer :: ja(:) ! (nzmax) real(dp) :: sparse_jac(:) ! (nzmax) @@ -328,10 +332,6 @@ double precision :: br(n), bi(n), alphn, betan - integer :: ierr, ip2(nm1), n, ldjac, ldmas, mlmas, mumas - integer :: m1, m2, nm1, lde1, ijob - integer :: mle, mue, mbjac, mbb, mdiag, mdiff, mbdiag - integer :: nzmax, isparse, lcd, lrd, lid goto (1,2,3,4,5,6,55,8,9,55,11,12,13,14,15), ijob diff --git a/num/private/estrad.dek b/num/private/estrad.dek index 6094819fe..a64e3e991 100644 --- a/num/private/estrad.dek +++ b/num/private/estrad.dek @@ -11,6 +11,10 @@ #include "mtx_decsol.dek" #include "mtx_decsols.dek" end interface + integer, pointer :: ip1(:) ! (nm1) + integer :: n, iphes(n), nerror, ldjac, mljac, mujac, ldmas, mlmas, mumas + integer :: nfcn, ijob, m1, m2, nm1, lde1, lrpar, lipar, ier, mle, mue + integer :: mbjac, mbb, mdiag, mdiff, mbdiag, nzmax, isparse, lrd, lid integer :: ia(:) ! (n+1) integer :: ja(:) ! (nzmax) double precision :: sa(nzmax) @@ -19,10 +23,6 @@ integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - integer, pointer :: ip1(:) ! (nm1) - integer :: iphes(n), n, nerror, ldjac, mljac, mujac, ldmas, mlmas, mumas - integer :: nfcn, ijob, m1, m2, nm1, lde1, lrpar, lipar, ier, mle, mue - integer :: mbjac, mbb, mdiag, mdiff, mbdiag, nzmax, isparse, lrd, lid double precision :: fjac(ldjac,n), fmas(ldmas,nm1) double precision, pointer :: e1_1D(:) double precision :: x, scal(n), y0(n), y(n) diff --git a/num/private/mod_bobyqa.f b/num/private/mod_bobyqa.f index a3424b662..4a8c07c1c 100644 --- a/num/private/mod_bobyqa.f +++ b/num/private/mod_bobyqa.f @@ -4,8 +4,7 @@ module mod_bobyqa contains - SUBROUTINE do_BOBYQA (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, - 1 MAXFUN,W,CALFUN,max_valid_value) + SUBROUTINE do_BOBYQA (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT,MAXFUN,W,CALFUN,max_valid_value) IMPLICIT REAL(dp) (A-H,O-Z) integer :: N, NPT, IPRINT, MAXFUN DIMENSION X(:),XL(:),XU(:),W(*) @@ -58,10 +57,9 @@ SUBROUTINE do_BOBYQA (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! Return if the value of NPT is unacceptable. ! NP=N+1 - IF (NPT .LT. N+2 .OR. NPT .GT. ((N+2)*NP)/2) THEN + IF (NPT < N+2 .OR. NPT > ((N+2)*NP)/2) THEN PRINT 10 - 10 FORMAT (/4X,'Return from BOBYQA because NPT is not in', - 1 ' the required interval') + 10 FORMAT (/4X,'Return from BOBYQA because NPT is not in the required interval') GO TO 40 END IF ! @@ -96,40 +94,39 @@ SUBROUTINE do_BOBYQA (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! components of X that become within distance RHOBEG from their bounds. ! ZERO=0.0D0 - DO 30 J=1,N - TEMP=XU(J)-XL(J) - IF (TEMP .LT. RHOBEG+RHOBEG) THEN - PRINT 20 - 20 FORMAT (/4X,'Return from BOBYQA because one of the', - 1 ' differences XU(I)-XL(I)'/6X,' is less than 2*RHOBEG.') - GO TO 40 - END IF - JSL=ISL+J-1 - JSU=JSL+N - W(JSL)=XL(J)-X(J) - W(JSU)=XU(J)-X(J) - IF (W(JSL) .GE. -RHOBEG) THEN - IF (W(JSL) .GE. ZERO) THEN - X(J)=XL(J) - W(JSL)=ZERO - W(JSU)=TEMP - ELSE - X(J)=XL(J)+RHOBEG - W(JSL)=-RHOBEG - W(JSU)=DMAX1(XU(J)-X(J),RHOBEG) - END IF - ELSE IF (W(JSU) .LE. RHOBEG) THEN - IF (W(JSU) .LE. ZERO) THEN - X(J)=XU(J) - W(JSL)=-TEMP - W(JSU)=ZERO - ELSE - X(J)=XU(J)-RHOBEG - W(JSL)=DMIN1(XL(J)-X(J),-RHOBEG) - W(JSU)=RHOBEG - END IF - END IF - 30 CONTINUE + DO J=1,N + TEMP=XU(J)-XL(J) + IF (TEMP < RHOBEG+RHOBEG) THEN + PRINT 20 + 20 FORMAT (/4X,'Return from BOBYQA because one of the differences XU(I)-XL(I)'/6X,' is less than 2*RHOBEG.') + GO TO 40 + END IF + JSL=ISL+J-1 + JSU=JSL+N + W(JSL)=XL(J)-X(J) + W(JSU)=XU(J)-X(J) + IF (W(JSL) >= -RHOBEG) THEN + IF (W(JSL) >= ZERO) THEN + X(J)=XL(J) + W(JSL)=ZERO + W(JSU)=TEMP + ELSE + X(J)=XL(J)+RHOBEG + W(JSL)=-RHOBEG + W(JSU)=DMAX1(XU(J)-X(J),RHOBEG) + END IF + ELSE IF (W(JSU) <= RHOBEG) THEN + IF (W(JSU) <= ZERO) THEN + X(J)=XU(J) + W(JSL)=-TEMP + W(JSU)=ZERO + ELSE + X(J)=XU(J)-RHOBEG + W(JSL)=DMIN1(XL(J)-X(J),-RHOBEG) + W(JSU)=RHOBEG + END IF + END IF + END DO ! ! Make the call of BOBYQB. ! @@ -210,12 +207,13 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, CALL PRELIM (N,NPT,X,XL,XU,RHOBEG,IPRINT,MAXFUN,XBASE,XPT, 1 FVAL,GOPT,HQ,PQ,BMAT,ZMAT,NDIM,SL,SU,NF,KOPT,CALFUN) XOPTSQ=ZERO - DO 10 I=1,N - XOPT(I)=XPT(KOPT,I) - 10 XOPTSQ=XOPTSQ+XOPT(I)**2 + DO I=1,N + XOPT(I)=XPT(KOPT,I) + XOPTSQ=XOPTSQ+XOPT(I)**2 + END DO FSAVE=FVAL(1) - IF (NF .LT. NPT) THEN - IF (IPRINT .GT. 0) PRINT 390 + IF (NF < NPT) THEN + IF (IPRINT > 0) PRINT 390 GOTO 720 END IF KBASE=1 @@ -234,21 +232,26 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! Update GOPT if necessary before the first iteration and after each ! call of RESCUE that makes a call of CALFUN. ! - 20 IF (KOPT .NE. KBASE) THEN + 20 IF (KOPT /= KBASE) THEN IH=0 - DO 30 J=1,N - DO 30 I=1,J - IH=IH+1 - IF (I .LT. J) GOPT(J)=GOPT(J)+HQ(IH)*XOPT(I) - 30 GOPT(I)=GOPT(I)+HQ(IH)*XOPT(J) - IF (NF .GT. NPT) THEN - DO 50 K=1,NPT - TEMP=ZERO - DO 40 J=1,N - 40 TEMP=TEMP+XPT(K,J)*XOPT(J) - TEMP=PQ(K)*TEMP - DO 50 I=1,N - 50 GOPT(I)=GOPT(I)+TEMP*XPT(K,I) + DO J=1,N + DO I=1,J + IH=IH+1 + IF (I < J) GOPT(J)=GOPT(J)+HQ(IH)*XOPT(I) + GOPT(I)=GOPT(I)+HQ(IH)*XOPT(J) + END DO + END DO + IF (NF > NPT) THEN + DO K=1,NPT + TEMP=ZERO + DO J=1,N + TEMP=TEMP+XPT(K,J)*XOPT(J) + END DO + TEMP=PQ(K)*TEMP + DO I=1,N + GOPT(I)=GOPT(I)+TEMP*XPT(K,I) + END DO + END DO END IF END IF ! @@ -262,10 +265,10 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, 60 CALL TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA,XNEW,D, 1 W,W(NP),W(NP+N),W(NP+2*N),W(NP+3*N),DSQ,CRVMIN) DNORM=DMIN1(DELTA,DSQRT(DSQ)) - IF (DNORM .LT. HALF*RHO) THEN + IF (DNORM < HALF*RHO) THEN NTRITS=-1 DISTSQ=(TEN*RHO)**2 - IF (NF .LE. NFSAV+2) GOTO 650 + IF (NF <= NFSAV+2) GOTO 650 ! ! The following choice between labels 650 and 680 depends on whether or ! not our work with the current RHO seems to be complete. Either RHO is @@ -275,21 +278,21 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! ERRBIG=DMAX1(DIFFA,DIFFB,DIFFC) FRHOSQ=0.125D0*RHO*RHO - IF (CRVMIN .GT. ZERO .AND. ERRBIG .GT. FRHOSQ*CRVMIN) - 1 GOTO 650 + IF (CRVMIN > ZERO .AND. ERRBIG > FRHOSQ*CRVMIN) GOTO 650 BDTOL=ERRBIG/RHO - DO 80 J=1,N - BDTEST=BDTOL - IF (XNEW(J) .EQ. SL(J)) BDTEST=W(J) - IF (XNEW(J) .EQ. SU(J)) BDTEST=-W(J) - IF (BDTEST .LT. BDTOL) THEN - CURV=HQ((J+J*J)/2) - DO 70 K=1,NPT - 70 CURV=CURV+PQ(K)*XPT(K,J)**2 - BDTEST=BDTEST+HALF*CURV*RHO - IF (BDTEST .LT. BDTOL) GOTO 650 - END IF - 80 CONTINUE + DO J=1,N + BDTEST=BDTOL + IF (XNEW(J) == SL(J)) BDTEST=W(J) + IF (XNEW(J) == SU(J)) BDTEST=-W(J) + IF (BDTEST < BDTOL) THEN + CURV=HQ((J+J*J)/2) + DO K=1,NPT + CURV=CURV+PQ(K)*XPT(K,J)**2 + END DO + BDTEST=BDTEST+HALF*CURV*RHO + IF (BDTEST < BDTOL) GOTO 650 + END IF + END DO GOTO 680 END IF NTRITS=NTRITS+1 @@ -300,67 +303,82 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! derivatives of the current model, beginning with the changes to BMAT ! that do not depend on ZMAT. VLAG is used temporarily for working space. ! - 90 IF (DSQ .LE. 1.0D-3*XOPTSQ) THEN + 90 IF (DSQ <= 1.0D-3*XOPTSQ) THEN FRACSQ=0.25D0*XOPTSQ SUMPQ=ZERO - DO 110 K=1,NPT - SUMPQ=SUMPQ+PQ(K) - SUM=-HALF*XOPTSQ - DO 100 I=1,N - 100 SUM=SUM+XPT(K,I)*XOPT(I) - W(NPT+K)=SUM - TEMP=FRACSQ-HALF*SUM - DO 110 I=1,N - W(I)=BMAT(K,I) - VLAG(I)=SUM*XPT(K,I)+TEMP*XOPT(I) - IP=NPT+I - DO 110 J=1,I - 110 BMAT(IP,J)=BMAT(IP,J)+W(I)*VLAG(J)+VLAG(I)*W(J) + DO K=1,NPT + SUMPQ=SUMPQ+PQ(K) + SUM=-HALF*XOPTSQ + DO I=1,N + SUM=SUM+XPT(K,I)*XOPT(I) + END DO + W(NPT+K)=SUM + TEMP=FRACSQ-HALF*SUM + DO I=1,N + W(I)=BMAT(K,I) + VLAG(I)=SUM*XPT(K,I)+TEMP*XOPT(I) + IP=NPT+I + DO J=1,I + BMAT(IP,J)=BMAT(IP,J)+W(I)*VLAG(J)+VLAG(I)*W(J) + END DO + END DO + END DO ! ! Then the revisions of BMAT that depend on ZMAT are calculated. ! - DO 150 JJ=1,NPTM - SUMZ=ZERO - SUMW=ZERO - DO 120 K=1,NPT - SUMZ=SUMZ+ZMAT(K,JJ) - VLAG(K)=W(NPT+K)*ZMAT(K,JJ) - 120 SUMW=SUMW+VLAG(K) - DO 140 J=1,N - SUM=(FRACSQ*SUMZ-HALF*SUMW)*XOPT(J) - DO 130 K=1,NPT - 130 SUM=SUM+VLAG(K)*XPT(K,J) - W(J)=SUM - DO 140 K=1,NPT - 140 BMAT(K,J)=BMAT(K,J)+SUM*ZMAT(K,JJ) - DO 150 I=1,N - IP=I+NPT - TEMP=W(I) - DO 150 J=1,I - 150 BMAT(IP,J)=BMAT(IP,J)+TEMP*W(J) + DO JJ=1,NPTM + SUMZ=ZERO + SUMW=ZERO + DO K=1,NPT + SUMZ=SUMZ+ZMAT(K,JJ) + VLAG(K)=W(NPT+K)*ZMAT(K,JJ) + SUMW=SUMW+VLAG(K) + END DO + DO J=1,N + SUM=(FRACSQ*SUMZ-HALF*SUMW)*XOPT(J) + DO K=1,NPT + SUM=SUM+VLAG(K)*XPT(K,J) + END DO + W(J)=SUM + DO K=1,NPT + BMAT(K,J)=BMAT(K,J)+SUM*ZMAT(K,JJ) + END DO + END DO + DO I=1,N + IP=I+NPT + TEMP=W(I) + DO J=1,I + BMAT(IP,J)=BMAT(IP,J)+TEMP*W(J) + END DO + END DO + END DO ! ! The following instructions complete the shift, including the changes ! to the second derivative parameters of the quadratic model. ! IH=0 - DO 170 J=1,N + DO J=1,N W(J)=-HALF*SUMPQ*XOPT(J) - DO 160 K=1,NPT - W(J)=W(J)+PQ(K)*XPT(K,J) - 160 XPT(K,J)=XPT(K,J)-XOPT(J) - DO 170 I=1,J - IH=IH+1 - HQ(IH)=HQ(IH)+W(I)*XOPT(J)+XOPT(I)*W(J) - 170 BMAT(NPT+I,J)=BMAT(NPT+J,I) - DO 180 I=1,N - XBASE(I)=XBASE(I)+XOPT(I) - XNEW(I)=XNEW(I)-XOPT(I) - SL(I)=SL(I)-XOPT(I) - SU(I)=SU(I)-XOPT(I) - 180 XOPT(I)=ZERO + DO K=1,NPT + W(J)=W(J)+PQ(K)*XPT(K,J) + XPT(K,J)=XPT(K,J)-XOPT(J) + END DO + DO I=1,J + IH=IH+1 + HQ(IH)=HQ(IH)+W(I)*XOPT(J)+XOPT(I)*W(J) + BMAT(NPT+I,J)=BMAT(NPT+J,I) + END DO + END DO + DO I=1,N + XBASE(I)=XBASE(I)+XOPT(I) + XNEW(I)=XNEW(I)-XOPT(I) + SL(I)=SL(I)-XOPT(I) + SU(I)=SU(I)-XOPT(I) + XOPT(I)=ZERO + END DO XOPTSQ=ZERO END IF - IF (NTRITS .EQ. 0) GOTO 210 + IF (NTRITS == 0) GOTO 210 GOTO 230 ! ! XBASE is also moved to XOPT by a call of RESCUE. This calculation is @@ -383,22 +401,23 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! leads to a trust region iteration as does the branch to label 60. ! XOPTSQ=ZERO - IF (KOPT .NE. KBASE) THEN - DO 200 I=1,N - XOPT(I)=XPT(KOPT,I) - 200 XOPTSQ=XOPTSQ+XOPT(I)**2 + IF (KOPT /= KBASE) THEN + DO I=1,N + XOPT(I)=XPT(KOPT,I) + XOPTSQ=XOPTSQ+XOPT(I)**2 + END DO END IF - IF (NF .LT. 0) THEN + IF (NF < 0) THEN NF=MAXFUN - IF (IPRINT .GT. 0) PRINT 390 + IF (IPRINT > 0) PRINT 390 GOTO 720 END IF NRESC=NF - IF (NFSAV .LT. NF) THEN + IF (NFSAV < NF) THEN NFSAV=NF GOTO 20 END IF - IF (NTRITS .GT. 0) GOTO 60 + IF (NTRITS > 0) GOTO 60 ! ! Pick two alternative vectors of variables, relative to XBASE, that ! are suitable as new positions of the KNEW-th interpolation point. @@ -413,47 +432,56 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! 210 CALL ALTMOV (N,NPT,XPT,XOPT,BMAT,ZMAT,NDIM,SL,SU,KOPT, 1 KNEW,ADELT,XNEW,XALT,ALPHA,CAUCHY,W,W(NP),W(NDIM+1)) - DO 220 I=1,N - 220 D(I)=XNEW(I)-XOPT(I) + DO I=1,N + D(I)=XNEW(I)-XOPT(I) + END DO ! ! Calculate VLAG and BETA for the current choice of D. The scalar ! product of D with XPT(K,.) is going to be held in W(NPT+K) for ! use when VQUAD is calculated. ! - 230 DO 250 K=1,NPT - SUMA=ZERO - SUMB=ZERO - SUM=ZERO - DO 240 J=1,N - SUMA=SUMA+XPT(K,J)*D(J) - SUMB=SUMB+XPT(K,J)*XOPT(J) - 240 SUM=SUM+BMAT(K,J)*D(J) - W(K)=SUMA*(HALF*SUMA+SUMB) - VLAG(K)=SUM - 250 W(NPT+K)=SUMA + 230 DO K=1,NPT + SUMA=ZERO + SUMB=ZERO + SUM=ZERO + DO J=1,N + SUMA=SUMA+XPT(K,J)*D(J) + SUMB=SUMB+XPT(K,J)*XOPT(J) + SUM=SUM+BMAT(K,J)*D(J) + END DO + W(K)=SUMA*(HALF*SUMA+SUMB) + VLAG(K)=SUM + W(NPT+K)=SUMA + END DO BETA=ZERO - DO 270 JJ=1,NPTM - SUM=ZERO - DO 260 K=1,NPT - 260 SUM=SUM+ZMAT(K,JJ)*W(K) - BETA=BETA-SUM*SUM - DO 270 K=1,NPT - 270 VLAG(K)=VLAG(K)+SUM*ZMAT(K,JJ) + DO JJ=1,NPTM + SUM=ZERO + DO K=1,NPT + SUM=SUM+ZMAT(K,JJ)*W(K) + END DO + BETA=BETA-SUM*SUM + DO K=1,NPT + VLAG(K)=VLAG(K)+SUM*ZMAT(K,JJ) + END DO + END DO DSQ=ZERO BSUM=ZERO DX=ZERO - DO 300 J=1,N + DO J=1,N DSQ=DSQ+D(J)**2 SUM=ZERO - DO 280 K=1,NPT - 280 SUM=SUM+W(K)*BMAT(K,J) + DO K=1,NPT + SUM=SUM+W(K)*BMAT(K,J) + END DO BSUM=BSUM+SUM*D(J) JP=NPT+J - DO 290 I=1,N - 290 SUM=SUM+BMAT(JP,I)*D(I) + DO I=1,N + SUM=SUM+BMAT(JP,I)*D(I) + END DO VLAG(JP)=SUM BSUM=BSUM+SUM*D(J) - 300 DX=DX+D(J)*XOPT(J) + DX=DX+D(J)*XOPT(J) + END DO BETA=DX*DX+DSQ*(XOPTSQ+DX+DX+HALF*DSQ)+BETA-BSUM VLAG(KOPT)=VLAG(KOPT)+ONE ! @@ -461,20 +489,20 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! the step D of ALTMOV by a Cauchy step. Then RESCUE may be called if ! rounding errors have damaged the chosen denominator. ! - IF (NTRITS .EQ. 0) THEN + IF (NTRITS == 0) THEN DENOM=VLAG(KNEW)**2+ALPHA*BETA - IF (DENOM .LT. CAUCHY .AND. CAUCHY .GT. ZERO) THEN - DO 310 I=1,N - XNEW(I)=XALT(I) - 310 D(I)=XNEW(I)-XOPT(I) + IF (DENOM < CAUCHY .AND. CAUCHY > ZERO) THEN + DO I=1,N + XNEW(I)=XALT(I) + D(I)=XNEW(I)-XOPT(I) + END DO CAUCHY=ZERO GO TO 230 END IF - IF (DENOM .LE. HALF*VLAG(KNEW)**2) THEN - IF (NF .GT. NRESC) GOTO 190 - IF (IPRINT .GT. 0) PRINT 320 - 320 FORMAT (/5X,'Return from BOBYQA because of much', - 1 ' cancellation in a denominator.') + IF (DENOM <= HALF*VLAG(KNEW)**2) THEN + IF (NF > NRESC) GOTO 190 + IF (IPRINT > 0) PRINT 320 + 320 FORMAT (/5X,'Return from BOBYQA because of much cancellation in a denominator.') GOTO 720 END IF ! @@ -489,26 +517,28 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, SCADEN=ZERO BIGLSQ=ZERO KNEW=0 - DO 350 K=1,NPT - IF (K .EQ. KOPT) GOTO 350 - HDIAG=ZERO - DO 330 JJ=1,NPTM - 330 HDIAG=HDIAG+ZMAT(K,JJ)**2 - DEN=BETA*HDIAG+VLAG(K)**2 - DISTSQ=ZERO - DO 340 J=1,N - 340 DISTSQ=DISTSQ+(XPT(K,J)-XOPT(J))**2 - TEMP=DMAX1(ONE,(DISTSQ/DELSQ)**2) - IF (TEMP*DEN .GT. SCADEN) THEN - SCADEN=TEMP*DEN - KNEW=K - DENOM=DEN - END IF - BIGLSQ=DMAX1(BIGLSQ,TEMP*VLAG(K)**2) - 350 CONTINUE - IF (SCADEN .LE. HALF*BIGLSQ) THEN - IF (NF .GT. NRESC) GOTO 190 - IF (IPRINT .GT. 0) PRINT 320 + DO K=1,NPT + IF (K == KOPT) CYCLE + HDIAG=ZERO + DO JJ=1,NPTM + HDIAG=HDIAG+ZMAT(K,JJ)**2 + END DO + DEN=BETA*HDIAG+VLAG(K)**2 + DISTSQ=ZERO + DO J=1,N + DISTSQ=DISTSQ+(XPT(K,J)-XOPT(J))**2 + END DO + TEMP=DMAX1(ONE,(DISTSQ/DELSQ)**2) + IF (TEMP*DEN > SCADEN) THEN + SCADEN=TEMP*DEN + KNEW=K + DENOM=DEN + END IF + BIGLSQ=DMAX1(BIGLSQ,TEMP*VLAG(K)**2) + END DO + IF (SCADEN <= HALF*BIGLSQ) THEN + IF (NF > NRESC) GOTO 190 + IF (IPRINT > 0) PRINT 320 GOTO 720 END IF END IF @@ -520,25 +550,24 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! Calculate the value of the objective function at XBASE+XNEW, unless ! the limit on the number of calculations of F has been reached. ! - 360 DO 380 I=1,N - X(I)=DMIN1(DMAX1(XL(I),XBASE(I)+XNEW(I)),XU(I)) - IF (XNEW(I) .EQ. SL(I)) X(I)=XL(I) - IF (XNEW(I) .EQ. SU(I)) X(I)=XU(I) - 380 CONTINUE - IF (NF .GE. MAXFUN) THEN - IF (IPRINT .GT. 0) PRINT 390 - 390 FORMAT (/4X,'Return from BOBYQA because CALFUN has been', - 1 ' called MAXFUN times.') + 360 DO I=1,N + X(I)=DMIN1(DMAX1(XL(I),XBASE(I)+XNEW(I)),XU(I)) + IF (XNEW(I) == SL(I)) X(I)=XL(I) + IF (XNEW(I) == SU(I)) X(I)=XU(I) + END DO + IF (NF >= MAXFUN) THEN + IF (IPRINT > 0) PRINT 390 + 390 FORMAT (/4X,'Return from BOBYQA because CALFUN has been called MAXFUN times.') GOTO 720 END IF NF=NF+1 CALL CALFUN (N,X,F) - IF (IPRINT .EQ. 3) THEN + IF (IPRINT == 3) THEN PRINT 400, NF,F,(X(I),I=1,N) 400 FORMAT (/4X,'Function number',I6,' F =',1PD18.10, 1 ' The corresponding X is:'/(2X,5D15.6)) END IF - IF (NTRITS .EQ. -1) THEN + IF (NTRITS == -1) THEN FSAVE=F GOTO 720 END IF @@ -549,65 +578,71 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, FOPT=FVAL(KOPT) VQUAD=ZERO IH=0 - DO 410 J=1,N - VQUAD=VQUAD+D(J)*GOPT(J) - DO 410 I=1,J - IH=IH+1 - TEMP=D(I)*D(J) - IF (I .EQ. J) TEMP=HALF*TEMP - 410 VQUAD=VQUAD+HQ(IH)*TEMP - DO 420 K=1,NPT - 420 VQUAD=VQUAD+HALF*PQ(K)*W(NPT+K)**2 + DO J=1,N + VQUAD=VQUAD+D(J)*GOPT(J) + DO I=1,J + IH=IH+1 + TEMP=D(I)*D(J) + IF (I == J) TEMP=HALF*TEMP + VQUAD=VQUAD+HQ(IH)*TEMP + END DO + END DO + DO K=1,NPT + VQUAD=VQUAD+HALF*PQ(K)*W(NPT+K)**2 + END DO DIFF=F-FOPT-VQUAD DIFFC=DIFFB DIFFB=DIFFA DIFFA=DABS(DIFF) - IF (DNORM .GT. RHO) NFSAV=NF + IF (DNORM > RHO) NFSAV=NF ! ! Pick the next value of DELTA after a trust region step. ! - IF (NTRITS .GT. 0) THEN - IF (VQUAD .GE. ZERO) THEN - IF (IPRINT .GT. 0) PRINT 430 + IF (NTRITS > 0) THEN + IF (VQUAD >= ZERO) THEN + IF (IPRINT > 0) PRINT 430 430 FORMAT (/4X,'Return from BOBYQA because a trust', 1 ' region step has failed to reduce Q.') GOTO 720 END IF RATIO=(F-FOPT)/VQUAD - IF (RATIO .LE. TENTH) THEN + IF (RATIO <= TENTH) THEN DELTA=DMIN1(HALF*DELTA,DNORM) ELSE IF (RATIO. LE. 0.7D0) THEN DELTA=DMAX1(HALF*DELTA,DNORM) ELSE DELTA=DMAX1(HALF*DELTA,DNORM+DNORM) END IF - IF (DELTA .LE. 1.5D0*RHO) DELTA=RHO + IF (DELTA <= 1.5D0*RHO) DELTA=RHO ! ! Recalculate KNEW and DENOM if the new F is less than FOPT. ! - IF (F .LT. FOPT) THEN + IF (F < FOPT) THEN KSAV=KNEW DENSAV=DENOM DELSQ=DELTA*DELTA SCADEN=ZERO BIGLSQ=ZERO KNEW=0 - DO 460 K=1,NPT - HDIAG=ZERO - DO 440 JJ=1,NPTM - 440 HDIAG=HDIAG+ZMAT(K,JJ)**2 - DEN=BETA*HDIAG+VLAG(K)**2 - DISTSQ=ZERO - DO 450 J=1,N - 450 DISTSQ=DISTSQ+(XPT(K,J)-XNEW(J))**2 - TEMP=DMAX1(ONE,(DISTSQ/DELSQ)**2) - IF (TEMP*DEN .GT. SCADEN) THEN - SCADEN=TEMP*DEN - KNEW=K - DENOM=DEN - END IF - 460 BIGLSQ=DMAX1(BIGLSQ,TEMP*VLAG(K)**2) - IF (SCADEN .LE. HALF*BIGLSQ) THEN + DO K=1,NPT + HDIAG=ZERO + DO JJ=1,NPTM + HDIAG=HDIAG+ZMAT(K,JJ)**2 + END DO + DEN=BETA*HDIAG+VLAG(K)**2 + DISTSQ=ZERO + DO J=1,N + DISTSQ=DISTSQ+(XPT(K,J)-XNEW(J))**2 + END DO + TEMP=DMAX1(ONE,(DISTSQ/DELSQ)**2) + IF (TEMP*DEN > SCADEN) THEN + SCADEN=TEMP*DEN + KNEW=K + DENOM=DEN + END IF + BIGLSQ=DMAX1(BIGLSQ,TEMP*VLAG(K)**2) + END DO + IF (SCADEN <= HALF*BIGLSQ) THEN KNEW=KSAV DENOM=DENSAV END IF @@ -621,102 +656,125 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, IH=0 PQOLD=PQ(KNEW) PQ(KNEW)=ZERO - DO 470 I=1,N - TEMP=PQOLD*XPT(KNEW,I) - DO 470 J=1,I - IH=IH+1 - 470 HQ(IH)=HQ(IH)+TEMP*XPT(KNEW,J) - DO 480 JJ=1,NPTM - TEMP=DIFF*ZMAT(KNEW,JJ) - DO 480 K=1,NPT - 480 PQ(K)=PQ(K)+TEMP*ZMAT(K,JJ) + DO I=1,N + TEMP=PQOLD*XPT(KNEW,I) + DO J=1,I + IH=IH+1 + HQ(IH)=HQ(IH)+TEMP*XPT(KNEW,J) + END DO + END DO + DO JJ=1,NPTM + TEMP=DIFF*ZMAT(KNEW,JJ) + DO K=1,NPT + PQ(K)=PQ(K)+TEMP*ZMAT(K,JJ) + END DO + END DO ! ! Include the new interpolation point, and make the changes to GOPT at ! the old XOPT that are caused by the updating of the quadratic model. ! FVAL(KNEW)=F - DO 490 I=1,N - XPT(KNEW,I)=XNEW(I) - 490 W(I)=BMAT(KNEW,I) - DO 520 K=1,NPT - SUMA=ZERO - DO 500 JJ=1,NPTM - 500 SUMA=SUMA+ZMAT(KNEW,JJ)*ZMAT(K,JJ) - SUMB=ZERO - DO 510 J=1,N - 510 SUMB=SUMB+XPT(K,J)*XOPT(J) - TEMP=SUMA*SUMB - DO 520 I=1,N - 520 W(I)=W(I)+TEMP*XPT(K,I) - DO 530 I=1,N - 530 GOPT(I)=GOPT(I)+DIFF*W(I) + DO I=1,N + XPT(KNEW,I)=XNEW(I) + W(I)=BMAT(KNEW,I) + END DO + DO K=1,NPT + SUMA=ZERO + DO JJ=1,NPTM + SUMA=SUMA+ZMAT(KNEW,JJ)*ZMAT(K,JJ) + END DO + SUMB=ZERO + DO J=1,N + SUMB=SUMB+XPT(K,J)*XOPT(J) + END DO + TEMP=SUMA*SUMB + DO I=1,N + W(I)=W(I)+TEMP*XPT(K,I) + END DO + END DO + DO I=1,N + GOPT(I)=GOPT(I)+DIFF*W(I) + END DO ! ! Update XOPT, GOPT and KOPT if the new calculated F is less than FOPT. ! - IF (F .LT. FOPT) THEN + IF (F < FOPT) THEN KOPT=KNEW XOPTSQ=ZERO IH=0 - DO 540 J=1,N - XOPT(J)=XNEW(J) - XOPTSQ=XOPTSQ+XOPT(J)**2 - DO 540 I=1,J - IH=IH+1 - IF (I .LT. J) GOPT(J)=GOPT(J)+HQ(IH)*D(I) - 540 GOPT(I)=GOPT(I)+HQ(IH)*D(J) - DO 560 K=1,NPT - TEMP=ZERO - DO 550 J=1,N - 550 TEMP=TEMP+XPT(K,J)*D(J) - TEMP=PQ(K)*TEMP - DO 560 I=1,N - 560 GOPT(I)=GOPT(I)+TEMP*XPT(K,I) + DO J=1,N + XOPT(J)=XNEW(J) + XOPTSQ=XOPTSQ+XOPT(J)**2 + DO I=1,J + IH=IH+1 + IF (I < J) GOPT(J)=GOPT(J)+HQ(IH)*D(I) + GOPT(I)=GOPT(I)+HQ(IH)*D(J) + END DO + END DO + DO K=1,NPT + TEMP=ZERO + DO J=1,N + TEMP=TEMP+XPT(K,J)*D(J) + END DO + TEMP=PQ(K)*TEMP + DO I=1,N + GOPT(I)=GOPT(I)+TEMP*XPT(K,I) + END DO + END DO END IF ! ! Calculate the parameters of the least Frobenius norm interpolant to ! the current data, the gradient of this interpolant at XOPT being put ! into VLAG(NPT+I), I=1,2,...,N. ! - IF (NTRITS .GT. 0) THEN - DO 570 K=1,NPT - VLAG(K)=FVAL(K)-FVAL(KOPT) - 570 W(K)=ZERO - DO 590 J=1,NPTM - SUM=ZERO - DO 580 K=1,NPT - 580 SUM=SUM+ZMAT(K,J)*VLAG(K) - DO 590 K=1,NPT - 590 W(K)=W(K)+SUM*ZMAT(K,J) - DO 610 K=1,NPT - SUM=ZERO - DO 600 J=1,N - 600 SUM=SUM+XPT(K,J)*XOPT(J) - W(K+NPT)=W(K) - 610 W(K)=SUM*W(K) + IF (NTRITS > 0) THEN + DO K=1,NPT + VLAG(K)=FVAL(K)-FVAL(KOPT) + W(K)=ZERO + END DO + DO J=1,NPTM + SUM=ZERO + DO K=1,NPT + SUM=SUM+ZMAT(K,J)*VLAG(K) + END DO + END DO + DO K=1,NPT + W(K)=W(K)+SUM*ZMAT(K,J) + END DO + DO K=1,NPT + SUM=ZERO + DO J=1,N + SUM=SUM+XPT(K,J)*XOPT(J) + END DO + W(K+NPT)=W(K) + W(K)=SUM*W(K) + END DO GQSQ=ZERO GISQ=ZERO - DO 630 I=1,N - SUM=ZERO - DO 620 K=1,NPT - 620 SUM=SUM+BMAT(K,I)*VLAG(K)+XPT(K,I)*W(K) - IF (XOPT(I) .EQ. SL(I)) THEN - GQSQ=GQSQ+DMIN1(ZERO,GOPT(I))**2 - GISQ=GISQ+DMIN1(ZERO,SUM)**2 - ELSE IF (XOPT(I) .EQ. SU(I)) THEN - GQSQ=GQSQ+DMAX1(ZERO,GOPT(I))**2 - GISQ=GISQ+DMAX1(ZERO,SUM)**2 - ELSE - GQSQ=GQSQ+GOPT(I)**2 - GISQ=GISQ+SUM*SUM - END IF - 630 VLAG(NPT+I)=SUM + DO I=1,N + SUM=ZERO + DO K=1,NPT + SUM=SUM+BMAT(K,I)*VLAG(K)+XPT(K,I)*W(K) + END DO + IF (XOPT(I) == SL(I)) THEN + GQSQ=GQSQ+DMIN1(ZERO,GOPT(I))**2 + GISQ=GISQ+DMIN1(ZERO,SUM)**2 + ELSE IF (XOPT(I) == SU(I)) THEN + GQSQ=GQSQ+DMAX1(ZERO,GOPT(I))**2 + GISQ=GISQ+DMAX1(ZERO,SUM)**2 + ELSE + GQSQ=GQSQ+GOPT(I)**2 + GISQ=GISQ+SUM*SUM + END IF + VLAG(NPT+I)=SUM + END DO ! ! Test whether to replace the new quadratic model by the least Frobenius ! norm interpolant, making the replacement if the test is satisfied. ! ITEST=ITEST+1 - IF (GQSQ .LT. TEN*GISQ) ITEST=0 - do_replace = (ITEST .GE. 3) + IF (GQSQ < TEN*GISQ) ITEST=0 + do_replace = (ITEST >= 3) if (.not. do_replace) then ! check for "invalid" value do k=1,npt if (fval(k) > max_valid_value) then @@ -728,12 +786,12 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, end if IF (do_replace) THEN !stop 'bobyqa: do_replace' - DO 640 I=1,MAX0(NPT,NH) - IF (I .LE. N) GOPT(I)=VLAG(NPT+I) - IF (I .LE. NPT) PQ(I)=W(NPT+I) - IF (I .LE. NH) HQ(I)=ZERO - ITEST=0 - 640 CONTINUE + DO I=1,MAX0(NPT,NH) + IF (I <= N) GOPT(I)=VLAG(NPT+I) + IF (I <= NPT) PQ(I)=W(NPT+I) + IF (I <= NH) HQ(I)=ZERO + ITEST=0 + END DO END IF END IF ! @@ -741,23 +799,24 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! branch for another trust region calculation. The case NTRITS=0 occurs ! when the new interpolation point was reached by an alternative step. ! - IF (NTRITS .EQ. 0) GOTO 60 - IF (F .LE. FOPT+TENTH*VQUAD) GOTO 60 + IF (NTRITS == 0) GOTO 60 + IF (F <= FOPT+TENTH*VQUAD) GOTO 60 ! ! Alternatively, find out if the interpolation points are close enough ! to the best point so far. ! DISTSQ=DMAX1((TWO*DELTA)**2,(TEN*RHO)**2) 650 KNEW=0 - DO 670 K=1,NPT - SUM=ZERO - DO 660 J=1,N - 660 SUM=SUM+(XPT(K,J)-XOPT(J))**2 - IF (SUM .GT. DISTSQ) THEN - KNEW=K - DISTSQ=SUM - END IF - 670 CONTINUE + DO K=1,NPT + SUM=ZERO + DO J=1,N + SUM=SUM+(XPT(K,J)-XOPT(J))**2 + END DO + IF (SUM > DISTSQ) THEN + KNEW=K + DISTSQ=SUM + END IF + END DO ! ! If KNEW is positive, then ALTMOV finds alternative new positions for ! the KNEW-th interpolation point within distance ADELT of XOPT. It is @@ -765,37 +824,37 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! another trust region iteration, unless the calculations with the ! current RHO are complete. ! - IF (KNEW .GT. 0) THEN + IF (KNEW > 0) THEN DIST=DSQRT(DISTSQ) - IF (NTRITS .EQ. -1) THEN + IF (NTRITS == -1) THEN DELTA=DMIN1(TENTH*DELTA,HALF*DIST) - IF (DELTA .LE. 1.5D0*RHO) DELTA=RHO + IF (DELTA <= 1.5D0*RHO) DELTA=RHO END IF NTRITS=0 ADELT=DMAX1(DMIN1(TENTH*DIST,DELTA),RHO) DSQ=ADELT*ADELT GOTO 90 END IF - IF (NTRITS .EQ. -1) GOTO 680 - IF (RATIO .GT. ZERO) GOTO 60 - IF (DMAX1(DELTA,DNORM) .GT. RHO) GOTO 60 + IF (NTRITS == -1) GOTO 680 + IF (RATIO > ZERO) GOTO 60 + IF (DMAX1(DELTA,DNORM) > RHO) GOTO 60 ! ! The calculations with the current value of RHO are complete. Pick the ! next values of RHO and DELTA. ! - 680 IF (RHO .GT. RHOEND) THEN + 680 IF (RHO > RHOEND) THEN DELTA=HALF*RHO RATIO=RHO/RHOEND - IF (RATIO .LE. 16.0D0) THEN + IF (RATIO <= 16.0D0) THEN RHO=RHOEND - ELSE IF (RATIO .LE. 250.0D0) THEN + ELSE IF (RATIO <= 250.0D0) THEN RHO=DSQRT(RATIO)*RHOEND ELSE RHO=TENTH*RHO END IF DELTA=DMAX1(DELTA,RHO) - IF (IPRINT .GE. 2) THEN - IF (IPRINT .GE. 3) PRINT 690 + IF (IPRINT >= 2) THEN + IF (IPRINT >= 3) PRINT 690 690 FORMAT (5X) PRINT 700, RHO,NF 700 FORMAT (/4X,'New RHO =',1PD11.4,5X,'Number of', @@ -812,19 +871,18 @@ SUBROUTINE BOBYQB (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT, ! Return from the calculation, after another Newton-Raphson step, if ! it is too short to have been tried before. ! - IF (NTRITS .EQ. -1) GOTO 360 - 720 IF (FVAL(KOPT) .LE. FSAVE) THEN - DO 730 I=1,N - X(I)=DMIN1(DMAX1(XL(I),XBASE(I)+XOPT(I)),XU(I)) - IF (XOPT(I) .EQ. SL(I)) X(I)=XL(I) - IF (XOPT(I) .EQ. SU(I)) X(I)=XU(I) - 730 CONTINUE + IF (NTRITS == -1) GOTO 360 + 720 IF (FVAL(KOPT) <= FSAVE) THEN + DO I=1,N + X(I)=DMIN1(DMAX1(XL(I),XBASE(I)+XOPT(I)),XU(I)) + IF (XOPT(I) == SL(I)) X(I)=XL(I) + IF (XOPT(I) == SU(I)) X(I)=XU(I) + END DO F=FVAL(KOPT) END IF - IF (IPRINT .GE. 1) THEN + IF (IPRINT >= 1) THEN PRINT 740, NF - 740 FORMAT (/4X,'At the return from BOBYQA',5X, - 1 'Number of function values =',I6) + 740 FORMAT (/4X,'At the return from BOBYQA',5X,'Number of function values =',I6) PRINT 710, F,(X(I),I=1,N) END IF RETURN @@ -872,26 +930,33 @@ SUBROUTINE ALTMOV (N,NPT,XPT,XOPT,BMAT,ZMAT,NDIM,SL,SU,KOPT, ONE=1.0D0 ZERO=0.0D0 CONST=ONE+DSQRT(2.0D0) - DO 10 K=1,NPT - 10 HCOL(K)=ZERO - DO 20 J=1,NPT-N-1 - TEMP=ZMAT(KNEW,J) - DO 20 K=1,NPT - 20 HCOL(K)=HCOL(K)+TEMP*ZMAT(K,J) + DO K=1,NPT + HCOL(K)=ZERO + END DO + DO J=1,NPT-N-1 + TEMP=ZMAT(KNEW,J) + DO K=1,NPT + HCOL(K)=HCOL(K)+TEMP*ZMAT(K,J) + END DO + END DO ALPHA=HCOL(KNEW) HA=HALF*ALPHA ! ! Calculate the gradient of the KNEW-th Lagrange function at XOPT. ! - DO 30 I=1,N - 30 GLAG(I)=BMAT(KNEW,I) - DO 50 K=1,NPT - TEMP=ZERO - DO 40 J=1,N - 40 TEMP=TEMP+XPT(K,J)*XOPT(J) - TEMP=HCOL(K)*TEMP - DO 50 I=1,N - 50 GLAG(I)=GLAG(I)+TEMP*XPT(K,I) + DO I=1,N + GLAG(I)=BMAT(KNEW,I) + END DO + DO K=1,NPT + TEMP=ZERO + DO J=1,N + TEMP=TEMP+XPT(K,J)*XOPT(J) + END DO + TEMP=HCOL(K)*TEMP + DO I=1,N + GLAG(I)=GLAG(I)+TEMP*XPT(K,I) + END DO + END DO ! ! Search for a large denominator along the straight lines through XOPT ! and another interpolation point. SLBD and SUBD will be lower and upper @@ -900,112 +965,114 @@ SUBROUTINE ALTMOV (N,NPT,XPT,XOPT,BMAT,ZMAT,NDIM,SL,SU,KOPT, ! will be set to the largest admissible value of PREDSQ that occurs. ! PRESAV=ZERO - DO 80 K=1,NPT - IF (K .EQ. KOPT) GOTO 80 - DDERIV=ZERO - DISTSQ=ZERO - DO 60 I=1,N - TEMP=XPT(K,I)-XOPT(I) - DDERIV=DDERIV+GLAG(I)*TEMP - 60 DISTSQ=DISTSQ+TEMP*TEMP - SUBD=ADELT/DSQRT(DISTSQ) - SLBD=-SUBD - ILBD=0 - IUBD=0 - SUMIN=DMIN1(ONE,SUBD) + DO K=1,NPT + IF (K == KOPT) CYCLE + DDERIV=ZERO + DISTSQ=ZERO + DO I=1,N + TEMP=XPT(K,I)-XOPT(I) + DDERIV=DDERIV+GLAG(I)*TEMP + DISTSQ=DISTSQ+TEMP*TEMP + END DO + SUBD=ADELT/DSQRT(DISTSQ) + SLBD=-SUBD + ILBD=0 + IUBD=0 + SUMIN=DMIN1(ONE,SUBD) ! ! Revise SLBD and SUBD if necessary because of the bounds in SL and SU. ! - DO 70 I=1,N - TEMP=XPT(K,I)-XOPT(I) - IF (TEMP .GT. ZERO) THEN - IF (SLBD*TEMP .LT. SL(I)-XOPT(I)) THEN - SLBD=(SL(I)-XOPT(I))/TEMP - ILBD=-I - END IF - IF (SUBD*TEMP .GT. SU(I)-XOPT(I)) THEN - SUBD=DMAX1(SUMIN,(SU(I)-XOPT(I))/TEMP) - IUBD=I - END IF - ELSE IF (TEMP .LT. ZERO) THEN - IF (SLBD*TEMP .GT. SU(I)-XOPT(I)) THEN - SLBD=(SU(I)-XOPT(I))/TEMP - ILBD=I - END IF - IF (SUBD*TEMP .LT. SL(I)-XOPT(I)) THEN - SUBD=DMAX1(SUMIN,(SL(I)-XOPT(I))/TEMP) - IUBD=-I - END IF - END IF - 70 CONTINUE + DO I=1,N + TEMP=XPT(K,I)-XOPT(I) + IF (TEMP > ZERO) THEN + IF (SLBD*TEMP < SL(I)-XOPT(I)) THEN + SLBD=(SL(I)-XOPT(I))/TEMP + ILBD=-I + END IF + IF (SUBD*TEMP > SU(I)-XOPT(I)) THEN + SUBD=DMAX1(SUMIN,(SU(I)-XOPT(I))/TEMP) + IUBD=I + END IF + ELSE IF (TEMP < ZERO) THEN + IF (SLBD*TEMP > SU(I)-XOPT(I)) THEN + SLBD=(SU(I)-XOPT(I))/TEMP + ILBD=I + END IF + IF (SUBD*TEMP < SL(I)-XOPT(I)) THEN + SUBD=DMAX1(SUMIN,(SL(I)-XOPT(I))/TEMP) + IUBD=-I + END IF + END IF + END DO ! ! Seek a large modulus of the KNEW-th Lagrange function when the index ! of the other interpolation point on the line through XOPT is KNEW. ! - IF (K .EQ. KNEW) THEN - DIFF=DDERIV-ONE - STEP=SLBD - VLAG=SLBD*(DDERIV-SLBD*DIFF) - ISBD=ILBD - TEMP=SUBD*(DDERIV-SUBD*DIFF) - IF (DABS(TEMP) .GT. DABS(VLAG)) THEN - STEP=SUBD - VLAG=TEMP - ISBD=IUBD - END IF - TEMPD=HALF*DDERIV - TEMPA=TEMPD-DIFF*SLBD - TEMPB=TEMPD-DIFF*SUBD - IF (TEMPA*TEMPB .LT. ZERO) THEN - TEMP=TEMPD*TEMPD/DIFF - IF (DABS(TEMP) .GT. DABS(VLAG)) THEN - STEP=TEMPD/DIFF - VLAG=TEMP - ISBD=0 - END IF - END IF + IF (K == KNEW) THEN + DIFF=DDERIV-ONE + STEP=SLBD + VLAG=SLBD*(DDERIV-SLBD*DIFF) + ISBD=ILBD + TEMP=SUBD*(DDERIV-SUBD*DIFF) + IF (DABS(TEMP) > DABS(VLAG)) THEN + STEP=SUBD + VLAG=TEMP + ISBD=IUBD + END IF + TEMPD=HALF*DDERIV + TEMPA=TEMPD-DIFF*SLBD + TEMPB=TEMPD-DIFF*SUBD + IF (TEMPA*TEMPB < ZERO) THEN + TEMP=TEMPD*TEMPD/DIFF + IF (DABS(TEMP) > DABS(VLAG)) THEN + STEP=TEMPD/DIFF + VLAG=TEMP + ISBD=0 + END IF + END IF ! ! Search along each of the other lines through XOPT and another point. ! - ELSE - STEP=SLBD - VLAG=SLBD*(ONE-SLBD) - ISBD=ILBD - TEMP=SUBD*(ONE-SUBD) - IF (DABS(TEMP) .GT. DABS(VLAG)) THEN - STEP=SUBD - VLAG=TEMP - ISBD=IUBD - END IF - IF (SUBD .GT. HALF) THEN - IF (DABS(VLAG) .LT. 0.25D0) THEN - STEP=HALF - VLAG=0.25D0 - ISBD=0 - END IF - END IF - VLAG=VLAG*DDERIV - END IF + ELSE + STEP=SLBD + VLAG=SLBD*(ONE-SLBD) + ISBD=ILBD + TEMP=SUBD*(ONE-SUBD) + IF (DABS(TEMP) > DABS(VLAG)) THEN + STEP=SUBD + VLAG=TEMP + ISBD=IUBD + END IF + IF (SUBD > HALF) THEN + IF (DABS(VLAG) < 0.25D0) THEN + STEP=HALF + VLAG=0.25D0 + ISBD=0 + END IF + END IF + VLAG=VLAG*DDERIV + END IF ! ! Calculate PREDSQ for the current line search and maintain PRESAV. ! - TEMP=STEP*(ONE-STEP)*DISTSQ - PREDSQ=VLAG*VLAG*(VLAG*VLAG+HA*TEMP*TEMP) - IF (PREDSQ .GT. PRESAV) THEN - PRESAV=PREDSQ - KSAV=K - STPSAV=STEP - IBDSAV=ISBD - END IF - 80 CONTINUE + TEMP=STEP*(ONE-STEP)*DISTSQ + PREDSQ=VLAG*VLAG*(VLAG*VLAG+HA*TEMP*TEMP) + IF (PREDSQ > PRESAV) THEN + PRESAV=PREDSQ + KSAV=K + STPSAV=STEP + IBDSAV=ISBD + END IF + END DO ! ! Construct XNEW in a way that satisfies the bound constraints exactly. ! - DO 90 I=1,N - TEMP=XOPT(I)+STPSAV*(XPT(KSAV,I)-XOPT(I)) - 90 XNEW(I)=DMAX1(SL(I),DMIN1(SU(I),TEMP)) - IF (IBDSAV .LT. 0) XNEW(-IBDSAV)=SL(-IBDSAV) - IF (IBDSAV .GT. 0) XNEW(IBDSAV)=SU(IBDSAV) + DO I=1,N + TEMP=XOPT(I)+STPSAV*(XPT(KSAV,I)-XOPT(I)) + XNEW(I)=DMAX1(SL(I),DMIN1(SU(I),TEMP)) + END DO + IF (IBDSAV < 0) XNEW(-IBDSAV)=SL(-IBDSAV) + IF (IBDSAV > 0) XNEW(IBDSAV)=SU(IBDSAV) ! ! Prepare for the iterative method that assembles the constrained Cauchy ! step in W. The sum of squares of the fixed components of W is formed in @@ -1015,16 +1082,16 @@ SUBROUTINE ALTMOV (N,NPT,XPT,XOPT,BMAT,ZMAT,NDIM,SL,SU,KOPT, IFLAG=0 100 WFIXSQ=ZERO GGFREE=ZERO - DO 110 I=1,N - W(I)=ZERO - TEMPA=DMIN1(XOPT(I)-SL(I),GLAG(I)) - TEMPB=DMAX1(XOPT(I)-SU(I),GLAG(I)) - IF (TEMPA .GT. ZERO .OR. TEMPB .LT. ZERO) THEN - W(I)=BIGSTP - GGFREE=GGFREE+GLAG(I)**2 - END IF - 110 CONTINUE - IF (GGFREE .EQ. ZERO) THEN + DO I=1,N + W(I)=ZERO + TEMPA=DMIN1(XOPT(I)-SL(I),GLAG(I)) + TEMPB=DMAX1(XOPT(I)-SU(I),GLAG(I)) + IF (TEMPA > ZERO .OR. TEMPB < ZERO) THEN + W(I)=BIGSTP + GGFREE=GGFREE+GLAG(I)**2 + END IF + END DO + IF (GGFREE == ZERO) THEN CAUCHY=ZERO GOTO 200 END IF @@ -1032,43 +1099,44 @@ SUBROUTINE ALTMOV (N,NPT,XPT,XOPT,BMAT,ZMAT,NDIM,SL,SU,KOPT, ! Investigate whether more components of W can be fixed. ! 120 TEMP=ADELT*ADELT-WFIXSQ - IF (TEMP .GT. ZERO) THEN + IF (TEMP > ZERO) THEN WSQSAV=WFIXSQ STEP=DSQRT(TEMP/GGFREE) GGFREE=ZERO - DO 130 I=1,N - IF (W(I) .EQ. BIGSTP) THEN - TEMP=XOPT(I)-STEP*GLAG(I) - IF (TEMP .LE. SL(I)) THEN - W(I)=SL(I)-XOPT(I) - WFIXSQ=WFIXSQ+W(I)**2 - ELSE IF (TEMP .GE. SU(I)) THEN - W(I)=SU(I)-XOPT(I) - WFIXSQ=WFIXSQ+W(I)**2 - ELSE - GGFREE=GGFREE+GLAG(I)**2 - END IF - END IF - 130 CONTINUE - IF (WFIXSQ .GT. WSQSAV .AND. GGFREE .GT. ZERO) GOTO 120 + DO I=1,N + IF (W(I) == BIGSTP) THEN + TEMP=XOPT(I)-STEP*GLAG(I) + IF (TEMP <= SL(I)) THEN + W(I)=SL(I)-XOPT(I) + WFIXSQ=WFIXSQ+W(I)**2 + ELSE IF (TEMP >= SU(I)) THEN + W(I)=SU(I)-XOPT(I) + WFIXSQ=WFIXSQ+W(I)**2 + ELSE + GGFREE=GGFREE+GLAG(I)**2 + END IF + END IF + END DO + IF (WFIXSQ > WSQSAV .AND. GGFREE > ZERO) GOTO 120 END IF ! ! Set the remaining free components of W and all components of XALT, ! except that W may be scaled later. ! GW=ZERO - DO 140 I=1,N - IF (W(I) .EQ. BIGSTP) THEN - W(I)=-STEP*GLAG(I) - XALT(I)=DMAX1(SL(I),DMIN1(SU(I),XOPT(I)+W(I))) - ELSE IF (W(I) .EQ. ZERO) THEN - XALT(I)=XOPT(I) - ELSE IF (GLAG(I) .GT. ZERO) THEN - XALT(I)=SL(I) - ELSE - XALT(I)=SU(I) - END IF - 140 GW=GW+GLAG(I)*W(I) + DO I=1,N + IF (W(I) == BIGSTP) THEN + W(I)=-STEP*GLAG(I) + XALT(I)=DMAX1(SL(I),DMIN1(SU(I),XOPT(I)+W(I))) + ELSE IF (W(I) == ZERO) THEN + XALT(I)=XOPT(I) + ELSE IF (GLAG(I) > ZERO) THEN + XALT(I)=SL(I) + ELSE + XALT(I)=SU(I) + END IF + GW=GW+GLAG(I)*W(I) + END DO ! ! Set CURV to the curvature of the KNEW-th Lagrange function along W. ! Scale W by a factor less than one if that can reduce the modulus of @@ -1076,17 +1144,20 @@ SUBROUTINE ALTMOV (N,NPT,XPT,XOPT,BMAT,ZMAT,NDIM,SL,SU,KOPT, ! the square of this function. ! CURV=ZERO - DO 160 K=1,NPT - TEMP=ZERO - DO 150 J=1,N - 150 TEMP=TEMP+XPT(K,J)*W(J) - 160 CURV=CURV+HCOL(K)*TEMP*TEMP - IF (IFLAG .EQ. 1) CURV=-CURV - IF (CURV .GT. -GW .AND. CURV .LT. -CONST*GW) THEN + DO K=1,NPT + TEMP=ZERO + DO J=1,N + TEMP=TEMP+XPT(K,J)*W(J) + END DO + CURV=CURV+HCOL(K)*TEMP*TEMP + END DO + IF (IFLAG == 1) CURV=-CURV + IF (CURV > -GW .AND. CURV < -CONST*GW) THEN SCALE=-GW/CURV - DO 170 I=1,N - TEMP=XOPT(I)+SCALE*W(I) - 170 XALT(I)=DMAX1(SL(I),DMIN1(SU(I),TEMP)) + DO I=1,N + TEMP=XOPT(I)+SCALE*W(I) + XALT(I)=DMAX1(SL(I),DMIN1(SU(I),TEMP)) + END DO CAUCHY=(HALF*GW*SCALE)**2 ELSE CAUCHY=(GW+HALF*CURV)**2 @@ -1096,17 +1167,19 @@ SUBROUTINE ALTMOV (N,NPT,XPT,XOPT,BMAT,ZMAT,NDIM,SL,SU,KOPT, ! the sign of GLAG. Thus two XALT vectors become available. The one that ! is chosen is the one that gives the larger value of CAUCHY. ! - IF (IFLAG .EQ. 0) THEN - DO 180 I=1,N - GLAG(I)=-GLAG(I) - 180 W(N+I)=XALT(I) + IF (IFLAG == 0) THEN + DO I=1,N + GLAG(I)=-GLAG(I) + W(N+I)=XALT(I) + END DO CSAVE=CAUCHY IFLAG=1 GOTO 100 END IF - IF (CSAVE .GT. CAUCHY) THEN - DO 190 I=1,N - 190 XALT(I)=W(N+I) + IF (CSAVE > CAUCHY) THEN + DO I=1,N + XALT(I)=W(N+I) + END DO CAUCHY=CSAVE END IF 200 RETURN @@ -1151,18 +1224,24 @@ SUBROUTINE PRELIM (N,NPT,X,XL,XU,RHOBEG,IPRINT,MAXFUN,XBASE, ! Set XBASE to the initial vector of variables, and set the initial ! elements of XPT, BMAT, HQ, PQ and ZMAT to zero. ! - DO 20 J=1,N - XBASE(J)=X(J) - DO 10 K=1,NPT - 10 XPT(K,J)=ZERO - DO 20 I=1,NDIM - 20 BMAT(I,J)=ZERO - DO 30 IH=1,(N*NP)/2 - 30 HQ(IH)=ZERO - DO 40 K=1,NPT - PQ(K)=ZERO - DO 40 J=1,NPT-NP - 40 ZMAT(K,J)=ZERO + DO J=1,N + XBASE(J)=X(J) + DO K=1,NPT + XPT(K,J)=ZERO + END DO + DO I=1,NDIM + BMAT(I,J)=ZERO + END DO + END DO + DO IH=1,(N*NP)/2 + HQ(IH)=ZERO + END DO + DO K=1,NPT + PQ(K)=ZERO + DO J=1,NPT-NP + ZMAT(K,J)=ZERO + END DO + END DO ! ! Begin the initialization procedure. NF becomes one more than the number ! of function values so far. The coordinates of the displacement of the @@ -1172,23 +1251,23 @@ SUBROUTINE PRELIM (N,NPT,X,XL,XU,RHOBEG,IPRINT,MAXFUN,XBASE, 50 NFM=NF NFX=NF-N NF=NF+1 - IF (NFM .LE. 2*N) THEN - IF (NFM .GE. 1 .AND. NFM .LE. N) THEN + IF (NFM <= 2*N) THEN + IF (NFM >= 1 .AND. NFM <= N) THEN STEPA=RHOBEG - IF (SU(NFM) .EQ. ZERO) STEPA=-STEPA + IF (SU(NFM) == ZERO) STEPA=-STEPA XPT(NF,NFM)=STEPA - ELSE IF (NFM .GT. N) THEN + ELSE IF (NFM > N) THEN STEPA=XPT(NF-N,NFX) STEPB=-RHOBEG - IF (SL(NFX) .EQ. ZERO) STEPB=DMIN1(TWO*RHOBEG,SU(NFX)) - IF (SU(NFX) .EQ. ZERO) STEPB=DMAX1(-TWO*RHOBEG,SL(NFX)) + IF (SL(NFX) == ZERO) STEPB=DMIN1(TWO*RHOBEG,SU(NFX)) + IF (SU(NFX) == ZERO) STEPB=DMAX1(-TWO*RHOBEG,SL(NFX)) XPT(NF,NFX)=STEPB END IF ELSE ITEMP=(NFM-NP)/N JPT=NFM-ITEMP*N-N IPT=JPT+ITEMP - IF (IPT .GT. N) THEN + IF (IPT > N) THEN ITEMP=JPT JPT=IPT-N IPT=ITEMP @@ -1200,23 +1279,22 @@ SUBROUTINE PRELIM (N,NPT,X,XL,XU,RHOBEG,IPRINT,MAXFUN,XBASE, ! Calculate the next value of F. The least function value so far and ! its index are required. ! - DO 60 J=1,N - X(J)=DMIN1(DMAX1(XL(J),XBASE(J)+XPT(NF,J)),XU(J)) - IF (XPT(NF,J) .EQ. SL(J)) X(J)=XL(J) - IF (XPT(NF,J) .EQ. SU(J)) X(J)=XU(J) - 60 CONTINUE + DO J=1,N + X(J)=DMIN1(DMAX1(XL(J),XBASE(J)+XPT(NF,J)),XU(J)) + IF (XPT(NF,J) == SL(J)) X(J)=XL(J) + IF (XPT(NF,J) == SU(J)) X(J)=XU(J) + END DO CALL CALFUN (N,X,F) - IF (IPRINT .EQ. 3) THEN - PRINT 70, NF,F,(X(I),I=1,N) - 70 FORMAT (/4X,'Function number',I6,' F =',1PD18.10, - 1 ' The corresponding X is:'/(2X,5D15.6)) + IF (IPRINT == 3) THEN + PRINT 70, NF,F,(X(I),I=1,N) + 70 FORMAT (/4X,'Function number',I6,' F =',1PD18.10,' The corresponding X is:'/(2X,5D15.6)) END IF FVAL(NF)=F - IF (NF .EQ. 1) THEN - FBEG=F - KOPT=1 - ELSE IF (F .LT. FVAL(KOPT)) THEN - KOPT=NF + IF (NF == 1) THEN + FBEG=F + KOPT=1 + ELSE IF (F < FVAL(KOPT)) THEN + KOPT=NF END IF ! ! Set the nonzero initial elements of BMAT and the quadratic model in the @@ -1225,25 +1303,25 @@ SUBROUTINE PRELIM (N,NPT,X,XL,XU,RHOBEG,IPRINT,MAXFUN,XBASE, ! order that the function value at the first of them contributes to the ! off-diagonal second derivative terms of the initial quadratic model. ! - IF (NF .LE. 2*N+1) THEN - IF (NF .GE. 2 .AND. NF .LE. N+1) THEN + IF (NF <= 2*N+1) THEN + IF (NF >= 2 .AND. NF <= N+1) THEN GOPT(NFM)=(F-FBEG)/STEPA - IF (NPT .LT. NF+N) THEN + IF (NPT < NF+N) THEN BMAT(1,NFM)=-ONE/STEPA BMAT(NF,NFM)=ONE/STEPA BMAT(NPT+NFM,NFM)=-HALF*RHOSQ END IF - ELSE IF (NF .GE. N+2) THEN + ELSE IF (NF >= N+2) THEN IH=(NFX*(NFX+1))/2 TEMP=(F-FBEG)/STEPB DIFF=STEPB-STEPA HQ(IH)=TWO*(TEMP-GOPT(NFX))/DIFF GOPT(NFX)=(GOPT(NFX)*STEPB-TEMP*STEPA)/DIFF - IF (STEPA*STEPB .LT. ZERO) THEN - IF (F .LT. FVAL(NF-N)) THEN + IF (STEPA*STEPB < ZERO) THEN + IF (F < FVAL(NF-N)) THEN FVAL(NF)=FVAL(NF-N) FVAL(NF-N)=F - IF (KOPT .EQ. NF) KOPT=NF-N + IF (KOPT == NF) KOPT=NF-N XPT(NF-N,NFX)=STEPB XPT(NF,NFX)=STEPA END IF @@ -1268,7 +1346,7 @@ SUBROUTINE PRELIM (N,NPT,X,XL,XU,RHOBEG,IPRINT,MAXFUN,XBASE, TEMP=XPT(NF,IPT)*XPT(NF,JPT) HQ(IH)=(FBEG-FVAL(IPT+1)-FVAL(JPT+1)+F)/TEMP END IF - IF (NF .LT. NPT .AND. NF .LT. MAXFUN) GOTO 50 + IF (NF < NPT .AND. NF < MAXFUN) GOTO 50 RETURN END SUBROUTINE PRELIM @@ -1337,49 +1415,57 @@ SUBROUTINE RESCUE (N,NPT,XL,XU,IPRINT,MAXFUN,XBASE,XPT, ! SUMPQ=ZERO WINC=ZERO - DO 20 K=1,NPT - DISTSQ=ZERO - DO 10 J=1,N - XPT(K,J)=XPT(K,J)-XOPT(J) - 10 DISTSQ=DISTSQ+XPT(K,J)**2 - SUMPQ=SUMPQ+PQ(K) - W(NDIM+K)=DISTSQ - WINC=DMAX1(WINC,DISTSQ) - DO 20 J=1,NPTM - 20 ZMAT(K,J)=ZERO + DO K=1,NPT + DISTSQ=ZERO + DO J=1,N + XPT(K,J)=XPT(K,J)-XOPT(J) + DISTSQ=DISTSQ+XPT(K,J)**2 + END DO + SUMPQ=SUMPQ+PQ(K) + W(NDIM+K)=DISTSQ + WINC=DMAX1(WINC,DISTSQ) + DO J=1,NPTM + ZMAT(K,J)=ZERO + END DO + END DO ! ! Update HQ so that HQ and PQ define the second derivatives of the model ! after XBASE has been shifted to the trust region centre. ! IH=0 - DO 40 J=1,N - W(J)=HALF*SUMPQ*XOPT(J) - DO 30 K=1,NPT - 30 W(J)=W(J)+PQ(K)*XPT(K,J) - DO 40 I=1,J - IH=IH+1 - 40 HQ(IH)=HQ(IH)+W(I)*XOPT(J)+W(J)*XOPT(I) + DO J=1,N + W(J)=HALF*SUMPQ*XOPT(J) + DO K=1,NPT + W(J)=W(J)+PQ(K)*XPT(K,J) + END DO + DO I=1,J + IH=IH+1 + HQ(IH)=HQ(IH)+W(I)*XOPT(J)+W(J)*XOPT(I) + END DO + END DO ! ! Shift XBASE, SL, SU and XOPT. Set the elements of BMAT to zero, and ! also set the elements of PTSAUX. ! - DO 50 J=1,N - XBASE(J)=XBASE(J)+XOPT(J) - SL(J)=SL(J)-XOPT(J) - SU(J)=SU(J)-XOPT(J) - XOPT(J)=ZERO - PTSAUX(1,J)=DMIN1(DELTA,SU(J)) - PTSAUX(2,J)=DMAX1(-DELTA,SL(J)) - IF (PTSAUX(1,J)+PTSAUX(2,J) .LT. ZERO) THEN - TEMP=PTSAUX(1,J) - PTSAUX(1,J)=PTSAUX(2,J) - PTSAUX(2,J)=TEMP - END IF - IF (DABS(PTSAUX(2,J)) .LT. HALF*DABS(PTSAUX(1,J))) THEN - PTSAUX(2,J)=HALF*PTSAUX(1,J) - END IF - DO 50 I=1,NDIM - 50 BMAT(I,J)=ZERO + DO J=1,N + XBASE(J)=XBASE(J)+XOPT(J) + SL(J)=SL(J)-XOPT(J) + SU(J)=SU(J)-XOPT(J) + XOPT(J)=ZERO + PTSAUX(1,J)=DMIN1(DELTA,SU(J)) + PTSAUX(2,J)=DMAX1(-DELTA,SL(J)) + IF (PTSAUX(1,J)+PTSAUX(2,J) < ZERO) THEN + TEMP=PTSAUX(1,J) + PTSAUX(1,J)=PTSAUX(2,J) + PTSAUX(2,J)=TEMP + END IF + IF (DABS(PTSAUX(2,J)) < HALF*DABS(PTSAUX(1,J))) THEN + PTSAUX(2,J)=HALF*PTSAUX(1,J) + END IF + DO I=1,NDIM + BMAT(I,J)=ZERO + END DO + END DO FBASE=FVAL(KOPT) ! ! Set the identifiers of the artificial interpolation points that are @@ -1387,40 +1473,41 @@ SUBROUTINE RESCUE (N,NPT,XL,XU,IPRINT,MAXFUN,XBASE,XPT, ! nonzero elements of BMAT and ZMAT. ! PTSID(1)=SFRAC - DO 60 J=1,N - JP=J+1 - JPN=JP+N - PTSID(JP)=DBLE(J)+SFRAC - IF (JPN .LE. NPT) THEN - PTSID(JPN)=DBLE(J)/DBLE(NP)+SFRAC - TEMP=ONE/(PTSAUX(1,J)-PTSAUX(2,J)) - BMAT(JP,J)=-TEMP+ONE/PTSAUX(1,J) - BMAT(JPN,J)=TEMP+ONE/PTSAUX(2,J) - BMAT(1,J)=-BMAT(JP,J)-BMAT(JPN,J) - ZMAT(1,J)=DSQRT(2.0D0)/DABS(PTSAUX(1,J)*PTSAUX(2,J)) - ZMAT(JP,J)=ZMAT(1,J)*PTSAUX(2,J)*TEMP - ZMAT(JPN,J)=-ZMAT(1,J)*PTSAUX(1,J)*TEMP - ELSE - BMAT(1,J)=-ONE/PTSAUX(1,J) - BMAT(JP,J)=ONE/PTSAUX(1,J) - BMAT(J+NPT,J)=-HALF*PTSAUX(1,J)**2 - END IF - 60 CONTINUE + DO J=1,N + JP=J+1 + JPN=JP+N + PTSID(JP)=DBLE(J)+SFRAC + IF (JPN <= NPT) THEN + PTSID(JPN)=DBLE(J)/DBLE(NP)+SFRAC + TEMP=ONE/(PTSAUX(1,J)-PTSAUX(2,J)) + BMAT(JP,J)=-TEMP+ONE/PTSAUX(1,J) + BMAT(JPN,J)=TEMP+ONE/PTSAUX(2,J) + BMAT(1,J)=-BMAT(JP,J)-BMAT(JPN,J) + ZMAT(1,J)=DSQRT(2.0D0)/DABS(PTSAUX(1,J)*PTSAUX(2,J)) + ZMAT(JP,J)=ZMAT(1,J)*PTSAUX(2,J)*TEMP + ZMAT(JPN,J)=-ZMAT(1,J)*PTSAUX(1,J)*TEMP + ELSE + BMAT(1,J)=-ONE/PTSAUX(1,J) + BMAT(JP,J)=ONE/PTSAUX(1,J) + BMAT(J+NPT,J)=-HALF*PTSAUX(1,J)**2 + END IF + END DO ! ! Set any remaining identifiers with their nonzero elements of ZMAT. ! - IF (NPT .GE. N+NP) THEN - DO 70 K=2*NP,NPT - IW=(DBLE(K-NP)-HALF)/DBLE(N) - IP=K-NP-IW*N - IQ=IP+IW - IF (IQ .GT. N) IQ=IQ-N - PTSID(K)=DBLE(IP)+DBLE(IQ)/DBLE(NP)+SFRAC - TEMP=ONE/(PTSAUX(1,IP)*PTSAUX(1,IQ)) - ZMAT(1,K-NP)=TEMP - ZMAT(IP+1,K-NP)=-TEMP - ZMAT(IQ+1,K-NP)=-TEMP - 70 ZMAT(K,K-NP)=TEMP + IF (NPT >= N+NP) THEN + DO K=2*NP,NPT + IW=(DBLE(K-NP)-HALF)/DBLE(N) + IP=K-NP-IW*N + IQ=IP+IW + IF (IQ > N) IQ=IQ-N + PTSID(K)=DBLE(IP)+DBLE(IQ)/DBLE(NP)+SFRAC + TEMP=ONE/(PTSAUX(1,IP)*PTSAUX(1,IQ)) + ZMAT(1,K-NP)=TEMP + ZMAT(IP+1,K-NP)=-TEMP + ZMAT(IQ+1,K-NP)=-TEMP + ZMAT(K,K-NP)=TEMP + END DO END IF NREM=NPT KOLD=1 @@ -1429,19 +1516,21 @@ SUBROUTINE RESCUE (N,NPT,XL,XU,IPRINT,MAXFUN,XBASE,XPT, ! Reorder the provisional points in the way that exchanges PTSID(KOLD) ! with PTSID(KNEW). ! - 80 DO 90 J=1,N - TEMP=BMAT(KOLD,J) - BMAT(KOLD,J)=BMAT(KNEW,J) - 90 BMAT(KNEW,J)=TEMP - DO 100 J=1,NPTM - TEMP=ZMAT(KOLD,J) - ZMAT(KOLD,J)=ZMAT(KNEW,J) - 100 ZMAT(KNEW,J)=TEMP + 80 DO J=1,N + TEMP=BMAT(KOLD,J) + BMAT(KOLD,J)=BMAT(KNEW,J) + BMAT(KNEW,J)=TEMP + END DO + DO J=1,NPTM + TEMP=ZMAT(KOLD,J) + ZMAT(KOLD,J)=ZMAT(KNEW,J) + ZMAT(KNEW,J)=TEMP + END DO PTSID(KOLD)=PTSID(KNEW) PTSID(KNEW)=ZERO W(NDIM+KNEW)=ZERO NREM=NREM-1 - IF (KNEW .NE. KOPT) THEN + IF (KNEW /= KOPT) THEN TEMP=VLAG(KOLD) VLAG(KOLD)=VLAG(KNEW) VLAG(KNEW)=TEMP @@ -1452,9 +1541,10 @@ SUBROUTINE RESCUE (N,NPT,XL,XU,IPRINT,MAXFUN,XBASE,XPT, ! The nonnegative values of W(NDIM+K) are required in the search below. ! CALL UPDATE (N,NPT,BMAT,ZMAT,NDIM,VLAG,BETA,DENOM,KNEW,W) - IF (NREM .EQ. 0) GOTO 350 - DO 110 K=1,NPT - 110 W(NDIM+K)=DABS(W(NDIM+K)) + IF (NREM == 0) GOTO 350 + DO K=1,NPT + W(NDIM+K)=DABS(W(NDIM+K)) + END DO END IF ! ! Pick the index KNEW of an original interpolation point that has not @@ -1462,68 +1552,79 @@ SUBROUTINE RESCUE (N,NPT,XL,XU,IPRINT,MAXFUN,XBASE,XPT, ! attention to the closeness to XOPT and to previous tries with KNEW. ! 120 DSQMIN=ZERO - DO 130 K=1,NPT - IF (W(NDIM+K) .GT. ZERO) THEN - IF (DSQMIN .EQ. ZERO .OR. W(NDIM+K) .LT. DSQMIN) THEN - KNEW=K - DSQMIN=W(NDIM+K) - END IF - END IF - 130 CONTINUE - IF (DSQMIN .EQ. ZERO) GOTO 260 + DO K=1,NPT + IF (W(NDIM+K) > ZERO) THEN + IF (DSQMIN == ZERO .OR. W(NDIM+K) < DSQMIN) THEN + KNEW=K + DSQMIN=W(NDIM+K) + END IF + END IF + END DO + IF (DSQMIN == ZERO) GOTO 260 ! ! Form the W-vector of the chosen original interpolation point. ! - DO 140 J=1,N - 140 W(NPT+J)=XPT(KNEW,J) - DO 160 K=1,NPT + DO J=1,N + W(NPT+J)=XPT(KNEW,J) + END DO + DO K=1,NPT SUM=ZERO - IF (K .EQ. KOPT) THEN + IF (K == KOPT) THEN CONTINUE - ELSE IF (PTSID(K) .EQ. ZERO) THEN - DO 150 J=1,N - 150 SUM=SUM+W(NPT+J)*XPT(K,J) + ELSE IF (PTSID(K) == ZERO) THEN + DO J=1,N + SUM=SUM+W(NPT+J)*XPT(K,J) + END DO ELSE IP=PTSID(K) - IF (IP .GT. 0) SUM=W(NPT+IP)*PTSAUX(1,IP) + IF (IP > 0) SUM=W(NPT+IP)*PTSAUX(1,IP) IQ=DBLE(NP)*PTSID(K)-DBLE(IP*NP) - IF (IQ .GT. 0) THEN + IF (IQ > 0) THEN IW=1 - IF (IP .EQ. 0) IW=2 + IF (IP == 0) IW=2 SUM=SUM+W(NPT+IQ)*PTSAUX(IW,IQ) END IF END IF - 160 W(K)=HALF*SUM*SUM + W(K)=HALF*SUM*SUM + END DO ! ! Calculate VLAG and BETA for the required updating of the H matrix if ! XPT(KNEW,.) is reinstated in the set of interpolation points. ! - DO 180 K=1,NPT - SUM=ZERO - DO 170 J=1,N - 170 SUM=SUM+BMAT(K,J)*W(NPT+J) - 180 VLAG(K)=SUM + DO K=1,NPT + SUM=ZERO + DO J=1,N + SUM=SUM+BMAT(K,J)*W(NPT+J) + END DO + VLAG(K)=SUM + END DO BETA=ZERO - DO 200 J=1,NPTM - SUM=ZERO - DO 190 K=1,NPT - 190 SUM=SUM+ZMAT(K,J)*W(K) - BETA=BETA-SUM*SUM - DO 200 K=1,NPT - 200 VLAG(K)=VLAG(K)+SUM*ZMAT(K,J) + DO J=1,NPTM + SUM=ZERO + DO K=1,NPT + SUM=SUM+ZMAT(K,J)*W(K) + END DO + BETA=BETA-SUM*SUM + DO K=1,NPT + VLAG(K)=VLAG(K)+SUM*ZMAT(K,J) + END DO + END DO BSUM=ZERO DISTSQ=ZERO - DO 230 J=1,N - SUM=ZERO - DO 210 K=1,NPT - 210 SUM=SUM+BMAT(K,J)*W(K) - JP=J+NPT - BSUM=BSUM+SUM*W(JP) - DO 220 IP=NPT+1,NDIM - 220 SUM=SUM+BMAT(IP,J)*W(IP) - BSUM=BSUM+SUM*W(JP) - VLAG(JP)=SUM - 230 DISTSQ=DISTSQ+XPT(KNEW,J)**2 + DO J=1,N + SUM=ZERO + DO K=1,NPT + SUM=SUM+BMAT(K,J)*W(K) + END DO + JP=J+NPT + BSUM=BSUM+SUM*W(JP) + DO IP=NPT+1,NDIM + SUM=SUM+BMAT(IP,J)*W(IP) + END DO + BSUM=BSUM+SUM*W(JP) + VLAG(JP)=SUM + DISTSQ=DISTSQ+XPT(KNEW,J)**2 + END DO BETA=HALF*DISTSQ*DISTSQ+BETA-BSUM VLAG(KOPT)=VLAG(KOPT)+ONE ! @@ -1534,19 +1635,21 @@ SUBROUTINE RESCUE (N,NPT,XL,XU,IPRINT,MAXFUN,XBASE,XPT, ! DENOM=ZERO VLMXSQ=ZERO - DO 250 K=1,NPT - IF (PTSID(K) .NE. ZERO) THEN - HDIAG=ZERO - DO 240 J=1,NPTM - 240 HDIAG=HDIAG+ZMAT(K,J)**2 - DEN=BETA*HDIAG+VLAG(K)**2 - IF (DEN .GT. DENOM) THEN - KOLD=K - DENOM=DEN - END IF - END IF - 250 VLMXSQ=DMAX1(VLMXSQ,VLAG(K)**2) - IF (DENOM .LE. 1.0D-2*VLMXSQ) THEN + DO K=1,NPT + IF (PTSID(K) /= ZERO) THEN + HDIAG=ZERO + DO J=1,NPTM + HDIAG=HDIAG+ZMAT(K,J)**2 + END DO + DEN=BETA*HDIAG+VLAG(K)**2 + IF (DEN > DENOM) THEN + KOLD=K + DENOM=DEN + END IF + END IF + VLMXSQ=DMAX1(VLMXSQ,VLAG(K)**2) + END DO + IF (DENOM <= 1.0D-2*VLMXSQ) THEN W(NDIM+KNEW)=-W(NDIM+KNEW)-WINC GOTO 120 END IF @@ -1560,105 +1663,109 @@ SUBROUTINE RESCUE (N,NPT,XL,XU,IPRINT,MAXFUN,XBASE,XPT, ! by putting the new point in XPT(KPT,.) and by setting PQ(KPT) to zero, ! except that a RETURN occurs if MAXFUN prohibits another value of F. ! - 260 DO 340 KPT=1,NPT - IF (PTSID(KPT) .EQ. ZERO) GOTO 340 - IF (NF .GE. MAXFUN) THEN - NF=-1 - GOTO 350 - END IF - IH=0 - DO 270 J=1,N - W(J)=XPT(KPT,J) - XPT(KPT,J)=ZERO - TEMP=PQ(KPT)*W(J) - DO 270 I=1,J - IH=IH+1 - 270 HQ(IH)=HQ(IH)+TEMP*W(I) - PQ(KPT)=ZERO - IP=PTSID(KPT) - IQ=DBLE(NP)*PTSID(KPT)-DBLE(IP*NP) - IF (IP .GT. 0) THEN - XP=PTSAUX(1,IP) - XPT(KPT,IP)=XP - END IF - IF (IQ .GT. 0) THEN - XQ=PTSAUX(1,IQ) - IF (IP .EQ. 0) XQ=PTSAUX(2,IQ) - XPT(KPT,IQ)=XQ - END IF + 260 DO KPT=1,NPT + IF (PTSID(KPT) == ZERO) CYCLE + IF (NF >= MAXFUN) THEN + NF=-1 + GOTO 350 + END IF + IH=0 + DO J=1,N + W(J)=XPT(KPT,J) + XPT(KPT,J)=ZERO + TEMP=PQ(KPT)*W(J) + DO I=1,J + IH=IH+1 + HQ(IH)=HQ(IH)+TEMP*W(I) + END DO + END DO + PQ(KPT)=ZERO + IP=PTSID(KPT) + IQ=DBLE(NP)*PTSID(KPT)-DBLE(IP*NP) + IF (IP > 0) THEN + XP=PTSAUX(1,IP) + XPT(KPT,IP)=XP + END IF + IF (IQ > 0) THEN + XQ=PTSAUX(1,IQ) + IF (IP == 0) XQ=PTSAUX(2,IQ) + XPT(KPT,IQ)=XQ + END IF ! ! Set VQUAD to the value of the current model at the new point. ! - VQUAD=FBASE - IF (IP .GT. 0) THEN - IHP=(IP+IP*IP)/2 - VQUAD=VQUAD+XP*(GOPT(IP)+HALF*XP*HQ(IHP)) - END IF - IF (IQ .GT. 0) THEN - IHQ=(IQ+IQ*IQ)/2 - VQUAD=VQUAD+XQ*(GOPT(IQ)+HALF*XQ*HQ(IHQ)) - IF (IP .GT. 0) THEN - IW=MAX0(IHP,IHQ)-IABS(IP-IQ) - VQUAD=VQUAD+XP*XQ*HQ(IW) - END IF - END IF - DO 280 K=1,NPT - TEMP=ZERO - IF (IP .GT. 0) TEMP=TEMP+XP*XPT(K,IP) - IF (IQ .GT. 0) TEMP=TEMP+XQ*XPT(K,IQ) - 280 VQUAD=VQUAD+HALF*PQ(K)*TEMP*TEMP + VQUAD=FBASE + IF (IP > 0) THEN + IHP=(IP+IP*IP)/2 + VQUAD=VQUAD+XP*(GOPT(IP)+HALF*XP*HQ(IHP)) + END IF + IF (IQ > 0) THEN + IHQ=(IQ+IQ*IQ)/2 + VQUAD=VQUAD+XQ*(GOPT(IQ)+HALF*XQ*HQ(IHQ)) + IF (IP > 0) THEN + IW=MAX0(IHP,IHQ)-IABS(IP-IQ) + VQUAD=VQUAD+XP*XQ*HQ(IW) + END IF + END IF + DO K=1,NPT + TEMP=ZERO + IF (IP > 0) TEMP=TEMP+XP*XPT(K,IP) + IF (IQ > 0) TEMP=TEMP+XQ*XPT(K,IQ) + VQUAD=VQUAD+HALF*PQ(K)*TEMP*TEMP + END DO ! ! Calculate F at the new interpolation point, and set DIFF to the factor ! that is going to multiply the KPT-th Lagrange function when the model ! is updated to provide interpolation to the new function value. ! - DO 290 I=1,N - W(I)=DMIN1(DMAX1(XL(I),XBASE(I)+XPT(KPT,I)),XU(I)) - IF (XPT(KPT,I) .EQ. SL(I)) W(I)=XL(I) - IF (XPT(KPT,I) .EQ. SU(I)) W(I)=XU(I) - 290 CONTINUE - NF=NF+1 - CALL CALFUN (N,W,F) - IF (IPRINT .EQ. 3) THEN - PRINT 300, NF,F,(W(I),I=1,N) - 300 FORMAT (/4X,'Function number',I6,' F =',1PD18.10, - 1 ' The corresponding X is:'/(2X,5D15.6)) - END IF - FVAL(KPT)=F - IF (F .LT. FVAL(KOPT)) KOPT=KPT - DIFF=F-VQUAD + DO I=1,N + W(I)=DMIN1(DMAX1(XL(I),XBASE(I)+XPT(KPT,I)),XU(I)) + IF (XPT(KPT,I) == SL(I)) W(I)=XL(I) + IF (XPT(KPT,I) == SU(I)) W(I)=XU(I) + END DO + NF=NF+1 + CALL CALFUN (N,W,F) + IF (IPRINT == 3) THEN + PRINT 300, NF,F,(W(I),I=1,N) + 300 FORMAT (/4X,'Function number',I6,' F =',1PD18.10,' The corresponding X is:'/(2X,5D15.6)) + END IF + FVAL(KPT)=F + IF (F < FVAL(KOPT)) KOPT=KPT + DIFF=F-VQUAD ! ! Update the quadratic model. The RETURN from the subroutine occurs when ! all the new interpolation points are included in the model. ! - DO 310 I=1,N - 310 GOPT(I)=GOPT(I)+DIFF*BMAT(KPT,I) - DO 330 K=1,NPT - SUM=ZERO - DO 320 J=1,NPTM - 320 SUM=SUM+ZMAT(K,J)*ZMAT(KPT,J) - TEMP=DIFF*SUM - IF (PTSID(K) .EQ. ZERO) THEN - PQ(K)=PQ(K)+TEMP - ELSE - IP=PTSID(K) - IQ=DBLE(NP)*PTSID(K)-DBLE(IP*NP) - IHQ=(IQ*IQ+IQ)/2 - IF (IP .EQ. 0) THEN - HQ(IHQ)=HQ(IHQ)+TEMP*PTSAUX(2,IQ)**2 - ELSE - IHP=(IP*IP+IP)/2 - HQ(IHP)=HQ(IHP)+TEMP*PTSAUX(1,IP)**2 - IF (IQ .GT. 0) THEN - HQ(IHQ)=HQ(IHQ)+TEMP*PTSAUX(1,IQ)**2 - IW=MAX0(IHP,IHQ)-IABS(IQ-IP) - HQ(IW)=HQ(IW)+TEMP*PTSAUX(1,IP)*PTSAUX(1,IQ) - END IF - END IF - END IF - 330 CONTINUE - PTSID(KPT)=ZERO - 340 CONTINUE + DO I=1,N + GOPT(I)=GOPT(I)+DIFF*BMAT(KPT,I) + END DO + DO K=1,NPT + SUM=ZERO + DO J=1,NPTM + SUM=SUM+ZMAT(K,J)*ZMAT(KPT,J) + END DO + TEMP=DIFF*SUM + IF (PTSID(K) == ZERO) THEN + PQ(K)=PQ(K)+TEMP + ELSE + IP=PTSID(K) + IQ=DBLE(NP)*PTSID(K)-DBLE(IP*NP) + IHQ=(IQ*IQ+IQ)/2 + IF (IP == 0) THEN + HQ(IHQ)=HQ(IHQ)+TEMP*PTSAUX(2,IQ)**2 + ELSE + IHP=(IP*IP+IP)/2 + HQ(IHP)=HQ(IHP)+TEMP*PTSAUX(1,IP)**2 + IF (IQ > 0) THEN + HQ(IHQ)=HQ(IHQ)+TEMP*PTSAUX(1,IQ)**2 + IW=MAX0(IHP,IHQ)-IABS(IQ-IP) + HQ(IW)=HQ(IW)+TEMP*PTSAUX(1,IP)*PTSAUX(1,IQ) + END IF + END IF + END IF + END DO + PTSID(KPT)=ZERO + END DO 350 RETURN END SUBROUTINE RESCUE @@ -1724,16 +1831,17 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ITERC=0 NACT=0 SQSTP=ZERO - DO 10 I=1,N - XBDI(I)=ZERO - IF (XOPT(I) .LE. SL(I)) THEN - IF (GOPT(I) .GE. ZERO) XBDI(I)=ONEMIN - ELSE IF (XOPT(I) .GE. SU(I)) THEN - IF (GOPT(I) .LE. ZERO) XBDI(I)=ONE - END IF - IF (XBDI(I) .NE. ZERO) NACT=NACT+1 - D(I)=ZERO - 10 GNEW(I)=GOPT(I) + DO I=1,N + XBDI(I)=ZERO + IF (XOPT(I) <= SL(I)) THEN + IF (GOPT(I) >= ZERO) XBDI(I)=ONEMIN + ELSE IF (XOPT(I) >= SU(I)) THEN + IF (GOPT(I) <= ZERO) XBDI(I)=ONE + END IF + IF (XBDI(I) /= ZERO) NACT=NACT+1 + D(I)=ZERO + GNEW(I)=GOPT(I) + END DO DELSQ=DELTA*DELTA QRED=ZERO CRVMIN=ONEMIN @@ -1746,21 +1854,22 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! 20 BETA=ZERO 30 STEPSQ=ZERO - DO 40 I=1,N - IF (XBDI(I) .NE. ZERO) THEN - S(I)=ZERO - ELSE IF (BETA .EQ. ZERO) THEN - S(I)=-GNEW(I) - ELSE - S(I)=BETA*S(I)-GNEW(I) - END IF - 40 STEPSQ=STEPSQ+S(I)**2 - IF (STEPSQ .EQ. ZERO) GOTO 190 - IF (BETA .EQ. ZERO) THEN + DO I=1,N + IF (XBDI(I) /= ZERO) THEN + S(I)=ZERO + ELSE IF (BETA == ZERO) THEN + S(I)=-GNEW(I) + ELSE + S(I)=BETA*S(I)-GNEW(I) + END IF + STEPSQ=STEPSQ+S(I)**2 + END DO + IF (STEPSQ == ZERO) GOTO 190 + IF (BETA == ZERO) THEN GREDSQ=STEPSQ ITERMAX=ITERC+N-NACT END IF - IF (GREDSQ*DELSQ .LE. 1.0D-4*QRED*QRED) GO TO 190 + IF (GREDSQ*DELSQ <= 1.0D-4*QRED*QRED) GO TO 190 ! ! Multiply the search direction by the second derivative matrix of Q and ! calculate some scalars for the choice of steplength. Then set BLEN to @@ -1771,22 +1880,22 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, 50 RESID=DELSQ DS=ZERO SHS=ZERO - DO 60 I=1,N - IF (XBDI(I) .EQ. ZERO) THEN - RESID=RESID-D(I)**2 - DS=DS+S(I)*D(I) - SHS=SHS+S(I)*HS(I) - END IF - 60 CONTINUE - IF (RESID .LE. ZERO) GOTO 90 + DO I=1,N + IF (XBDI(I) == ZERO) THEN + RESID=RESID-D(I)**2 + DS=DS+S(I)*D(I) + SHS=SHS+S(I)*HS(I) + END IF + END DO + IF (RESID <= ZERO) GOTO 90 TEMP=DSQRT(STEPSQ*RESID+DS*DS) - IF (DS .LT. ZERO) THEN + IF (DS < ZERO) THEN BLEN=(TEMP-DS)/STEPSQ ELSE BLEN=RESID/(TEMP+DS) END IF STPLEN=BLEN - IF (SHS .GT. ZERO) THEN + IF (SHS > ZERO) THEN STPLEN=DMIN1(BLEN,GREDSQ/SHS) END IF @@ -1795,58 +1904,59 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! letting IACT be the index of the new constrained variable. ! IACT=0 - DO 70 I=1,N - IF (S(I) .NE. ZERO) THEN - XSUM=XOPT(I)+D(I) - IF (S(I) .GT. ZERO) THEN - TEMP=(SU(I)-XSUM)/S(I) - ELSE - TEMP=(SL(I)-XSUM)/S(I) - END IF - IF (TEMP .LT. STPLEN) THEN - STPLEN=TEMP - IACT=I - END IF - END IF - 70 CONTINUE + DO I=1,N + IF (S(I) /= ZERO) THEN + XSUM=XOPT(I)+D(I) + IF (S(I) > ZERO) THEN + TEMP=(SU(I)-XSUM)/S(I) + ELSE + TEMP=(SL(I)-XSUM)/S(I) + END IF + IF (TEMP < STPLEN) THEN + STPLEN=TEMP + IACT=I + END IF + END IF + END DO ! ! Update CRVMIN, GNEW and D. Set SDEC to the decrease that occurs in Q. ! SDEC=ZERO - IF (STPLEN .GT. ZERO) THEN + IF (STPLEN > ZERO) THEN ITERC=ITERC+1 TEMP=SHS/STEPSQ - IF (IACT .EQ. 0 .AND. TEMP .GT. ZERO) THEN + IF (IACT == 0 .AND. TEMP > ZERO) THEN CRVMIN=DMIN1(CRVMIN,TEMP) - IF (CRVMIN .EQ. ONEMIN) CRVMIN=TEMP + IF (CRVMIN == ONEMIN) CRVMIN=TEMP END IF GGSAV=GREDSQ GREDSQ=ZERO - DO 80 I=1,N - GNEW(I)=GNEW(I)+STPLEN*HS(I) - IF (XBDI(I) .EQ. ZERO) GREDSQ=GREDSQ+GNEW(I)**2 - 80 D(I)=D(I)+STPLEN*S(I) + DO I=1,N + GNEW(I)=GNEW(I)+STPLEN*HS(I) + IF (XBDI(I) == ZERO) GREDSQ=GREDSQ+GNEW(I)**2 + D(I)=D(I)+STPLEN*S(I) + END DO SDEC=DMAX1(STPLEN*(GGSAV-HALF*STPLEN*SHS),ZERO) QRED=QRED+SDEC END IF ! ! Restart the conjugate gradient method if it has hit a new bound. ! - IF (IACT .GT. 0) THEN + IF (IACT > 0) THEN NACT=NACT+1 XBDI(IACT)=ONE - IF (S(IACT) .LT. ZERO) XBDI(IACT)=ONEMIN + IF (S(IACT) < ZERO) XBDI(IACT)=ONEMIN DELSQ=DELSQ-D(IACT)**2 - IF (DELSQ .LE. ZERO) GOTO 90 + IF (DELSQ <= ZERO) GOTO 90 GOTO 20 END IF ! ! If STPLEN is less than BLEN, then either apply another conjugate ! gradient iteration or RETURN. ! - IF (STPLEN .LT. BLEN) THEN - IF (ITERC .EQ. ITERMAX) GOTO 190 - IF (SDEC .LE. 0.01D0*QRED) GOTO 190 + IF (STPLEN < BLEN) THEN + IF (ITERC == ITERMAX) GOTO 190 + IF (SDEC <= 0.01D0*QRED) GOTO 190 BETA=GREDSQ/GGSAV GOTO 30 END IF @@ -1856,20 +1966,20 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! and by multiplying the reduced D by the second derivative matrix of ! Q, where S holds the reduced D in the call of GGMULT. ! - 100 IF (NACT .GE. N-1) GOTO 190 + 100 IF (NACT >= N-1) GOTO 190 DREDSQ=ZERO DREDG=ZERO GREDSQ=ZERO - DO 110 I=1,N - IF (XBDI(I) .EQ. ZERO) THEN - DREDSQ=DREDSQ+D(I)**2 - DREDG=DREDG+D(I)*GNEW(I) - GREDSQ=GREDSQ+GNEW(I)**2 - S(I)=D(I) - ELSE - S(I)=ZERO - END IF - 110 CONTINUE + DO I=1,N + IF (XBDI(I) == ZERO) THEN + DREDSQ=DREDSQ+D(I)**2 + DREDG=DREDG+D(I)*GNEW(I) + GREDSQ=GREDSQ+GNEW(I)**2 + S(I)=D(I) + ELSE + S(I)=ZERO + END IF + END DO ITCSAV=ITERC GOTO 210 ! @@ -1878,15 +1988,15 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! 120 ITERC=ITERC+1 TEMP=GREDSQ*DREDSQ-DREDG*DREDG - IF (TEMP .LE. 1.0D-4*QRED*QRED) GOTO 190 + IF (TEMP <= 1.0D-4*QRED*QRED) GOTO 190 TEMP=DSQRT(TEMP) - DO 130 I=1,N - IF (XBDI(I) .EQ. ZERO) THEN - S(I)=(DREDG*D(I)-DREDSQ*GNEW(I))/TEMP - ELSE - S(I)=ZERO - END IF - 130 CONTINUE + DO I=1,N + IF (XBDI(I) == ZERO) THEN + S(I)=(DREDG*D(I)-DREDSQ*GNEW(I))/TEMP + ELSE + S(I)=ZERO + END IF + END DO SREDG=-TEMP ! ! By considering the simple bounds on the variables, calculate an upper @@ -1896,41 +2006,41 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! ANGBD=ONE IACT=0 - DO 140 I=1,N - IF (XBDI(I) .EQ. ZERO) THEN - TEMPA=XOPT(I)+D(I)-SL(I) - TEMPB=SU(I)-XOPT(I)-D(I) - IF (TEMPA .LE. ZERO) THEN - NACT=NACT+1 - XBDI(I)=ONEMIN - GOTO 100 - ELSE IF (TEMPB .LE. ZERO) THEN - NACT=NACT+1 - XBDI(I)=ONE - GOTO 100 - END IF - RATIO=ONE - SSQ=D(I)**2+S(I)**2 - TEMP=SSQ-(XOPT(I)-SL(I))**2 - IF (TEMP .GT. ZERO) THEN - TEMP=DSQRT(TEMP)-S(I) - IF (ANGBD*TEMP .GT. TEMPA) THEN - ANGBD=TEMPA/TEMP - IACT=I - XSAV=ONEMIN - END IF - END IF - TEMP=SSQ-(SU(I)-XOPT(I))**2 - IF (TEMP .GT. ZERO) THEN - TEMP=DSQRT(TEMP)+S(I) - IF (ANGBD*TEMP .GT. TEMPB) THEN - ANGBD=TEMPB/TEMP - IACT=I - XSAV=ONE - END IF - END IF - END IF - 140 CONTINUE + DO I=1,N + IF (XBDI(I) == ZERO) THEN + TEMPA=XOPT(I)+D(I)-SL(I) + TEMPB=SU(I)-XOPT(I)-D(I) + IF (TEMPA <= ZERO) THEN + NACT=NACT+1 + XBDI(I)=ONEMIN + GOTO 100 + ELSE IF (TEMPB <= ZERO) THEN + NACT=NACT+1 + XBDI(I)=ONE + GOTO 100 + END IF + RATIO=ONE + SSQ=D(I)**2+S(I)**2 + TEMP=SSQ-(XOPT(I)-SL(I))**2 + IF (TEMP > ZERO) THEN + TEMP=DSQRT(TEMP)-S(I) + IF (ANGBD*TEMP > TEMPA) THEN + ANGBD=TEMPA/TEMP + IACT=I + XSAV=ONEMIN + END IF + END IF + TEMP=SSQ-(SU(I)-XOPT(I))**2 + IF (TEMP > ZERO) THEN + TEMP=DSQRT(TEMP)+S(I) + IF (ANGBD*TEMP > TEMPB) THEN + ANGBD=TEMPB/TEMP + IACT=I + XSAV=ONE + END IF + END IF + END IF + END DO ! ! Calculate HHD and some curvatures for the alternative iteration. ! @@ -1938,13 +2048,13 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, 150 SHS=ZERO DHS=ZERO DHD=ZERO - DO 160 I=1,N - IF (XBDI(I) .EQ. ZERO) THEN - SHS=SHS+S(I)*HS(I) - DHS=DHS+D(I)*HS(I) - DHD=DHD+D(I)*HRED(I) - END IF - 160 CONTINUE + DO I=1,N + IF (XBDI(I) == ZERO) THEN + SHS=SHS+S(I)*HS(I) + DHS=DHS+D(I)*HS(I) + DHD=DHD+D(I)*HRED(I) + END IF + END DO ! ! Seek the greatest reduction in Q for a range of equally spaced values ! of ANGT in [0,ANGBD], where ANGT is the tangent of half the angle of @@ -1954,25 +2064,26 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ISAV=0 REDSAV=ZERO IU=17.0D0*ANGBD+3.1D0 - DO 170 I=1,IU - ANGT=ANGBD*DBLE(I)/DBLE(IU) - STH=(ANGT+ANGT)/(ONE+ANGT*ANGT) - TEMP=SHS+ANGT*(ANGT*DHD-DHS-DHS) - REDNEW=STH*(ANGT*DREDG-SREDG-HALF*STH*TEMP) - IF (REDNEW .GT. REDMAX) THEN - REDMAX=REDNEW - ISAV=I - RDPREV=REDSAV - ELSE IF (I .EQ. ISAV+1) THEN - RDNEXT=REDNEW - END IF - 170 REDSAV=REDNEW + DO I=1,IU + ANGT=ANGBD*DBLE(I)/DBLE(IU) + STH=(ANGT+ANGT)/(ONE+ANGT*ANGT) + TEMP=SHS+ANGT*(ANGT*DHD-DHS-DHS) + REDNEW=STH*(ANGT*DREDG-SREDG-HALF*STH*TEMP) + IF (REDNEW > REDMAX) THEN + REDMAX=REDNEW + ISAV=I + RDPREV=REDSAV + ELSE IF (I == ISAV+1) THEN + RDNEXT=REDNEW + END IF + REDSAV=REDNEW + END DO ! ! Return if the reduction is zero. Otherwise, set the sine and cosine ! of the angle of the alternative iteration, and calculate SDEC. ! - IF (ISAV .EQ. 0) GOTO 190 - IF (ISAV .LT. IU) THEN + IF (ISAV == 0) GOTO 190 + IF (ISAV < IU) THEN TEMP=(RDNEXT-RDPREV)/(REDMAX+REDMAX-RDPREV-RDNEXT) ANGT=ANGBD*(DBLE(ISAV)+HALF*TEMP)/DBLE(IU) END IF @@ -1980,7 +2091,7 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, STH=(ANGT+ANGT)/(ONE+ANGT*ANGT) TEMP=SHS+ANGT*(ANGT*DHD-DHS-DHS) SDEC=STH*(ANGT*DREDG-SREDG-HALF*STH*TEMP) - IF (SDEC .LE. ZERO) GOTO 190 + IF (SDEC <= ZERO) GOTO 190 ! ! Update GNEW, D and HRED. If the angle of the alternative iteration ! is restricted by a bound on a free variable, that variable is fixed @@ -1988,16 +2099,17 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! DREDG=ZERO GREDSQ=ZERO - DO 180 I=1,N - GNEW(I)=GNEW(I)+(CTH-ONE)*HRED(I)+STH*HS(I) - IF (XBDI(I) .EQ. ZERO) THEN - D(I)=CTH*D(I)+STH*S(I) - DREDG=DREDG+D(I)*GNEW(I) - GREDSQ=GREDSQ+GNEW(I)**2 - END IF - 180 HRED(I)=CTH*HRED(I)+STH*HS(I) + DO I=1,N + GNEW(I)=GNEW(I)+(CTH-ONE)*HRED(I)+STH*HS(I) + IF (XBDI(I) == ZERO) THEN + D(I)=CTH*D(I)+STH*S(I) + DREDG=DREDG+D(I)*GNEW(I) + GREDSQ=GREDSQ+GNEW(I)**2 + END IF + HRED(I)=CTH*HRED(I)+STH*HS(I) + END DO QRED=QRED+SDEC - IF (IACT .GT. 0 .AND. ISAV .EQ. IU) THEN + IF (IACT > 0 .AND. ISAV == IU) THEN NACT=NACT+1 XBDI(IACT)=XSAV GOTO 100 @@ -2006,14 +2118,15 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! If SDEC is sufficiently small, then RETURN after setting XNEW to ! XOPT+D, giving careful attention to the bounds. ! - IF (SDEC .GT. 0.01D0*QRED) GOTO 120 + IF (SDEC > 0.01D0*QRED) GOTO 120 190 DSQ=ZERO - DO 200 I=1,N - XNEW(I)=DMAX1(DMIN1(XOPT(I)+D(I),SU(I)),SL(I)) - IF (XBDI(I) .EQ. ONEMIN) XNEW(I)=SL(I) - IF (XBDI(I) .EQ. ONE) XNEW(I)=SU(I) - D(I)=XNEW(I)-XOPT(I) - 200 DSQ=DSQ+D(I)**2 + DO I=1,N + XNEW(I)=DMAX1(DMIN1(XOPT(I)+D(I),SU(I)),SL(I)) + IF (XBDI(I) == ONEMIN) XNEW(I)=SL(I) + IF (XBDI(I) == ONE) XNEW(I)=SU(I) + D(I)=XNEW(I)-XOPT(I) + DSQ=DSQ+D(I)**2 + END DO RETURN ! The following instructions multiply the current S-vector by the second @@ -2022,32 +2135,36 @@ SUBROUTINE TRSBOX (N,NPT,XPT,XOPT,GOPT,HQ,PQ,SL,SU,DELTA, ! they can be regarded as an external subroutine. ! 210 IH=0 - DO 220 J=1,N - HS(J)=ZERO - DO 220 I=1,J - IH=IH+1 - IF (I .LT. J) HS(J)=HS(J)+HQ(IH)*S(I) - 220 HS(I)=HS(I)+HQ(IH)*S(J) - DO 250 K=1,NPT - IF (PQ(K) .NE. ZERO) THEN - TEMP=ZERO - DO 230 J=1,N - 230 TEMP=TEMP+XPT(K,J)*S(J) - TEMP=TEMP*PQ(K) - DO 240 I=1,N - 240 HS(I)=HS(I)+TEMP*XPT(K,I) - END IF - 250 CONTINUE - IF (CRVMIN .NE. ZERO) GOTO 50 - IF (ITERC .GT. ITCSAV) GOTO 150 - DO 260 I=1,N - 260 HRED(I)=HS(I) + DO J=1,N + HS(J)=ZERO + DO I=1,J + IH=IH+1 + IF (I < J) HS(J)=HS(J)+HQ(IH)*S(I) + HS(I)=HS(I)+HQ(IH)*S(J) + END DO + END DO + DO K=1,NPT + IF (PQ(K) /= ZERO) THEN + TEMP=ZERO + DO J=1,N + TEMP=TEMP+XPT(K,J)*S(J) + END DO + TEMP=TEMP*PQ(K) + DO I=1,N + HS(I)=HS(I)+TEMP*XPT(K,I) + END DO + END IF + END DO + IF (CRVMIN /= ZERO) GOTO 50 + IF (ITERC > ITCSAV) GOTO 150 + DO I=1,N + HRED(I)=HS(I) + END DO GOTO 120 END SUBROUTINE TRSBOX - SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,NDIM,VLAG,BETA,DENOM, - 1 KNEW,W) + SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,NDIM,VLAG,BETA,DENOM,KNEW,W) IMPLICIT real(dp) (A-H,O-Z) DIMENSION BMAT(NDIM,*),ZMAT(NPT,*),VLAG(*),W(*) ! @@ -2066,33 +2183,36 @@ SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,NDIM,VLAG,BETA,DENOM, ZERO=0.0D0 NPTM=NPT-N-1 ZTEST=ZERO - DO 10 K=1,NPT - DO 10 J=1,NPTM - 10 ZTEST=DMAX1(ZTEST,DABS(ZMAT(K,J))) + DO K=1,NPT + DO J=1,NPTM + ZTEST=DMAX1(ZTEST,DABS(ZMAT(K,J))) + END DO + END DO ZTEST=1.0D-20*ZTEST ! ! Apply the rotations that put zeros in the KNEW-th row of ZMAT. ! JL=1 - DO 30 J=2,NPTM - IF (DABS(ZMAT(KNEW,J)) .GT. ZTEST) THEN - TEMP=DSQRT(ZMAT(KNEW,1)**2+ZMAT(KNEW,J)**2) - TEMPA=ZMAT(KNEW,1)/TEMP - TEMPB=ZMAT(KNEW,J)/TEMP - DO 20 I=1,NPT - TEMP=TEMPA*ZMAT(I,1)+TEMPB*ZMAT(I,J) - ZMAT(I,J)=TEMPA*ZMAT(I,J)-TEMPB*ZMAT(I,1) - 20 ZMAT(I,1)=TEMP - END IF - ZMAT(KNEW,J)=ZERO - 30 CONTINUE + DO J=2,NPTM + IF (DABS(ZMAT(KNEW,J)) > ZTEST) THEN + TEMP=DSQRT(ZMAT(KNEW,1)**2+ZMAT(KNEW,J)**2) + TEMPA=ZMAT(KNEW,1)/TEMP + TEMPB=ZMAT(KNEW,J)/TEMP + DO I=1,NPT + TEMP=TEMPA*ZMAT(I,1)+TEMPB*ZMAT(I,J) + ZMAT(I,J)=TEMPA*ZMAT(I,J)-TEMPB*ZMAT(I,1) + ZMAT(I,1)=TEMP + END DO + END IF + ZMAT(KNEW,J)=ZERO + END DO ! Put the first NPT components of the KNEW-th column of HLAG into W, ! and calculate the parameters of the updating formula. - DO 40 I=1,NPT - W(I)=ZMAT(KNEW,1)*ZMAT(I,1) - 40 CONTINUE + DO I=1,NPT + W(I)=ZMAT(KNEW,1)*ZMAT(I,1) + END DO ALPHA=W(KNEW) TAU=VLAG(KNEW) VLAG(KNEW)=VLAG(KNEW)-ONE @@ -2102,20 +2222,22 @@ SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,NDIM,VLAG,BETA,DENOM, TEMP=DSQRT(DENOM) TEMPB=ZMAT(KNEW,1)/TEMP TEMPA=TAU/TEMP - DO 50 I=1,NPT - 50 ZMAT(I,1)=TEMPA*ZMAT(I,1)-TEMPB*VLAG(I) + DO I=1,NPT + ZMAT(I,1)=TEMPA*ZMAT(I,1)-TEMPB*VLAG(I) + END DO ! Finally, update the matrix BMAT. - DO 60 J=1,N - JP=NPT+J - W(JP)=BMAT(KNEW,J) - TEMPA=(ALPHA*VLAG(JP)-TAU*W(JP))/DENOM - TEMPB=(-BETA*W(JP)-TAU*VLAG(JP))/DENOM - DO 60 I=1,JP - BMAT(I,J)=BMAT(I,J)+TEMPA*VLAG(I)+TEMPB*W(I) - IF (I .GT. NPT) BMAT(JP,I-NPT)=BMAT(I,J) - 60 CONTINUE + DO J=1,N + JP=NPT+J + W(JP)=BMAT(KNEW,J) + TEMPA=(ALPHA*VLAG(JP)-TAU*W(JP))/DENOM + TEMPB=(-BETA*W(JP)-TAU*VLAG(JP))/DENOM + DO I=1,JP + BMAT(I,J)=BMAT(I,J)+TEMPA*VLAG(I)+TEMPB*W(I) + IF (I > NPT) BMAT(JP,I-NPT)=BMAT(I,J) + END DO + END DO RETURN END SUBROUTINE UPDATE diff --git a/num/private/mod_dop853.f b/num/private/mod_dop853.f index 83dfc61ec..690ca36a0 100644 --- a/num/private/mod_dop853.f +++ b/num/private/mod_dop853.f @@ -65,98 +65,98 @@ subroutine do_dop853( nrejct=0 arret=.false. ! -------- nmax , the maximal number of steps ----- - if(max_steps.eq.0)then + if(max_steps == 0)then nmax=100000 else nmax=max_steps - if(nmax.le.0)then - if (lout.gt.0) write(lout,*) + if(nmax <= 0)then + if (lout >0) write(lout,*) & ' wrong input max_steps=',max_steps arret=.true. end if end if ! -------- meth coefficients of the method - if(iwork(2).eq.0)then + if(iwork(2) == 0)then meth=1 else meth=iwork(2) - if(meth.le.0.or.meth.ge.4)then - if (lout.gt.0) write(lout,*) + if(meth <= 0.or.meth >= 4)then + if (lout >0) write(lout,*) & ' curious input iwork(2)=',iwork(2) arret=.true. end if end if ! -------- nstiff parameter for stiffness detection nstiff=iwork(4) - if (nstiff.eq.0) nstiff=1000 - if (nstiff.lt.0) nstiff=nmax+10 + if (nstiff == 0) nstiff=1000 + if (nstiff <0) nstiff=nmax+10 ! -------- nrdens number of dense output components nrdens=iwork(5) - if(nrdens.lt.0.or.nrdens.gt.n)then - if (lout.gt.0) write(lout,*) + if(nrdens <0.or.nrdens >n)then + if (lout >0) write(lout,*) & ' curious input iwork(5)=',iwork(5) arret=.true. else - if(nrdens.gt.0.and.iout.lt.2)then - if (lout.gt.0) write(lout,*) + if(nrdens >0.and.iout <2)then + if (lout >0) write(lout,*) & ' warning: put iout=2 for dense output ' end if - if (nrdens.eq.n) then + if (nrdens == n) then do i=1,nrdens iwork(i+20)=i end do end if end if ! -------- uround smallest number satisfying 1.d0+uround>1.d0 - if(work(1).eq.0.d0)then + if(work(1) == 0.d0)then uround=2.3d-16 else uround=work(1) - if(uround.le.1.d-35.or.uround.ge.1.d0)then - if (lout.gt.0) write(lout,*) + if(uround <= 1.d-35.or.uround >= 1.d0)then + if (lout >0) write(lout,*) & ' which machine do you have? your uround was:',work(1) arret=.true. end if end if ! ------- safety factor ------------- - if(work(2).eq.0.d0)then + if(work(2) == 0.d0)then safe=0.9d0 else safe=work(2) - if(safe.ge.1.d0.or.safe.le.1.d-4)then - if (lout.gt.0) write(lout,*) + if(safe >= 1.d0.or.safe <= 1.d-4)then + if (lout >0) write(lout,*) & ' curious input for safety factor work(2)=',work(2) arret=.true. end if end if ! ------- fac1,fac2 parameters for step size selection - if(work(3).eq.0.d0)then + if(work(3) == 0.d0)then fac1=0.333d0 else fac1=work(3) end if - if(work(4).eq.0.d0)then + if(work(4) == 0.d0)then fac2=6.d0 else fac2=work(4) end if ! --------- beta for step control stabilization ----------- - if(work(5).eq.0.d0)then + if(work(5) == 0.d0)then beta=0.0d0 else - if(work(5).lt.0.d0)then + if(work(5) <0.d0)then beta=0.d0 else beta=work(5) - if(beta.gt.0.2d0)then - if (lout.gt.0) write(lout,*) + if(beta >0.2d0)then + if (lout >0) write(lout,*) & ' curious input for beta: work(5)=',work(5) arret=.true. end if end if end if ! -------- maximal step size - if(max_step_size.eq.0.d0)then + if(max_step_size == 0.d0)then hmax=xend-x else hmax=max_step_size @@ -176,15 +176,15 @@ subroutine do_dop853( ieco=iey1+n ! ------ total storage requirement ----------- istore=ieco+(3+8*nrdens)-1 - if(istore.gt.lwork)then - if (lout.gt.0) write(lout,*) + if(istore >lwork)then + if (lout >0) write(lout,*) & ' insufficient storage for work, min. lwork=',istore arret=.true. end if icomp=21 istore=icomp+nrdens-1 - if(istore.gt.liwork)then - if (lout.gt.0) write(lout,*) + if(istore >liwork)then + if (lout >0) write(lout,*) & ' insufficient storage for iwork, min. liwork=',istore arret=.true. end if @@ -429,21 +429,21 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, if (ierr /= 0) then; idid=-5; return; end if hmax=abs(hmax) iord=8 - if (h.eq.0.d0) h=hinit(n,fcn,x,y,xend,posneg,k1,k2,k3,iord, + if (h == 0.d0) h=hinit(n,fcn,x,y,xend,posneg,k1,k2,k3,iord, & hmax,atol,rtol,itol,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; idid=-5; return; end if nfcn=nfcn+2 reject=.false. xold=x irtrn=1 - if (iout.ge.1) then + if (iout >= 1) then hout=1.d0 rwork(1) = xold rwork(2) = hout iwork(1) = nrd iwork(2:nrd+1) = icomp(1:nrd) - do 662 j=1,nrd + do j=1,nrd i=icomp(j) cont(j)=y(i) cont(j+nrd)=0 @@ -453,101 +453,115 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, cont(j+nrd*5)=0 cont(j+nrd*6)=0 cont(j+nrd*7)=0 - 662 continue + end do call solout(naccpt+1,xold,x,n,y,rwork,iwork,contd8,lrpar,rpar,lipar,ipar,irtrn) - if (irtrn.lt.0) goto 79 + if (irtrn <0) goto 79 end if ! --- basic integration step 1 continue - if (nstep.gt.nmax) goto 78 - if (0.1d0*abs(h).le.abs(x)*uround)goto 77 - if ((x+1.01d0*h-xend)*posneg.gt.0.d0) then + if (nstep >nmax) goto 78 + if (0.1d0*abs(h) <= abs(x)*uround)goto 77 + if ((x+1.01d0*h-xend)*posneg >0.d0) then h=xend-x last=.true. end if nstep=nstep+1 ! --- the twelve stages - if (irtrn.ge.2) then + if (irtrn >= 2) then call fcn(n,x,h,y,k1,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if end if - do 22 i=1,n - 22 y1(i)=y(i)+h*a21*k1(i) + do i=1,n + y1(i)=y(i)+h*a21*k1(i) + end do call fcn(n,x+c2*h,h,y1,k2,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 23 i=1,n - 23 y1(i)=y(i)+h*(a31*k1(i)+a32*k2(i)) + do i=1,n + y1(i)=y(i)+h*(a31*k1(i)+a32*k2(i)) + end do call fcn(n,x+c3*h,h,y1,k3,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 24 i=1,n - 24 y1(i)=y(i)+h*(a41*k1(i)+a43*k3(i)) + do i=1,n + y1(i)=y(i)+h*(a41*k1(i)+a43*k3(i)) + end do call fcn(n,x+c4*h,h,y1,k4,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 25 i=1,n - 25 y1(i)=y(i)+h*(a51*k1(i)+a53*k3(i)+a54*k4(i)) + do i=1,n + y1(i)=y(i)+h*(a51*k1(i)+a53*k3(i)+a54*k4(i)) + end do call fcn(n,x+c5*h,h,y1,k5,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 26 i=1,n - 26 y1(i)=y(i)+h*(a61*k1(i)+a64*k4(i)+a65*k5(i)) + do i=1,n + y1(i)=y(i)+h*(a61*k1(i)+a64*k4(i)+a65*k5(i)) + end do call fcn(n,x+c6*h,h,y1,k6,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 27 i=1,n - 27 y1(i)=y(i)+h*(a71*k1(i)+a74*k4(i)+a75*k5(i)+a76*k6(i)) + do i=1,n + y1(i)=y(i)+h*(a71*k1(i)+a74*k4(i)+a75*k5(i)+a76*k6(i)) + end do call fcn(n,x+c7*h,h,y1,k7,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 28 i=1,n - 28 y1(i)=y(i)+h*(a81*k1(i)+a84*k4(i)+a85*k5(i)+a86*k6(i)+a87*k7(i)) + do i=1,n + y1(i)=y(i)+h*(a81*k1(i)+a84*k4(i)+a85*k5(i)+a86*k6(i)+a87*k7(i)) + end do call fcn(n,x+c8*h,h,y1,k8,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 29 i=1,n - 29 y1(i)=y(i)+h*(a91*k1(i)+a94*k4(i)+a95*k5(i)+a96*k6(i)+a97*k7(i) - & +a98*k8(i)) + do i=1,n + y1(i)=y(i)+h*(a91*k1(i)+a94*k4(i)+a95*k5(i)+a96*k6(i)+a97*k7(i) + & +a98*k8(i)) + end do call fcn(n,x+c9*h,h,y1,k9,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 30 i=1,n - 30 y1(i)=y(i)+h*(a101*k1(i)+a104*k4(i)+a105*k5(i)+a106*k6(i) - & +a107*k7(i)+a108*k8(i)+a109*k9(i)) + do i=1,n + y1(i)=y(i)+h*(a101*k1(i)+a104*k4(i)+a105*k5(i)+a106*k6(i) + & +a107*k7(i)+a108*k8(i)+a109*k9(i)) + end do call fcn(n,x+c10*h,h,y1,k10,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 31 i=1,n - 31 y1(i)=y(i)+h*(a111*k1(i)+a114*k4(i)+a115*k5(i)+a116*k6(i) - & +a117*k7(i)+a118*k8(i)+a119*k9(i)+a1110*k10(i)) + do i=1,n + y1(i)=y(i)+h*(a111*k1(i)+a114*k4(i)+a115*k5(i)+a116*k6(i) + & +a117*k7(i)+a118*k8(i)+a119*k9(i)+a1110*k10(i)) + end do call fcn(n,x+c11*h,h,y1,k2,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if xph=x+h - do 32 i=1,n - 32 y1(i)=y(i)+h*(a121*k1(i)+a124*k4(i)+a125*k5(i)+a126*k6(i) - & +a127*k7(i)+a128*k8(i)+a129*k9(i)+a1210*k10(i)+a1211*k2(i)) + do i=1,n + y1(i)=y(i)+h*(a121*k1(i)+a124*k4(i)+a125*k5(i)+a126*k6(i) + & +a127*k7(i)+a128*k8(i)+a129*k9(i)+a1210*k10(i)+a1211*k2(i)) + end do call fcn(n,xph,h,y1,k3,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if nfcn=nfcn+11 - do 35 i=1,n - k4(i)=b1*k1(i)+b6*k6(i)+b7*k7(i)+b8*k8(i)+b9*k9(i) - & +b10*k10(i)+b11*k2(i)+b12*k3(i) - 35 k5(i)=y(i)+h*k4(i) + do i=1,n + k4(i)=b1*k1(i)+b6*k6(i)+b7*k7(i)+b8*k8(i)+b9*k9(i) + & +b10*k10(i)+b11*k2(i)+b12*k3(i) + k5(i)=y(i)+h*k4(i) + end do ! --- error estimation err=0.d0 err2=0.d0 - if (itol.eq.0) then - do 41 i=1,n - sk=atoli+rtoli*max(abs(y(i)),abs(k5(i))) - erri=k4(i)-bhh1*k1(i)-bhh2*k9(i)-bhh3*k3(i) - err2=err2+(erri/sk)**2 - erri=er1*k1(i)+er6*k6(i)+er7*k7(i)+er8*k8(i)+er9*k9(i) - & +er10*k10(i)+er11*k2(i)+er12*k3(i) - 41 err=err+(erri/sk)**2 + if (itol == 0) then + do i=1,n + sk=atoli+rtoli*max(abs(y(i)),abs(k5(i))) + erri=k4(i)-bhh1*k1(i)-bhh2*k9(i)-bhh3*k3(i) + err2=err2+(erri/sk)**2 + erri=er1*k1(i)+er6*k6(i)+er7*k7(i)+er8*k8(i)+er9*k9(i) + & +er10*k10(i)+er11*k2(i)+er12*k3(i) + err=err+(erri/sk)**2 + end do else - do 42 i=1,n - sk=atol(i)+rtol(i)*max(abs(y(i)),abs(k5(i))) - erri=k4(i)-bhh1*k1(i)-bhh2*k9(i)-bhh3*k3(i) - err2=err2+(erri/sk)**2 - erri=er1*k1(i)+er6*k6(i)+er7*k7(i)+er8*k8(i)+er9*k9(i) - & +er10*k10(i)+er11*k2(i)+er12*k3(i) - 42 err=err+(erri/sk)**2 + do i=1,n + sk=atol(i)+rtol(i)*max(abs(y(i)),abs(k5(i))) + erri=k4(i)-bhh1*k1(i)-bhh2*k9(i)-bhh3*k3(i) + err2=err2+(erri/sk)**2 + erri=er1*k1(i)+er6*k6(i)+er7*k7(i)+er8*k8(i)+er9*k9(i) + & +er10*k10(i)+er11*k2(i)+er12*k3(i) + err=err+(erri/sk)**2 + end do end if deno=err+0.01d0*err2 - if (deno.le.0.d0) deno=1.d0 + if (deno <= 0.d0) deno=1.d0 err=abs(h)*err*sqrt(1.d0/(n*deno)) ! --- computation of hnew fac11=pow(err,expo1) @@ -556,7 +570,7 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, ! --- we require fac1 <= hnew/h <= fac2 fac=max(facc2,min(facc1,fac/safe)) hnew=h/fac - if(err.le.1.d0)then + if(err <= 1.d0)then ! --- step is accepted facold=max(err,1.0d-4) naccpt=naccpt+1 @@ -564,31 +578,31 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if nfcn=nfcn+1 ! ------- stiffness detection - if (mod(naccpt,nstiff).eq.0.or.iasti.gt.0) then + if (mod(naccpt,nstiff) == 0.or.iasti >0) then stnum=0.d0 stden=0.d0 - do 64 i=1,n + do i=1,n stnum=stnum+(k4(i)-k3(i))**2 stden=stden+(k5(i)-y1(i))**2 - 64 continue - if (stden.gt.0.d0) hlamb=abs(h)*sqrt(stnum/stden) - if (hlamb.gt.6.1d0) then + end do + if (stden >0.d0) hlamb=abs(h)*sqrt(stnum/stden) + if (hlamb >6.1d0) then nonsti=0 iasti=iasti+1 - if (iasti.eq.15) then - if (lout.gt.0) write (lout,*) + if (iasti == 15) then + if (lout >0) write (lout,*) & ' the problem seems to become stiff at x = ',x - if (lout.lt.0) goto 76 + if (lout <0) goto 76 end if else nonsti=nonsti+1 - if (nonsti.eq.6) iasti=0 + if (nonsti == 6) iasti=0 end if end if ! ------- final preparation for dense output - if (iout.ge.2) then + if (iout >= 2) then ! ---- save the first function evaluations - do 62 j=1,nrd + do j=1,nrd i=icomp(j) cont(j)=y(i) ydiff=k5(i)-y(i) @@ -604,29 +618,32 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, & +d69*k9(i)+d610*k10(i)+d611*k2(i)+d612*k3(i) cont(j+nrd*7)=d71*k1(i)+d76*k6(i)+d77*k7(i)+d78*k8(i) & +d79*k9(i)+d710*k10(i)+d711*k2(i)+d712*k3(i) - 62 continue + end do ! --- the next three function evaluations - do 51 i=1,n - 51 y1(i)=y(i)+h*(a141*k1(i)+a147*k7(i)+a148*k8(i) + do i=1,n + y1(i)=y(i)+h*(a141*k1(i)+a147*k7(i)+a148*k8(i) & +a149*k9(i)+a1410*k10(i)+a1411*k2(i)+a1412*k3(i) & +a1413*k4(i)) + end do call fcn(n,x+c14*h,h,y1,k10,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 52 i=1,n - 52 y1(i)=y(i)+h*(a151*k1(i)+a156*k6(i)+a157*k7(i) + do i=1,n + y1(i)=y(i)+h*(a151*k1(i)+a156*k6(i)+a157*k7(i) & +a158*k8(i)+a1511*k2(i)+a1512*k3(i)+a1513*k4(i) & +a1514*k10(i)) + end do call fcn(n,x+c15*h,h,y1,k2,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 53 i=1,n - 53 y1(i)=y(i)+h*(a161*k1(i)+a166*k6(i)+a167*k7(i) + do i=1,n + y1(i)=y(i)+h*(a161*k1(i)+a166*k6(i)+a167*k7(i) & +a168*k8(i)+a169*k9(i)+a1613*k4(i)+a1614*k10(i) & +a1615*k2(i)) + end do call fcn(n,x+c16*h,h,y1,k3,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if nfcn=nfcn+3 ! --- final preparation - do 63 j=1,nrd + do j=1,nrd i=icomp(j) cont(j+nrd*4)=h*(cont(j+nrd*4)+d413*k4(i)+d414*k10(i) & +d415*k2(i)+d416*k3(i)) @@ -636,21 +653,22 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, & +d615*k2(i)+d616*k3(i)) cont(j+nrd*7)=h*(cont(j+nrd*7)+d713*k4(i)+d714*k10(i) & +d715*k2(i)+d716*k3(i)) - 63 continue + end do hout=h end if - do 67 i=1,n - k1(i)=k4(i) - 67 y(i)=k5(i) + do i=1,n + k1(i)=k4(i) + y(i)=k5(i) + end do xold=x x=xph - if (iout.ge.1) then + if (iout >= 1) then rwork(1) = xold rwork(2) = hout iwork(1) = nrd iwork(2:nrd+1) = icomp(1:nrd) call solout(naccpt+1,xold,x,n,y,rwork,iwork,contd8,lrpar,rpar,lipar,ipar,irtrn) - if (irtrn.lt.0) goto 79 + if (irtrn <0) goto 79 end if ! ------- normal exit if (last) then @@ -658,14 +676,14 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, idid=1 return end if - if(abs(hnew).gt.hmax)hnew=posneg*hmax + if(abs(hnew) >hmax)hnew=posneg*hmax if(reject)hnew=posneg*min(abs(hnew),abs(h)) reject=.false. else ! --- step is rejected hnew=h/min(facc1,fac11/safe) reject=.true. - if(naccpt.ge.1)nrejct=nrejct+1 + if(naccpt >= 1)nrejct=nrejct+1 last=.false. end if h=hnew @@ -675,18 +693,18 @@ subroutine dp86co(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, idid=-4 return 77 continue - if (lout.gt.0) write(lout,979) x - if (lout.gt.0) write(lout,*)' step size too small, h=',h + if (lout >0) write(lout,979) x + if (lout >0) write(lout,*)' step size too small, h=',h idid=-3 return 78 continue - if (lout.gt.0) write(lout,979) x - if (lout.gt.0) write(lout,*) + if (lout >0) write(lout,979) x + if (lout >0) write(lout,*) & ' more than nmax =',nmax,'steps are needed' idid=-2 return 79 continue - !if (lout.gt.0) write(lout,979) x + !if (lout >0) write(lout,979) x 979 format(' exit of dop853 at x=',e18.4) idid=2 return @@ -724,18 +742,20 @@ function hinit(n,fcn,x,y,xend,posneg,f0,f1,y1,iord, dny=0.0d0 atoli=atol(1) rtoli=rtol(1) - if (itol.eq.0) then - do 10 i=1,n - sk=atoli+rtoli*abs(y(i)) - dnf=dnf+(f0(i)/sk)**2 - 10 dny=dny+(y(i)/sk)**2 + if (itol == 0) then + do i=1,n + sk=atoli+rtoli*abs(y(i)) + dnf=dnf+(f0(i)/sk)**2 + dny=dny+(y(i)/sk)**2 + end do else - do 11 i=1,n - sk=atol(i)+rtol(i)*abs(y(i)) - dnf=dnf+(f0(i)/sk)**2 - 11 dny=dny+(y(i)/sk)**2 + do i=1,n + sk=atol(i)+rtol(i)*abs(y(i)) + dnf=dnf+(f0(i)/sk)**2 + dny=dny+(y(i)/sk)**2 + end do end if - if (dnf.le.1.d-10.or.dny.le.1.d-10) then + if (dnf <= 1.d-10.or.dny <= 1.d-10) then h=1.0d-6 else h=sqrt(dny/dnf)*0.01d0 @@ -743,26 +763,29 @@ function hinit(n,fcn,x,y,xend,posneg,f0,f1,y1,iord, h=min(h,hmax) h=sign(h,posneg) ! ---- perform an explicit euler step - do 12 i=1,n - 12 y1(i)=y(i)+h*f0(i) + do i=1,n + y1(i)=y(i)+h*f0(i) + end do call fcn(n,x+h,h,y1,f1,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; idid=-5; return; end if ! ---- estimate the second derivative of the solution der2=0.0d0 - if (itol.eq.0) then - do 15 i=1,n - sk=atoli+rtoli*abs(y(i)) - 15 der2=der2+((f1(i)-f0(i))/sk)**2 + if (itol == 0) then + do i=1,n + sk=atoli+rtoli*abs(y(i)) + der2=der2+((f1(i)-f0(i))/sk)**2 + end do else - do 16 i=1,n - sk=atol(i)+rtol(i)*abs(y(i)) - 16 der2=der2+((f1(i)-f0(i))/sk)**2 + do i=1,n + sk=atol(i)+rtol(i)*abs(y(i)) + der2=der2+((f1(i)-f0(i))/sk)**2 + end do end if der2=sqrt(der2)/h ! ---- step size is computed such that ! ---- h**iord * max ( norm (f0), norm (der2)) = 0.01 der12=max(abs(der2),sqrt(dnf)) - if (der12.le.1.d-15) then + if (der12 <= 1.d-15) then h1=max(1.0d-6,abs(h)*1.0d-3) else h1=pow(0.01d0/der12,1.d0/iord) @@ -771,10 +794,9 @@ function hinit(n,fcn,x,y,xend,posneg,f0,f1,y1,iord, hinit=sign(h,posneg) return end function hinit -! - + real(dp) function contd8(ii,x,rwork,iwork,ierr) ! ---------------------------------------------------------- ! this function can be used for continuous output in connection @@ -801,11 +823,11 @@ real(dp) function contd8(ii,x,rwork,iwork,ierr) ! ----- compute place of ii-th component i=0 do j=1,nd - if (icomp(j).eq.ii) then + if (icomp(j) == ii) then i=j; exit end if end do - if (i.eq.0) then + if (i == 0) then contd8 = 0 ierr = -1 return @@ -820,3 +842,4 @@ end function contd8 end module mod_dop853 + diff --git a/num/private/mod_dopri5.f b/num/private/mod_dopri5.f index b5ee75dcb..97bd6ae7c 100644 --- a/num/private/mod_dopri5.f +++ b/num/private/mod_dopri5.f @@ -24,7 +24,9 @@ ! *********************************************************************** module mod_dopri5 use const_def, only: dp - use math_lib + use math_lib + + implicit none contains @@ -35,7 +37,6 @@ subroutine do_dopri5( ! *** *** *** *** *** *** *** *** *** *** *** *** *** ! declarations ! *** *** *** *** *** *** *** *** *** *** *** *** *** - implicit real(dp) (a-h,o-z) integer, intent(in) :: n ! the dimension of the system interface #include "num_fcn.dek" @@ -54,6 +55,10 @@ subroutine do_dopri5( real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(in) :: lout integer, intent(out) :: idid + integer :: nfcn, nstep, naccpt, nrejct, i, icomp, ieco + integer :: iek1, iek2, iek3, iek4, iek5, iek6 + integer :: iey1, ieys, istore, nmax, meth, nstiff, nrdens + real(dp) :: beta, fac1, fac2, hmax, safe, uround logical arret ! *** *** *** *** *** *** *** @@ -65,97 +70,98 @@ subroutine do_dopri5( nrejct=0 arret=.false. ! -------- nmax , the maximal number of steps ----- - if(max_steps.eq.0)then + if (max_steps == 0 ) then nmax=100000 else nmax=max_steps - if(nmax.le.0)then - if (lout.gt.0) write(lout,*) + if (nmax <= 0 ) then + if (lout > 0) write(lout,*) & ' wrong input max_steps=',max_steps arret=.true. end if end if ! -------- meth coefficients of the method - if(iwork(2).eq.0)then + if (iwork(2) == 0 ) then meth=1 else meth=iwork(2) - if(meth.le.0.or.meth.ge.4)then - if (lout.gt.0) write(lout,*) + if (meth <= 0.or.meth >= 4 ) then + if (lout > 0) write(lout,*) & ' curious input iwork(2)=',iwork(2) arret=.true. end if end if ! -------- nstiff parameter for stiffness detection nstiff=iwork(4) - if (nstiff.eq.0) nstiff=1000 - if (nstiff.lt.0) nstiff=nmax+10 + if (nstiff == 0) nstiff=1000 + if (nstiff < 0) nstiff=nmax+10 ! -------- nrdens number of dense output components nrdens=iwork(5) - if(nrdens.lt.0.or.nrdens.gt.n)then - if (lout.gt.0) write(lout,*) + if (nrdens < 0.or.nrdens > n ) then + if (lout > 0) write(lout,*) & ' curious input iwork(5)=',iwork(5) arret=.true. else - if(nrdens.gt.0.and.iout.lt.2)then - if (lout.gt.0) write(lout,*) + if (nrdens > 0.and.iout < 2 ) then + if (lout > 0) write(lout,*) & ' warning: put iout=2 for dense output ' end if - if (nrdens.eq.n) then - do 16 i=1,nrdens - 16 iwork(20+i)=i + if (nrdens == n) then + do i=1,nrdens + iwork(20+i)=i + end do end if end if ! -------- uround smallest number satisfying 1.d0+uround>1.d0 - if(work(1).eq.0.d0)then + if (work(1) == 0.d0 ) then uround=2.3d-16 else uround=work(1) - if(uround.le.1.d-35.or.uround.ge.1.d0)then - if (lout.gt.0) write(lout,*) + if (uround <= 1.d-35.or.uround >= 1.d0 ) then + if (lout > 0) write(lout,*) & ' which machine do you have? your uround was:',work(1) arret=.true. end if end if ! ------- safety factor ------------- - if(work(2).eq.0.d0)then + if (work(2) == 0.d0 ) then safe=0.9d0 else safe=work(2) - if(safe.ge.1.d0.or.safe.le.1.d-4)then - if (lout.gt.0) write(lout,*) + if (safe >= 1.d0.or.safe <= 1.d-4 ) then + if (lout > 0) write(lout,*) & ' curious input for safety factor work(2)=',work(2) arret=.true. end if end if ! ------- fac1,fac2 parameters for step size selection - if(work(3).eq.0.d0)then + if (work(3) == 0.d0 ) then fac1=0.2d0 else fac1=work(3) end if - if(work(4).eq.0.d0)then + if (work(4) == 0.d0 ) then fac2=10.d0 else fac2=work(4) end if ! --------- beta for step control stabilization ----------- - if(work(5).eq.0.d0)then + if (work(5) == 0.d0 ) then beta=0.04d0 else - if(work(5).lt.0.d0)then + if (work(5) < 0.d0 ) then beta=0.d0 else beta=work(5) - if(beta.gt.0.2d0)then - if (lout.gt.0) write(lout,*) + if (beta > 0.2d0 ) then + if (lout > 0) write(lout,*) & ' curious input for beta: work(5)=',work(5) arret=.true. end if end if end if ! -------- maximal step size - if(max_step_size.eq.0.d0)then + if (max_step_size == 0.d0 ) then hmax=xend-x else hmax=max_step_size @@ -172,15 +178,15 @@ subroutine do_dopri5( ieco=ieys+n ! ------ total storage requirement ----------- istore=ieys+(3+5*nrdens)-1 - if(istore.gt.lwork)then - if (lout.gt.0) write(lout,*) + if (istore > lwork ) then + if (lout > 0) write(lout,*) & ' insufficient storage for work, min. lwork=',istore arret=.true. end if icomp=21 istore=icomp+nrdens-1 - if(istore.gt.liwork)then - if (lout.gt.0) write(lout,*) + if (istore > liwork ) then + if (lout > 0) write(lout,*) & ' insufficient storage for iwork, min. liwork=',istore arret=.true. end if @@ -218,16 +224,25 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, ! ---------------------------------------------------------- ! declarations ! ---------------------------------------------------------- - implicit real(dp) (a-h,o-z) - integer :: n, itol, lout, iout, idid, nmax, meth - - real(dp) k1(n),k2(n),k3(n),k4(n),k5(n),k6(n) - dimension y(n),y1(n),ysti(n),atol(*),rtol(*) - dimension icomp(nrd),iwork(nrd+1) + integer :: n, nrd, itol, lout, iout, idid, nmax, meth + real(dp) :: x, xold, xend, hmax, h, uround, safe + real(dp) :: beta, fac1, fac2 + real(dp) :: k1(n),k2(n),k3(n),k4(n),k5(n),k6(n) + real(dp) :: y(n),y1(n),ysti(n),atol(*),rtol(*) + integer :: icomp(nrd), iwork(nrd+1) + integer :: lrpar, lipar, nfcn, nstep, naccpt, nrejct, nstiff logical reject,last integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp) :: c2,c3,c4,c5 + real(dp) :: e1,e3,e4,e5,e6,e7 + real(dp) :: a21,a31,a32,a41,a42,a43,a51,a52,a53,a54 + real(dp) :: a61,a62,a63,a64,a65,a71,a73,a74,a75,a76 + real(dp) :: d1,d3,d4,d5,d6,d7 + real(dp) :: atoli, expo1, facc1, facc2, facold, hlamb, hout, nonsti, posneg, bspl, rtoli + integer :: i, iasti, ierr, iord, irtrn, j !common /condo5/xold,hout + real(dp) :: err, fac, fac11, hnew, sk, stden, stnum, xph, yd0, ydiff interface #include "num_fcn.dek" @@ -240,9 +255,9 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, ! *** *** *** *** *** *** *** -! initialisations +! initializations ! *** *** *** *** *** *** *** - if (meth.eq.1) call cdopri(c2,c3,c4,c5,e1,e3,e4,e5,e6,e7, + if (meth == 1) call cdopri(c2,c3,c4,c5,e1,e3,e4,e5,e6,e7, & a21,a31,a32,a41,a42,a43,a51,a52,a53,a54, & a61,a62,a63,a64,a65,a71,a73,a74,a75,a76, & d1,d3,d4,d5,d6,d7) @@ -262,13 +277,13 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, if (ierr /= 0) then; idid=-5; return; end if hmax=abs(hmax) iord=5 - if (h.eq.0.d0) h=hinit(n,fcn,x,y,xend,posneg,k1,k2,k3,iord, + if (h == 0.d0) h=hinit(n,fcn,x,y,xend,posneg,k1,k2,k3,iord, & hmax,atol,rtol,itol,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; idid=-5; return; end if nfcn=nfcn+2 reject=.false. xold=x - if (iout.ne.0) then + if (iout /= 0) then irtrn=1 hout=h rwork(1) = xold @@ -276,80 +291,89 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, iwork(1) = nrd iwork(2:nrd+1) = icomp(1:nrd) - if (iout.ge.2) then - do 443 j=1,nrd - i=icomp(j) - cont(j)=y(i) - cont(nrd+j)=0 - cont(2*nrd+j)=0 - cont(3*nrd+j)=0 - 443 continue + if (iout >= 2) then + do j=1,nrd + i=icomp(j) + cont(j)=y(i) + cont(nrd+j)=0 + cont(2*nrd+j)=0 + cont(3*nrd+j)=0 + end do end if call solout(naccpt+1,xold,x,n,y,rwork,iwork,contd5,lrpar,rpar,lipar,ipar,irtrn) - if (irtrn.lt.0) goto 79 + if (irtrn < 0) goto 79 else irtrn=0 end if ! --- basic integration step 1 continue - if (nstep.gt.nmax) goto 78 - if (0.1d0*abs(h).le.abs(x)*uround)goto 77 - if ((x+1.01d0*h-xend)*posneg.gt.0.d0) then + if (nstep > nmax) goto 78 + if (0.1d0*abs(h) <= abs(x)*uround)goto 77 + if ((x+1.01d0*h-xend)*posneg > 0.d0) then h=xend-x last=.true. end if nstep=nstep+1 ! --- the first 6 stages - if (irtrn.ge.2) then + if (irtrn >= 2) then call fcn(n,x,h,y,k1,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if end if - do 22 i=1,n - 22 y1(i)=y(i)+h*a21*k1(i) + do i=1,n + y1(i)=y(i)+h*a21*k1(i) + end do call fcn(n,x+c2*h,h,y1,k2,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 23 i=1,n - 23 y1(i)=y(i)+h*(a31*k1(i)+a32*k2(i)) + do i=1,n + y1(i)=y(i)+h*(a31*k1(i)+a32*k2(i)) + end do call fcn(n,x+c3*h,h,y1,k3,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 24 i=1,n - 24 y1(i)=y(i)+h*(a41*k1(i)+a42*k2(i)+a43*k3(i)) + do i=1,n + y1(i)=y(i)+h*(a41*k1(i)+a42*k2(i)+a43*k3(i)) + end do call fcn(n,x+c4*h,h,y1,k4,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 25 i=1,n - 25 y1(i)=y(i)+h*(a51*k1(i)+a52*k2(i)+a53*k3(i)+a54*k4(i)) + do i=1,n + y1(i)=y(i)+h*(a51*k1(i)+a52*k2(i)+a53*k3(i)+a54*k4(i)) + end do call fcn(n,x+c5*h,h,y1,k5,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 26 i=1,n - 26 ysti(i)=y(i)+h*(a61*k1(i)+a62*k2(i)+a63*k3(i)+a64*k4(i)+a65*k5(i)) + do i=1,n + ysti(i)=y(i)+h*(a61*k1(i)+a62*k2(i)+a63*k3(i)+a64*k4(i)+a65*k5(i)) + end do xph=x+h call fcn(n,xph,h,ysti,k6,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - do 27 i=1,n - 27 y1(i)=y(i)+h*(a71*k1(i)+a73*k3(i)+a74*k4(i)+a75*k5(i)+a76*k6(i)) + do i=1,n + y1(i)=y(i)+h*(a71*k1(i)+a73*k3(i)+a74*k4(i)+a75*k5(i)+a76*k6(i)) + end do call fcn(n,xph,h,y1,k2,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; hnew=h/facc1; h=hnew; goto 1; end if - if (iout.ge.2) then - do 40 j=1,nrd - i=icomp(j) - cont(4*nrd+j)=h*(d1*k1(i)+d3*k3(i)+d4*k4(i)+d5*k5(i) - & +d6*k6(i)+d7*k2(i)) - 40 continue + if (iout >= 2) then + do j=1,nrd + i=icomp(j) + cont(4*nrd+j)=h*(d1*k1(i)+d3*k3(i)+d4*k4(i)+d5*k5(i) + & +d6*k6(i)+d7*k2(i)) + end do end if - do 28 i=1,n - 28 k4(i)=(e1*k1(i)+e3*k3(i)+e4*k4(i)+e5*k5(i)+e6*k6(i)+e7*k2(i))*h + do i=1,n + k4(i)=(e1*k1(i)+e3*k3(i)+e4*k4(i)+e5*k5(i)+e6*k6(i)+e7*k2(i))*h + end do nfcn=nfcn+6 ! --- error estimation err=0.d0 - if (itol.eq.0) then - do 41 i=1,n - sk=atoli+rtoli*max(abs(y(i)),abs(y1(i))) - 41 err=err+pow2(k4(i)/sk) + if (itol == 0) then + do i=1,n + sk=atoli+rtoli*max(abs(y(i)),abs(y1(i))) + err=err+pow2(k4(i)/sk) + end do else - do 42 i=1,n - sk=atol(i)+rtol(i)*max(abs(y(i)),abs(y1(i))) - 42 err=err+pow2(k4(i)/sk) + do i=1,n + sk=atol(i)+rtol(i)*max(abs(y(i)),abs(y1(i))) + err=err+pow2(k4(i)/sk) + end do end if err=sqrt(err/n) ! --- computation of hnew @@ -359,50 +383,51 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, ! --- we require fac1 <= hnew/h <= fac2 fac=max(facc2,min(facc1,fac/safe)) hnew=h/fac - if(err.le.1.d0)then + if (err <= 1.d0 ) then ! --- step is accepted facold=max(err,1.0d-4) naccpt=naccpt+1 ! ------- stiffness detection - if (mod(naccpt,nstiff).eq.0.or.iasti.gt.0) then + if (mod(naccpt,nstiff) == 0.or.iasti > 0) then stnum=0.d0 stden=0.d0 - do 64 i=1,n + do i=1,n stnum=stnum+pow2(k2(i)-k6(i)) stden=stden+pow2(y1(i)-ysti(i)) - 64 continue - if (stden.gt.0.d0) hlamb=h*sqrt(stnum/stden) - if (hlamb.gt.3.25d0) then + end do + if (stden > 0.d0) hlamb=h*sqrt(stnum/stden) + if (hlamb > 3.25d0) then nonsti=0 iasti=iasti+1 - if (iasti.eq.15) then - if (lout.gt.0) write (lout,*) + if (iasti == 15) then + if (lout > 0) write (lout,*) & ' the problem seems to become stiff at x = ',x - if (lout.lt.0) goto 76 + if (lout < 0) goto 76 end if else nonsti=nonsti+1 - if (nonsti.eq.6) iasti=0 + if (nonsti == 6) iasti=0 end if end if - if (iout.ge.2) then - do 43 j=1,nrd - i=icomp(j) - yd0=y(i) - ydiff=y1(i)-yd0 - bspl=h*k1(i)-ydiff - cont(j)=y(i) - cont(nrd+j)=ydiff - cont(2*nrd+j)=bspl - cont(3*nrd+j)=-h*k2(i)+ydiff-bspl - 43 continue + if (iout >= 2) then + do j=1,nrd + i=icomp(j) + yd0=y(i) + ydiff=y1(i)-yd0 + bspl=h*k1(i)-ydiff + cont(j)=y(i) + cont(nrd+j)=ydiff + cont(2*nrd+j)=bspl + cont(3*nrd+j)=-h*k2(i)+ydiff-bspl + end do end if - do 44 i=1,n - k1(i)=k2(i) - 44 y(i)=y1(i) + do i=1,n + k1(i)=k2(i) + y(i)=y1(i) + end do xold=x x=xph - if (iout.ne.0) then + if (iout /= 0) then irtrn=1 hout=h rwork(1) = xold @@ -410,7 +435,7 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, iwork(1) = nrd iwork(2:nrd+1) = icomp(1:nrd) call solout(naccpt+1,xold,x,n,y,rwork,iwork,contd5,lrpar,rpar,lipar,ipar,irtrn) - if (irtrn.lt.0) goto 79 + if (irtrn < 0) goto 79 end if ! ------- normal exit if (last) then @@ -418,14 +443,14 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, idid=1 return end if - if(abs(hnew).gt.hmax)hnew=posneg*hmax - if(reject)hnew=posneg*min(abs(hnew),abs(h)) + if (abs(hnew) > hmax)hnew=posneg*hmax + if (reject)hnew=posneg*min(abs(hnew),abs(h)) reject=.false. else ! --- step is rejected hnew=h/min(facc1,fac11/safe) reject=.true. - if(naccpt.ge.1)nrejct=nrejct+1 + if (naccpt >= 1)nrejct=nrejct+1 last=.false. end if h=hnew @@ -435,33 +460,37 @@ subroutine dopcor(n,fcn,x,y,xend,hmax,h,rtol,atol,itol,lout, idid=-4 return 77 continue - if (lout.gt.0) write(lout,979)x - if (lout.gt.0) write(lout,*)' step size too small, h=',h + if (lout > 0) write(lout,979)x + if (lout > 0) write(lout,*)' step size too small, h=',h idid=-3 return 78 continue - if (lout.gt.0) write(lout,979)x - if (lout.gt.0) write(lout,*) + if (lout > 0) write(lout,979)x + if (lout > 0) write(lout,*) & ' more than nmax =',nmax,'steps are needed' idid=-2 return 79 continue - !if (lout.gt.0) write(lout,979)x + !if (lout > 0) write(lout,979)x 979 format(' exit of dopri5 at x=',e18.4) idid=2 return end subroutine dopcor ! - function hinit(n,fcn,x,y,xend,posneg,f0,f1,y1,iord, - & hmax,atol,rtol,itol,lrpar,rpar,lipar,ipar,ierr) + real(dp) function hinit(n,fcn,x,y,xend,posneg,f0,f1,y1,iord, + & hmax,atol,rtol,itol,lrpar,rpar,lipar,ipar,ierr) ! ---------------------------------------------------------- ! ---- computation of an initial step size guess ! ---------------------------------------------------------- - implicit real(dp) (a-h,o-z) + integer, intent(in) :: n + real(dp) :: x dimension y(n),y1(n),f0(n),f1(n),atol(*),rtol(*) integer, intent(in) :: lrpar, lipar integer, intent(inout), pointer :: ipar(:) ! (lipar) real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp) :: y, xend, posneg, f0, f1, y1, hmax, atol, rtol, atoli + real(dp) :: der2, der12, dnf, dny, h, h1, rtoli, sk + integer :: i, iord, itol, ierr, idid interface #include "num_fcn.dek" @@ -475,18 +504,20 @@ function hinit(n,fcn,x,y,xend,posneg,f0,f1,y1,iord, dny=0.0d0 atoli=atol(1) rtoli=rtol(1) - if (itol.eq.0) then - do 10 i=1,n - sk=atoli+rtoli*abs(y(i)) - dnf=dnf+pow2(f0(i)/sk) - 10 dny=dny+pow2(y(i)/sk) + if (itol == 0) then + do i=1,n + sk=atoli+rtoli*abs(y(i)) + dnf=dnf+pow2(f0(i)/sk) + dny=dny+pow2(y(i)/sk) + end do else - do 11 i=1,n - sk=atol(i)+rtol(i)*abs(y(i)) - dnf=dnf+pow2(f0(i)/sk) - 11 dny=dny+pow2(y(i)/sk) + do i=1,n + sk=atol(i)+rtol(i)*abs(y(i)) + dnf=dnf+pow2(f0(i)/sk) + dny=dny+pow2(y(i)/sk) + end do end if - if (dnf.le.1.d-10.or.dny.le.1.d-10) then + if (dnf <= 1.d-10.or.dny <= 1.d-10) then h=1.0d-6 else h=sqrt(dny/dnf)*0.01d0 @@ -494,26 +525,29 @@ function hinit(n,fcn,x,y,xend,posneg,f0,f1,y1,iord, h=min(h,hmax) h=sign(h,posneg) ! ---- perform an explicit euler step - do 12 i=1,n - 12 y1(i)=y(i)+h*f0(i) + do i=1,n + y1(i)=y(i)+h*f0(i) + end do call fcn(n,x+h,h,y1,f1,lrpar,rpar,lipar,ipar,ierr) if (ierr /= 0) then; idid=-5; return; end if ! ---- estimate the second derivative of the solution der2=0.0d0 - if (itol.eq.0) then - do 15 i=1,n - sk=atoli+rtoli*abs(y(i)) - 15 der2=der2+pow2((f1(i)-f0(i))/sk) + if (itol == 0) then + do i=1,n + sk=atoli+rtoli*abs(y(i)) + der2=der2+pow2((f1(i)-f0(i))/sk) + end do else - do 16 i=1,n - sk=atol(i)+rtol(i)*abs(y(i)) - 16 der2=der2+pow2((f1(i)-f0(i))/sk) + do i=1,n + sk=atol(i)+rtol(i)*abs(y(i)) + der2=der2+pow2((f1(i)-f0(i))/sk) + end do end if der2=sqrt(der2)/h ! ---- step size is computed such that ! ---- h**iord * max ( norm (f0), norm (der2)) = 0.01 der12=max(abs(der2),sqrt(dnf)) - if (der12.le.1.d-15) then + if (der12 <= 1.d-15) then h1=max(1.0d-6,abs(h)*1.0d-3) else h1=pow(0.01d0/der12,1.d0/iord) @@ -536,7 +570,7 @@ real(dp) function contd5(ii,x,rwork,iwork,ierr) integer, intent(inout), target :: iwork(*) integer, intent(out) :: ierr - real(dp) :: xold, h + real(dp) :: xold, h, theta, theta1 integer :: nd, i, j real(dp), pointer :: con(:) integer, pointer :: icomp(:) @@ -552,10 +586,10 @@ real(dp) function contd5(ii,x,rwork,iwork,ierr) ! ----- compute place of ii-th component i=0 - do 5 j=1,nd - if (icomp(j).eq.ii) i=j - 5 continue - if (i.eq.0) then + do j=1,nd + if (icomp(j) == ii) i=j + end do + if (i == 0) then contd5 = 0 ierr = -1 return @@ -575,7 +609,15 @@ subroutine cdopri(c2,c3,c4,c5,e1,e3,e4,e5,e6,e7, ! ---------------------------------------------------------- ! runge-kutta coefficients of dormand and prince (1980) ! ---------------------------------------------------------- - implicit real(dp) (a-h,o-z) + real(dp) :: c2, c3, c4, c5 + real(dp) :: a21 + real(dp) :: a31, a32 + real(dp) :: a41, a42, a43 + real(dp) :: a51, a52, a53, a54 + real(dp) :: a61, a62, a63, a64, a65 + real(dp) :: a71, a72, a73, a74, a75, a76 + real(dp) :: e1, e2, e3, e4, e5, e6, e7 + real(dp) :: d1, d3, d4, d5, d6, d7 c2=0.2d0 c3=0.3d0 c4=0.8d0 @@ -618,5 +660,3 @@ end subroutine cdopri end module mod_dopri5 - - diff --git a/num/private/mod_newuoa.f b/num/private/mod_newuoa.f index c7e23b9fd..8a2d6678b 100644 --- a/num/private/mod_newuoa.f +++ b/num/private/mod_newuoa.f @@ -5,10 +5,7 @@ module mod_newuoa contains - - - SUBROUTINE do_newuoa (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W, - > CALFUN,max_valid_value) + SUBROUTINE do_newuoa(N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W,CALFUN,max_valid_value) IMPLICIT real(dp) (A-H,O-Z) DIMENSION X(*),W(*) interface @@ -51,10 +48,9 @@ SUBROUTINE do_newuoa (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W, ! NP=N+1 NPTM=NPT-NP - IF (NPT .LT. N+2 .OR. NPT .GT. ((N+2)*NP)/2) THEN + IF (NPT < N+2 .OR. NPT > ((N+2)*NP)/2) THEN PRINT 10 - 10 FORMAT (/4X,'Return from NEWUOA because NPT is not in', - 1 ' the required interval') + 10 FORMAT (/4X,'Return from NEWUOA because NPT is not in the required interval') GO TO 20 END IF NDIM=NPT+N @@ -133,18 +129,24 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! ! Set the initial elements of XPT, BMAT, HQ, PQ and ZMAT to zero. ! - DO 20 J=1,N - XBASE(J)=X(J) - DO 10 K=1,NPT - 10 XPT(K,J)=ZERO - DO 20 I=1,NDIM - 20 BMAT(I,J)=ZERO - DO 30 IH=1,NH - 30 HQ(IH)=ZERO - DO 40 K=1,NPT - PQ(K)=ZERO - DO 40 J=1,NPTM - 40 ZMAT(K,J)=ZERO + DO J=1,N + XBASE(J)=X(J) + DO K=1,NPT + XPT(K,J)=ZERO + END DO + DO I=1,NDIM + BMAT(I,J)=ZERO + END DO + END DO + DO IH=1,NH + HQ(IH)=ZERO + END DO + DO K=1,NPT + PQ(K)=ZERO + DO J=1,NPTM + ZMAT(K,J)=ZERO + END DO + END DO ! ! Begin the initialization procedure. NF becomes one more than the number ! of function values so far. The coordinates of the displacement of the @@ -157,25 +159,25 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, 50 NFM=NF NFMM=NF-N NF=NF+1 - IF (NFM .LE. 2*N) THEN - IF (NFM .GE. 1 .AND. NFM .LE. N) THEN + IF (NFM <= 2*N) THEN + IF (NFM >= 1 .AND. NFM <= N) THEN XPT(NF,NFM)=RHOBEG - ELSE IF (NFM .GT. N) THEN + ELSE IF (NFM > N) THEN XPT(NF,NFMM)=-RHOBEG END IF ELSE ITEMP=(NFMM-1)/N JPT=NFM-ITEMP*N-N IPT=JPT+ITEMP - IF (IPT .GT. N) THEN + IF (IPT > N) THEN ITEMP=JPT JPT=IPT-N IPT=ITEMP END IF XIPT=RHOBEG - IF (FVAL(IPT+NP) .LT. FVAL(IPT+1)) XIPT=-XIPT + IF (FVAL(IPT+NP) < FVAL(IPT+1)) XIPT=-XIPT XJPT=RHOBEG - IF (FVAL(JPT+NP) .LT. FVAL(JPT+1)) XJPT=-XJPT + IF (FVAL(JPT+NP) < FVAL(JPT+1)) XJPT=-XJPT XPT(NF,IPT)=XIPT XPT(NF,JPT)=XJPT END IF @@ -184,15 +186,16 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! after this calculation. The least function value so far and its index ! are required. ! - DO 60 J=1,N - 60 X(J)=XPT(NF,J)+XBASE(J) + DO J=1,N + X(J)=XPT(NF,J)+XBASE(J) + END DO GOTO 310 70 FVAL(NF)=F - IF (NF .EQ. 1) THEN + IF (NF == 1) THEN FBEG=F FOPT=F KOPT=1 - ELSE IF (F .LT. FOPT) THEN + ELSE IF (F < FOPT) THEN FOPT=F KOPT=NF END IF @@ -200,15 +203,15 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! Set the nonzero initial elements of BMAT and the quadratic model in ! the cases when NF is at most 2*N+1. ! - IF (NFM .LE. 2*N) THEN - IF (NFM .GE. 1 .AND. NFM .LE. N) THEN + IF (NFM <= 2*N) THEN + IF (NFM >= 1 .AND. NFM <= N) THEN GQ(NFM)=(F-FBEG)/RHOBEG - IF (NPT .LT. NF+N) THEN + IF (NPT < NF+N) THEN BMAT(1,NFM)=-ONE/RHOBEG BMAT(NF,NFM)=ONE/RHOBEG BMAT(NPT+NFM,NFM)=-HALF*RHOSQ END IF - ELSE IF (NFM .GT. N) THEN + ELSE IF (NFM > N) THEN BMAT(NF-N,NFMM)=HALF/RHOBEG BMAT(NF,NFMM)=-HALF/RHOBEG ZMAT(1,NFMM)=-RECIQ-RECIQ @@ -225,15 +228,15 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! ELSE IH=(IPT*(IPT-1))/2+JPT - IF (XIPT .LT. ZERO) IPT=IPT+N - IF (XJPT .LT. ZERO) JPT=JPT+N + IF (XIPT < ZERO) IPT=IPT+N + IF (XJPT < ZERO) JPT=JPT+N ZMAT(1,NFMM)=RECIP ZMAT(NF,NFMM)=RECIP ZMAT(IPT+1,NFMM)=-RECIP ZMAT(JPT+1,NFMM)=-RECIP HQ(IH)=(FBEG-FVAL(IPT+1)-FVAL(JPT+1)+F)/(XIPT*XJPT) END IF - IF (NF .LT. NPT) GOTO 50 + IF (NF < NPT) GOTO 50 ! ! Begin the iterative procedure, because the initial model is complete. ! @@ -244,93 +247,109 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, DIFFB=ZERO ITEST=0 XOPTSQ=ZERO - DO 80 I=1,N - XOPT(I)=XPT(KOPT,I) - 80 XOPTSQ=XOPTSQ+XOPT(I)**2 + DO I=1,N + XOPT(I)=XPT(KOPT,I) + XOPTSQ=XOPTSQ+XOPT(I)**2 + END DO 90 NFSAV=NF ! ! Generate the next trust region step and test its length. Set KNEW ! to -1 if the purpose of the next F will be to improve the model. ! 100 KNEW=0 - CALL TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,D,W,W(NP), - 1 W(NP+N),W(NP+2*N),CRVMIN) + CALL TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,D,W,W(NP),W(NP+N),W(NP+2*N),CRVMIN) DSQ=ZERO - DO 110 I=1,N - 110 DSQ=DSQ+D(I)**2 + DO I=1,N + DSQ=DSQ+D(I)**2 + END DO DNORM=DMIN1(DELTA,DSQRT(DSQ)) - IF (DNORM .LT. HALF*RHO) THEN + IF (DNORM < HALF*RHO) THEN KNEW=-1 DELTA=TENTH*DELTA RATIO=-1.0D0 - IF (DELTA .LE. 1.5D0*RHO) DELTA=RHO - IF (NF .LE. NFSAV+2) GOTO 460 + IF (DELTA <= 1.5D0*RHO) DELTA=RHO + IF (NF <= NFSAV+2) GOTO 460 TEMP=0.125D0*CRVMIN*RHO*RHO - IF (TEMP .LE. DMAX1(DIFFA,DIFFB,DIFFC)) GOTO 460 + IF (TEMP <= DMAX1(DIFFA,DIFFB,DIFFC)) GOTO 460 GOTO 490 END IF ! ! Shift XBASE if XOPT may be too far from XBASE. First make the changes ! to BMAT that do not depend on ZMAT. ! - 120 IF (DSQ .LE. 1.0D-3*XOPTSQ) THEN + 120 IF (DSQ <= 1.0D-3*XOPTSQ) THEN TEMPQ=0.25D0*XOPTSQ - DO 140 K=1,NPT - SUM=ZERO - DO 130 I=1,N - 130 SUM=SUM+XPT(K,I)*XOPT(I) - TEMP=PQ(K)*SUM - SUM=SUM-HALF*XOPTSQ - W(NPT+K)=SUM - DO 140 I=1,N - GQ(I)=GQ(I)+TEMP*XPT(K,I) - XPT(K,I)=XPT(K,I)-HALF*XOPT(I) - VLAG(I)=BMAT(K,I) - W(I)=SUM*XPT(K,I)+TEMPQ*XOPT(I) - IP=NPT+I - DO 140 J=1,I - 140 BMAT(IP,J)=BMAT(IP,J)+VLAG(I)*W(J)+W(I)*VLAG(J) + DO K=1,NPT + SUM=ZERO + DO I=1,N + SUM=SUM+XPT(K,I)*XOPT(I) + END DO + TEMP=PQ(K)*SUM + SUM=SUM-HALF*XOPTSQ + W(NPT+K)=SUM + DO I=1,N + GQ(I)=GQ(I)+TEMP*XPT(K,I) + XPT(K,I)=XPT(K,I)-HALF*XOPT(I) + VLAG(I)=BMAT(K,I) + W(I)=SUM*XPT(K,I)+TEMPQ*XOPT(I) + IP=NPT+I + DO J=1,I + BMAT(IP,J)=BMAT(IP,J)+VLAG(I)*W(J)+W(I)*VLAG(J) + END DO + END DO + END DO ! ! Then the revisions of BMAT that depend on ZMAT are calculated. ! - DO 180 K=1,NPTM - SUMZ=ZERO - DO 150 I=1,NPT - SUMZ=SUMZ+ZMAT(I,K) - 150 W(I)=W(NPT+I)*ZMAT(I,K) - DO 170 J=1,N - SUM=TEMPQ*SUMZ*XOPT(J) - DO 160 I=1,NPT - 160 SUM=SUM+W(I)*XPT(I,J) - VLAG(J)=SUM - IF (K .LT. IDZ) SUM=-SUM - DO 170 I=1,NPT - 170 BMAT(I,J)=BMAT(I,J)+SUM*ZMAT(I,K) - DO 180 I=1,N - IP=I+NPT - TEMP=VLAG(I) - IF (K .LT. IDZ) TEMP=-TEMP - DO 180 J=1,I - 180 BMAT(IP,J)=BMAT(IP,J)+TEMP*VLAG(J) + DO K=1,NPTM + SUMZ=ZERO + DO I=1,NPT + SUMZ=SUMZ+ZMAT(I,K) + W(I)=W(NPT+I)*ZMAT(I,K) + END DO + DO J=1,N + SUM=TEMPQ*SUMZ*XOPT(J) + DO I=1,NPT + SUM=SUM+W(I)*XPT(I,J) + END DO + VLAG(J)=SUM + IF (K < IDZ) SUM=-SUM + DO I=1,NPT + BMAT(I,J)=BMAT(I,J)+SUM*ZMAT(I,K) + END DO + END DO + DO I=1,N + IP=I+NPT + TEMP=VLAG(I) + IF (K < IDZ) TEMP=-TEMP + DO J=1,I + BMAT(IP,J)=BMAT(IP,J)+TEMP*VLAG(J) + END DO + END DO + END DO ! ! The following instructions complete the shift of XBASE, including ! the changes to the parameters of the quadratic model. ! IH=0 - DO 200 J=1,N - W(J)=ZERO - DO 190 K=1,NPT - W(J)=W(J)+PQ(K)*XPT(K,J) - 190 XPT(K,J)=XPT(K,J)-HALF*XOPT(J) - DO 200 I=1,J - IH=IH+1 - IF (I .LT. J) GQ(J)=GQ(J)+HQ(IH)*XOPT(I) - GQ(I)=GQ(I)+HQ(IH)*XOPT(J) - HQ(IH)=HQ(IH)+W(I)*XOPT(J)+XOPT(I)*W(J) - 200 BMAT(NPT+I,J)=BMAT(NPT+J,I) - DO 210 J=1,N - XBASE(J)=XBASE(J)+XOPT(J) - 210 XOPT(J)=ZERO + DO J=1,N + W(J)=ZERO + DO K=1,NPT + W(J)=W(J)+PQ(K)*XPT(K,J) + XPT(K,J)=XPT(K,J)-HALF*XOPT(J) + END DO + DO I=1,J + IH=IH+1 + IF (I < J) GQ(J)=GQ(J)+HQ(IH)*XOPT(I) + GQ(I)=GQ(I)+HQ(IH)*XOPT(J) + HQ(IH)=HQ(IH)+W(I)*XOPT(J)+XOPT(I)*W(J) + BMAT(NPT+I,J)=BMAT(NPT+J,I) + END DO + END DO + DO J=1,N + XBASE(J)=XBASE(J)+XOPT(J) + XOPT(J)=ZERO + END DO XOPTSQ=ZERO END IF ! @@ -338,50 +357,57 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! may be made later, if the choice of D by BIGLAG causes substantial ! cancellation in DENOM. ! - IF (KNEW .GT. 0) THEN - CALL BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW,DSTEP, - 1 D,ALPHA,VLAG,VLAG(NPT+1),W,W(NP),W(NP+N)) + IF (KNEW > 0) THEN + CALL BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW,DSTEP,D,ALPHA,VLAG,VLAG(NPT+1),W,W(NP),W(NP+N)) END IF ! ! Calculate VLAG and BETA for the current choice of D. The first NPT ! components of W_check will be held in W. ! - DO 230 K=1,NPT - SUMA=ZERO - SUMB=ZERO - SUM=ZERO - DO 220 J=1,N - SUMA=SUMA+XPT(K,J)*D(J) - SUMB=SUMB+XPT(K,J)*XOPT(J) - 220 SUM=SUM+BMAT(K,J)*D(J) - W(K)=SUMA*(HALF*SUMA+SUMB) - 230 VLAG(K)=SUM + DO K=1,NPT + SUMA=ZERO + SUMB=ZERO + SUM=ZERO + DO J=1,N + SUMA=SUMA+XPT(K,J)*D(J) + SUMB=SUMB+XPT(K,J)*XOPT(J) + SUM=SUM+BMAT(K,J)*D(J) + END DO + W(K)=SUMA*(HALF*SUMA+SUMB) + VLAG(K)=SUM + END DO BETA=ZERO - DO 250 K=1,NPTM - SUM=ZERO - DO 240 I=1,NPT - 240 SUM=SUM+ZMAT(I,K)*W(I) - IF (K .LT. IDZ) THEN - BETA=BETA+SUM*SUM - SUM=-SUM - ELSE - BETA=BETA-SUM*SUM - END IF - DO 250 I=1,NPT - 250 VLAG(I)=VLAG(I)+SUM*ZMAT(I,K) + DO K=1,NPTM + SUM=ZERO + DO I=1,NPT + SUM=SUM+ZMAT(I,K)*W(I) + END DO + IF (K < IDZ) THEN + BETA=BETA+SUM*SUM + SUM=-SUM + ELSE + BETA=BETA-SUM*SUM + END IF + DO I=1,NPT + VLAG(I)=VLAG(I)+SUM*ZMAT(I,K) + END DO + END DO BSUM=ZERO DX=ZERO - DO 280 J=1,N - SUM=ZERO - DO 260 I=1,NPT - 260 SUM=SUM+W(I)*BMAT(I,J) - BSUM=BSUM+SUM*D(J) - JP=NPT+J - DO 270 K=1,N - 270 SUM=SUM+BMAT(JP,K)*D(K) - VLAG(JP)=SUM - BSUM=BSUM+SUM*D(J) - 280 DX=DX+D(J)*XOPT(J) + DO J=1,N + SUM=ZERO + DO I=1,NPT + SUM=SUM+W(I)*BMAT(I,J) + END DO + BSUM=BSUM+SUM*D(J) + JP=NPT+J + DO K=1,N + SUM=SUM+BMAT(JP,K)*D(K) + END DO + VLAG(JP)=SUM + BSUM=BSUM+SUM*D(J) + DX=DX+D(J)*XOPT(J) + END DO BETA=DX*DX+DSQ*(XOPTSQ+DX+DX+HALF*DSQ)+BETA-BSUM VLAG(KOPT)=VLAG(KOPT)+ONE ! @@ -389,9 +415,9 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! then BIGDEN calculates an alternative model step, XNEW being used for ! working space. ! - IF (KNEW .GT. 0) THEN + IF (KNEW > 0) THEN TEMP=ONE+ALPHA*BETA/VLAG(KNEW)**2 - IF (DABS(TEMP) .LE. 0.8D0) THEN + IF (DABS(TEMP) <= 0.8D0) THEN CALL BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, 1 KNEW,D,W,VLAG,BETA,XNEW,W(NDIM+1),W(6*NDIM+1)) END IF @@ -399,105 +425,109 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! ! Calculate the next value of the objective function. ! - 290 DO 300 I=1,N - XNEW(I)=XOPT(I)+D(I) - 300 X(I)=XBASE(I)+XNEW(I) + 290 DO I=1,N + XNEW(I)=XOPT(I)+D(I) + X(I)=XBASE(I)+XNEW(I) + END DO NF=NF+1 - 310 IF (NF .GT. NFTEST) THEN + 310 IF (NF > NFTEST) THEN NF=NF-1 - IF (IPRINT .GT. 0) PRINT 320 - 320 FORMAT (/4X,'Return from NEWUOA because CALFUN has been', - 1 ' called MAXFUN times.') + IF (IPRINT > 0) PRINT 320 + 320 FORMAT (/4X,'Return from NEWUOA because CALFUN has been called MAXFUN times.') GOTO 530 END IF CALL CALFUN (N,X,F) - IF (IPRINT .EQ. 3) THEN - PRINT 330, NF,F,(X(I),I=1,N) - 330 FORMAT (/4X,'Function number',I6,' F =',1PD18.10, - 1 ' The corresponding X is:'/(2X,5D15.6)) + IF (IPRINT == 3) THEN + PRINT 330, NF,F,(X(I),I=1,N) + 330 FORMAT (/4X,'Function number',I6,' F =',1PD18.10,' The corresponding X is:'/(2X,5D15.6)) END IF - IF (NF .LE. NPT) GOTO 70 - IF (KNEW .EQ. -1) GOTO 530 + IF (NF <= NPT) GOTO 70 + IF (KNEW == -1) GOTO 530 ! ! Use the quadratic model to predict the change in F due to the step D, ! and set DIFF to the error of this prediction. ! VQUAD=ZERO IH=0 - DO 340 J=1,N - VQUAD=VQUAD+D(J)*GQ(J) - DO 340 I=1,J - IH=IH+1 - TEMP=D(I)*XNEW(J)+D(J)*XOPT(I) - IF (I .EQ. J) TEMP=HALF*TEMP - 340 VQUAD=VQUAD+TEMP*HQ(IH) - DO 350 K=1,NPT - 350 VQUAD=VQUAD+PQ(K)*W(K) + DO J=1,N + VQUAD=VQUAD+D(J)*GQ(J) + DO I=1,J + IH=IH+1 + TEMP=D(I)*XNEW(J)+D(J)*XOPT(I) + IF (I == J) TEMP=HALF*TEMP + VQUAD=VQUAD+TEMP*HQ(IH) + END DO + END DO + DO K=1,NPT + VQUAD=VQUAD+PQ(K)*W(K) + END DO DIFF=F-FOPT-VQUAD DIFFC=DIFFB DIFFB=DIFFA DIFFA=DABS(DIFF) - IF (DNORM .GT. RHO) NFSAV=NF + IF (DNORM > RHO) NFSAV=NF ! ! Update FOPT and XOPT if the new F is the least value of the objective ! function so far. The branch when KNEW is positive occurs if D is not ! a trust region step. ! FSAVE=FOPT - IF (F .LT. FOPT) THEN - FOPT=F - XOPTSQ=ZERO - DO 360 I=1,N - XOPT(I)=XNEW(I) - 360 XOPTSQ=XOPTSQ+XOPT(I)**2 + IF (F < FOPT) THEN + FOPT=F + XOPTSQ=ZERO + DO I=1,N + XOPT(I)=XNEW(I) + XOPTSQ=XOPTSQ+XOPT(I)**2 + END DO END IF KSAVE=KNEW - IF (KNEW .GT. 0) GOTO 410 + IF (KNEW > 0) GOTO 410 ! ! Pick the next value of DELTA after a trust region step. ! - IF (VQUAD .GE. ZERO) THEN - IF (IPRINT .GT. 0) PRINT 370 - 370 FORMAT (/4X,'Return from NEWUOA because a trust', - 1 ' region step has failed to reduce Q.') + IF (VQUAD >= ZERO) THEN + IF (IPRINT > 0) PRINT 370 + 370 FORMAT (/4X,'Return from NEWUOA because a trust region step has failed to reduce Q.') GOTO 530 END IF RATIO=(F-FSAVE)/VQUAD - IF (RATIO .LE. TENTH) THEN + IF (RATIO <= TENTH) THEN DELTA=HALF*DNORM ELSE IF (RATIO. LE. 0.7D0) THEN DELTA=DMAX1(HALF*DELTA,DNORM) ELSE DELTA=DMAX1(HALF*DELTA,DNORM+DNORM) END IF - IF (DELTA .LE. 1.5D0*RHO) DELTA=RHO + IF (DELTA <= 1.5D0*RHO) DELTA=RHO ! ! Set KNEW to the index of the next interpolation point to be deleted. ! RHOSQ=DMAX1(TENTH*DELTA,RHO)**2 KTEMP=0 DETRAT=ZERO - IF (F .GE. FSAVE) THEN + IF (F >= FSAVE) THEN KTEMP=KOPT DETRAT=ONE END IF - DO 400 K=1,NPT - HDIAG=ZERO - DO 380 J=1,NPTM - TEMP=ONE - IF (J .LT. IDZ) TEMP=-ONE - 380 HDIAG=HDIAG+TEMP*ZMAT(K,J)**2 - TEMP=DABS(BETA*HDIAG+VLAG(K)**2) - DISTSQ=ZERO - DO 390 J=1,N - 390 DISTSQ=DISTSQ+(XPT(K,J)-XOPT(J))**2 - IF (DISTSQ .GT. RHOSQ) TEMP=TEMP*(DISTSQ/RHOSQ)*(DISTSQ/RHOSQ)*(DISTSQ/RHOSQ) - IF (TEMP .GT. DETRAT .AND. K .NE. KTEMP) THEN - DETRAT=TEMP - KNEW=K - END IF - 400 CONTINUE - IF (KNEW .EQ. 0) GOTO 460 + DO K=1,NPT + HDIAG=ZERO + DO J=1,NPTM + TEMP=ONE + IF (J < IDZ) TEMP=-ONE + HDIAG=HDIAG+TEMP*ZMAT(K,J)**2 + END DO + TEMP=DABS(BETA*HDIAG+VLAG(K)**2) + DISTSQ=ZERO + DO J=1,N + DISTSQ=DISTSQ+(XPT(K,J)-XOPT(J))**2 + END DO + IF (DISTSQ > RHOSQ) TEMP=TEMP*(DISTSQ/RHOSQ)*(DISTSQ/RHOSQ)*(DISTSQ/RHOSQ) + IF (TEMP > DETRAT .AND. K /= KTEMP) THEN + DETRAT=TEMP + KNEW=K + END IF + END DO + IF (KNEW == 0) GOTO 460 ! ! Update BMAT, ZMAT and IDZ, so that the KNEW-th interpolation point ! can be moved. Begin the updating of the quadratic model, starting @@ -506,51 +536,59 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, 410 CALL UPDATE (N,NPT,BMAT,ZMAT,IDZ,NDIM,VLAG,BETA,KNEW,W) FVAL(KNEW)=F IH=0 - DO 420 I=1,N - TEMP=PQ(KNEW)*XPT(KNEW,I) - DO 420 J=1,I - IH=IH+1 - 420 HQ(IH)=HQ(IH)+TEMP*XPT(KNEW,J) + DO I=1,N + TEMP=PQ(KNEW)*XPT(KNEW,I) + DO J=1,I + IH=IH+1 + HQ(IH)=HQ(IH)+TEMP*XPT(KNEW,J) + END DO + END DO PQ(KNEW)=ZERO ! ! Update the other second derivative parameters, and then the gradient ! vector of the model. Also include the new interpolation point. ! - DO 440 J=1,NPTM - TEMP=DIFF*ZMAT(KNEW,J) - IF (J .LT. IDZ) TEMP=-TEMP - DO 440 K=1,NPT - 440 PQ(K)=PQ(K)+TEMP*ZMAT(K,J) + DO J=1,NPTM + TEMP=DIFF*ZMAT(KNEW,J) + IF (J < IDZ) TEMP=-TEMP + DO K=1,NPT + PQ(K)=PQ(K)+TEMP*ZMAT(K,J) + END DO + END DO GQSQ=ZERO - DO 450 I=1,N - GQ(I)=GQ(I)+DIFF*BMAT(KNEW,I) - GQSQ=GQSQ+GQ(I)**2 - 450 XPT(KNEW,I)=XNEW(I) + DO I=1,N + GQ(I)=GQ(I)+DIFF*BMAT(KNEW,I) + GQSQ=GQSQ+GQ(I)**2 + XPT(KNEW,I)=XNEW(I) + END DO ! ! If a trust region step makes a small change to the objective function, ! then calculate the gradient of the least Frobenius norm interpolant at ! XBASE, and store it in W, using VLAG for a vector of right hand sides. ! - IF (KSAVE .EQ. 0 .AND. DELTA .EQ. RHO) THEN - IF (DABS(RATIO) .GT. 1.0D-2) THEN + IF (KSAVE == 0 .AND. DELTA == RHO) THEN + IF (DABS(RATIO) > 1.0D-2) THEN ITEST=0 ELSE - DO 700 K=1,NPT - 700 VLAG(K)=FVAL(K)-FVAL(KOPT) + DO K=1,NPT + VLAG(K)=FVAL(K)-FVAL(KOPT) + END DO GISQ=ZERO - DO 720 I=1,N - SUM=ZERO - DO 710 K=1,NPT - 710 SUM=SUM+BMAT(K,I)*VLAG(K) - GISQ=GISQ+SUM*SUM - 720 W(I)=SUM + DO I=1,N + SUM=ZERO + DO K=1,NPT + SUM=SUM+BMAT(K,I)*VLAG(K) + END DO + GISQ=GISQ+SUM*SUM + W(I)=SUM + END DO ! ! Test whether to replace the new quadratic model by the least Frobenius ! norm interpolant, making the replacement if the test is satisfied. ! ITEST=ITEST+1 - IF (GQSQ .LT. 1.0D2*GISQ) ITEST=0 - do_replace = (ITEST .GE. 3) + IF (GQSQ < 1.0D2*GISQ) ITEST=0 + do_replace = (ITEST >= 3) if (.not. do_replace) then ! check for "invalid" value do k=1,npt if (fval(k) > max_valid_value) then @@ -561,81 +599,86 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, end do end if IF (do_replace) THEN - DO 730 I=1,N - 730 GQ(I)=W(I) - DO 740 IH=1,NH - 740 HQ(IH)=ZERO - DO 760 J=1,NPTM - W(J)=ZERO - DO 750 K=1,NPT - 750 W(J)=W(J)+VLAG(K)*ZMAT(K,J) - 760 IF (J .LT. IDZ) W(J)=-W(J) - DO 770 K=1,NPT - PQ(K)=ZERO - DO 770 J=1,NPTM - 770 PQ(K)=PQ(K)+ZMAT(K,J)*W(J) + DO I=1,N + GQ(I)=W(I) + END DO + DO IH=1,NH + HQ(IH)=ZERO + END DO + DO J=1,NPTM + W(J)=ZERO + DO K=1,NPT + W(J)=W(J)+VLAG(K)*ZMAT(K,J) + END DO + IF (J < IDZ) W(J)=-W(J) + END DO + DO K=1,NPT + PQ(K)=ZERO + DO J=1,NPTM + PQ(K)=PQ(K)+ZMAT(K,J)*W(J) + END DO + END DO ITEST=0 END IF END IF END IF - IF (F .LT. FSAVE) KOPT=KNEW + IF (F < FSAVE) KOPT=KNEW ! ! If a trust region step has provided a sufficient decrease in F, then ! branch for another trust region calculation. The case KSAVE>0 occurs ! when the new function value was calculated by a model step. ! - IF (F .LE. FSAVE+TENTH*VQUAD) GOTO 100 - IF (KSAVE .GT. 0) GOTO 100 + IF (F <= FSAVE+TENTH*VQUAD) GOTO 100 + IF (KSAVE > 0) GOTO 100 ! ! Alternatively, find out if the interpolation points are close enough ! to the best point so far. ! KNEW=0 460 DISTSQ=4.0D0*DELTA*DELTA - DO 480 K=1,NPT - SUM=ZERO - DO 470 J=1,N - 470 SUM=SUM+(XPT(K,J)-XOPT(J))**2 - IF (SUM .GT. DISTSQ) THEN - KNEW=K - DISTSQ=SUM - END IF - 480 CONTINUE + DO K=1,NPT + SUM=ZERO + DO J=1,N + SUM=SUM+(XPT(K,J)-XOPT(J))**2 + END DO + IF (SUM > DISTSQ) THEN + KNEW=K + DISTSQ=SUM + END IF + END DO ! ! If KNEW is positive, then set DSTEP, and branch back for the next ! iteration, which will generate a "model step". ! - IF (KNEW .GT. 0) THEN + IF (KNEW > 0) THEN DSTEP=DMAX1(DMIN1(TENTH*DSQRT(DISTSQ),HALF*DELTA),RHO) DSQ=DSTEP*DSTEP GOTO 120 END IF - IF (RATIO .GT. ZERO) GOTO 100 - IF (DMAX1(DELTA,DNORM) .GT. RHO) GOTO 100 + IF (RATIO > ZERO) GOTO 100 + IF (DMAX1(DELTA,DNORM) > RHO) GOTO 100 ! ! The calculations with the current value of RHO are complete. Pick the ! next values of RHO and DELTA. ! - 490 IF (RHO .GT. RHOEND) THEN + 490 IF (RHO > RHOEND) THEN DELTA=HALF*RHO RATIO=RHO/RHOEND - IF (RATIO .LE. 16.0D0) THEN + IF (RATIO <= 16.0D0) THEN RHO=RHOEND - ELSE IF (RATIO .LE. 250.0D0) THEN + ELSE IF (RATIO <= 250.0D0) THEN RHO=DSQRT(RATIO)*RHOEND ELSE RHO=TENTH*RHO END IF DELTA=DMAX1(DELTA,RHO) - IF (IPRINT .GE. 2) THEN - IF (IPRINT .GE. 3) PRINT 500 + IF (IPRINT >= 2) THEN + IF (IPRINT >= 3) PRINT 500 500 FORMAT (5X) PRINT 510, RHO,NF - 510 FORMAT (/4X,'New RHO =',1PD11.4,5X,'Number of', - 1 ' function values =',I6) + 510 FORMAT (/4X,'New RHO =',1PD11.4,5X,'Number of function values =',I6) PRINT 520, FOPT,(XBASE(I)+XOPT(I),I=1,N) - 520 FORMAT (4X,'Least value of F =',1PD23.15,9X, - 1 'The corresponding X is:'/(2X,5D15.6)) + 520 FORMAT (4X,'Least value of F =',1PD23.15,9X,'The corresponding X is:'/(2X,5D15.6)) END IF GOTO 90 END IF @@ -643,23 +686,22 @@ SUBROUTINE NEWUOB (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,XBASE, ! Return from the calculation, after another Newton-Raphson step, if ! it is too short to have been tried before. ! - IF (KNEW .EQ. -1) GOTO 290 - 530 IF (FOPT .LE. F) THEN - DO 540 I=1,N - 540 X(I)=XBASE(I)+XOPT(I) + IF (KNEW == -1) GOTO 290 + 530 IF (FOPT <= F) THEN + DO I=1,N + X(I)=XBASE(I)+XOPT(I) + END DO F=FOPT END IF - IF (IPRINT .GE. 1) THEN + IF (IPRINT >= 1) THEN PRINT 550, NF - 550 FORMAT (/4X,'At the return from NEWUOA',5X, - 1 'Number of function values =',I6) + 550 FORMAT (/4X,'At the return from NEWUOA',5X,'Number of function values =',I6) PRINT 520, F,(X(I),I=1,N) END IF RETURN END SUBROUTINE NEWUOB - SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, - 1 KNEW,D,W,VLAG,BETA,S,WVEC,PROD) + SUBROUTINE BIGDEN(N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT,KNEW,D,W,VLAG,BETA,S,WVEC,PROD) IMPLICIT real(dp) (A-H,O-Z) DIMENSION XOPT(*),XPT(NPT,*),BMAT(NDIM,*),ZMAT(NPT,*),D(*), 1 W(*),VLAG(*),S(*),WVEC(NDIM,*),PROD(NDIM,*) @@ -701,13 +743,16 @@ SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, ! Store the first NPT elements of the KNEW-th column of H in W(N+1) ! to W(N+NPT). ! - DO 10 K=1,NPT - 10 W(N+K)=ZERO - DO 20 J=1,NPTM - TEMP=ZMAT(KNEW,J) - IF (J .LT. IDZ) TEMP=-TEMP - DO 20 K=1,NPT - 20 W(N+K)=W(N+K)+TEMP*ZMAT(K,J) + DO K=1,NPT + W(N+K)=ZERO + END DO + DO J=1,NPTM + TEMP=ZMAT(KNEW,J) + IF (J < IDZ) TEMP=-TEMP + DO K=1,NPT + W(N+K)=W(N+K)+TEMP*ZMAT(K,J) + END DO + END DO ALPHA=W(N+KNEW) ! ! The initial search direction D is taken from the last call of BIGLAG, @@ -719,33 +764,36 @@ SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, DS=ZERO SS=ZERO XOPTSQ=ZERO - DO 30 I=1,N - DD=DD+D(I)**2 - S(I)=XPT(KNEW,I)-XOPT(I) - DS=DS+D(I)*S(I) - SS=SS+S(I)**2 - 30 XOPTSQ=XOPTSQ+XOPT(I)**2 - IF (DS*DS .GT. 0.99D0*DD*SS) THEN + DO I=1,N + DD=DD+D(I)**2 + S(I)=XPT(KNEW,I)-XOPT(I) + DS=DS+D(I)*S(I) + SS=SS+S(I)**2 + XOPTSQ=XOPTSQ+XOPT(I)**2 + END DO + IF (DS*DS > 0.99D0*DD*SS) THEN KSAV=KNEW DTEST=DS*DS/SS - DO 50 K=1,NPT - IF (K .NE. KOPT) THEN - DSTEMP=ZERO - SSTEMP=ZERO - DO 40 I=1,N - DIFF=XPT(K,I)-XOPT(I) - DSTEMP=DSTEMP+D(I)*DIFF - 40 SSTEMP=SSTEMP+DIFF*DIFF - IF (DSTEMP*DSTEMP/SSTEMP .LT. DTEST) THEN - KSAV=K - DTEST=DSTEMP*DSTEMP/SSTEMP - DS=DSTEMP - SS=SSTEMP - END IF - END IF - 50 CONTINUE - DO 60 I=1,N - 60 S(I)=XPT(KSAV,I)-XOPT(I) + DO K=1,NPT + IF (K /= KOPT) THEN + DSTEMP=ZERO + SSTEMP=ZERO + DO I=1,N + DIFF=XPT(K,I)-XOPT(I) + DSTEMP=DSTEMP+D(I)*DIFF + SSTEMP=SSTEMP+DIFF*DIFF + END DO + IF (DSTEMP*DSTEMP/SSTEMP < DTEST) THEN + KSAV=K + DTEST=DSTEMP*DSTEMP/SSTEMP + DS=DSTEMP + SS=SSTEMP + END IF + END IF + END DO + DO I=1,N + S(I)=XPT(KSAV,I)-XOPT(I) + END DO END IF SSDEN=DD*SS-DS*DS ITERC=0 @@ -758,10 +806,11 @@ SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, TEMP=ONE/DSQRT(SSDEN) XOPTD=ZERO XOPTS=ZERO - DO 80 I=1,N - S(I)=TEMP*(DD*S(I)-DS*D(I)) - XOPTD=XOPTD+XOPT(I)*D(I) - 80 XOPTS=XOPTS+XOPT(I)*S(I) + DO I=1,N + S(I)=TEMP*(DD*S(I)-DS*D(I)) + XOPTD=XOPTD+XOPT(I)*D(I) + XOPTS=XOPTS+XOPT(I)*S(I) + END DO ! ! Set the coefficients of the first two terms of BETA. ! @@ -772,92 +821,108 @@ SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, DEN(3)=TWO*XOPTS*DD DEN(4)=TEMPA-TEMPB DEN(5)=XOPTD*XOPTS - DO 90 I=6,9 - 90 DEN(I)=ZERO + DO I=6,9 + DEN(I)=ZERO + END DO ! ! Put the coefficients of Wcheck in WVEC. ! - DO 110 K=1,NPT - TEMPA=ZERO - TEMPB=ZERO - TEMPC=ZERO - DO 100 I=1,N - TEMPA=TEMPA+XPT(K,I)*D(I) - TEMPB=TEMPB+XPT(K,I)*S(I) - 100 TEMPC=TEMPC+XPT(K,I)*XOPT(I) - WVEC(K,1)=QUART*(TEMPA*TEMPA+TEMPB*TEMPB) - WVEC(K,2)=TEMPA*TEMPC - WVEC(K,3)=TEMPB*TEMPC - WVEC(K,4)=QUART*(TEMPA*TEMPA-TEMPB*TEMPB) - 110 WVEC(K,5)=HALF*TEMPA*TEMPB - DO 120 I=1,N - IP=I+NPT - WVEC(IP,1)=ZERO - WVEC(IP,2)=D(I) - WVEC(IP,3)=S(I) - WVEC(IP,4)=ZERO - 120 WVEC(IP,5)=ZERO + DO K=1,NPT + TEMPA=ZERO + TEMPB=ZERO + TEMPC=ZERO + DO I=1,N + TEMPA=TEMPA+XPT(K,I)*D(I) + TEMPB=TEMPB+XPT(K,I)*S(I) + TEMPC=TEMPC+XPT(K,I)*XOPT(I) + END DO + WVEC(K,1)=QUART*(TEMPA*TEMPA+TEMPB*TEMPB) + WVEC(K,2)=TEMPA*TEMPC + WVEC(K,3)=TEMPB*TEMPC + WVEC(K,4)=QUART*(TEMPA*TEMPA-TEMPB*TEMPB) + WVEC(K,5)=HALF*TEMPA*TEMPB + END DO + DO I=1,N + IP=I+NPT + WVEC(IP,1)=ZERO + WVEC(IP,2)=D(I) + WVEC(IP,3)=S(I) + WVEC(IP,4)=ZERO + WVEC(IP,5)=ZERO + END DO ! ! Put the coefficents of THETA*Wcheck in PROD. ! - DO 190 JC=1,5 - NW=NPT - IF (JC .EQ. 2 .OR. JC .EQ. 3) NW=NDIM - DO 130 K=1,NPT - 130 PROD(K,JC)=ZERO - DO 150 J=1,NPTM - SUM=ZERO - DO 140 K=1,NPT - 140 SUM=SUM+ZMAT(K,J)*WVEC(K,JC) - IF (J .LT. IDZ) SUM=-SUM - DO 150 K=1,NPT - 150 PROD(K,JC)=PROD(K,JC)+SUM*ZMAT(K,J) - IF (NW .EQ. NDIM) THEN - DO 170 K=1,NPT - SUM=ZERO - DO 160 J=1,N - 160 SUM=SUM+BMAT(K,J)*WVEC(NPT+J,JC) - 170 PROD(K,JC)=PROD(K,JC)+SUM - END IF - DO 190 J=1,N - SUM=ZERO - DO 180 I=1,NW - 180 SUM=SUM+BMAT(I,J)*WVEC(I,JC) - 190 PROD(NPT+J,JC)=SUM + DO JC=1,5 + NW=NPT + IF (JC == 2 .OR. JC == 3) NW=NDIM + DO K=1,NPT + PROD(K,JC)=ZERO + END DO + DO J=1,NPTM + SUM=ZERO + DO K=1,NPT + SUM=SUM+ZMAT(K,J)*WVEC(K,JC) + END DO + IF (J < IDZ) SUM=-SUM + DO K=1,NPT + PROD(K,JC)=PROD(K,JC)+SUM*ZMAT(K,J) + END DO + END DO + IF (NW == NDIM) THEN + DO K=1,NPT + SUM=ZERO + DO J=1,N + SUM=SUM+BMAT(K,J)*WVEC(NPT+J,JC) + END DO + PROD(K,JC)=PROD(K,JC)+SUM + END DO + END IF + DO J=1,N + SUM=ZERO + DO I=1,NW + SUM=SUM+BMAT(I,J)*WVEC(I,JC) + END DO + PROD(NPT+J,JC)=SUM + END DO + END DO ! ! Include in DEN the part of BETA that depends on THETA. ! - DO 210 K=1,NDIM - SUM=ZERO - DO 200 I=1,5 - PAR(I)=HALF*PROD(K,I)*WVEC(K,I) - 200 SUM=SUM+PAR(I) - DEN(1)=DEN(1)-PAR(1)-SUM - TEMPA=PROD(K,1)*WVEC(K,2)+PROD(K,2)*WVEC(K,1) - TEMPB=PROD(K,2)*WVEC(K,4)+PROD(K,4)*WVEC(K,2) - TEMPC=PROD(K,3)*WVEC(K,5)+PROD(K,5)*WVEC(K,3) - DEN(2)=DEN(2)-TEMPA-HALF*(TEMPB+TEMPC) - DEN(6)=DEN(6)-HALF*(TEMPB-TEMPC) - TEMPA=PROD(K,1)*WVEC(K,3)+PROD(K,3)*WVEC(K,1) - TEMPB=PROD(K,2)*WVEC(K,5)+PROD(K,5)*WVEC(K,2) - TEMPC=PROD(K,3)*WVEC(K,4)+PROD(K,4)*WVEC(K,3) - DEN(3)=DEN(3)-TEMPA-HALF*(TEMPB-TEMPC) - DEN(7)=DEN(7)-HALF*(TEMPB+TEMPC) - TEMPA=PROD(K,1)*WVEC(K,4)+PROD(K,4)*WVEC(K,1) - DEN(4)=DEN(4)-TEMPA-PAR(2)+PAR(3) - TEMPA=PROD(K,1)*WVEC(K,5)+PROD(K,5)*WVEC(K,1) - TEMPB=PROD(K,2)*WVEC(K,3)+PROD(K,3)*WVEC(K,2) - DEN(5)=DEN(5)-TEMPA-HALF*TEMPB - DEN(8)=DEN(8)-PAR(4)+PAR(5) - TEMPA=PROD(K,4)*WVEC(K,5)+PROD(K,5)*WVEC(K,4) - 210 DEN(9)=DEN(9)-HALF*TEMPA + DO K=1,NDIM + SUM=ZERO + DO I=1,5 + PAR(I)=HALF*PROD(K,I)*WVEC(K,I) + SUM=SUM+PAR(I) + END DO + DEN(1)=DEN(1)-PAR(1)-SUM + TEMPA=PROD(K,1)*WVEC(K,2)+PROD(K,2)*WVEC(K,1) + TEMPB=PROD(K,2)*WVEC(K,4)+PROD(K,4)*WVEC(K,2) + TEMPC=PROD(K,3)*WVEC(K,5)+PROD(K,5)*WVEC(K,3) + DEN(2)=DEN(2)-TEMPA-HALF*(TEMPB+TEMPC) + DEN(6)=DEN(6)-HALF*(TEMPB-TEMPC) + TEMPA=PROD(K,1)*WVEC(K,3)+PROD(K,3)*WVEC(K,1) + TEMPB=PROD(K,2)*WVEC(K,5)+PROD(K,5)*WVEC(K,2) + TEMPC=PROD(K,3)*WVEC(K,4)+PROD(K,4)*WVEC(K,3) + DEN(3)=DEN(3)-TEMPA-HALF*(TEMPB-TEMPC) + DEN(7)=DEN(7)-HALF*(TEMPB+TEMPC) + TEMPA=PROD(K,1)*WVEC(K,4)+PROD(K,4)*WVEC(K,1) + DEN(4)=DEN(4)-TEMPA-PAR(2)+PAR(3) + TEMPA=PROD(K,1)*WVEC(K,5)+PROD(K,5)*WVEC(K,1) + TEMPB=PROD(K,2)*WVEC(K,3)+PROD(K,3)*WVEC(K,2) + DEN(5)=DEN(5)-TEMPA-HALF*TEMPB + DEN(8)=DEN(8)-PAR(4)+PAR(5) + TEMPA=PROD(K,4)*WVEC(K,5)+PROD(K,5)*WVEC(K,4) + DEN(9)=DEN(9)-HALF*TEMPA + END DO ! ! Extend DEN so that it holds all the coefficients of DENOM. ! SUM=ZERO - DO 220 I=1,5 - PAR(I)=HALF*PROD(KNEW,I)**2 - 220 SUM=SUM+PAR(I) + DO I=1,5 + PAR(I)=HALF*PROD(KNEW,I)**2 + SUM=SUM+PAR(I) + END DO DENEX(1)=ALPHA*DEN(1)+PAR(1)+SUM TEMPA=TWO*PROD(KNEW,1)*PROD(KNEW,2) TEMPB=PROD(KNEW,2)*PROD(KNEW,4) @@ -885,29 +950,31 @@ SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, IU=49 TEMP=TWOPI/DBLE(IU+1) PAR(1)=ONE - DO 250 I=1,IU - ANGLE=DBLE(I)*TEMP - PAR(2)=cos(ANGLE) - PAR(3)=sin(ANGLE) - DO 230 J=4,8,2 - PAR(J)=PAR(2)*PAR(J-2)-PAR(3)*PAR(J-1) - 230 PAR(J+1)=PAR(2)*PAR(J-1)+PAR(3)*PAR(J-2) - SUMOLD=SUM - SUM=ZERO - DO 240 J=1,9 - 240 SUM=SUM+DENEX(J)*PAR(J) - IF (DABS(SUM) .GT. DABS(DENMAX)) THEN - DENMAX=SUM - ISAVE=I - TEMPA=SUMOLD - ELSE IF (I .EQ. ISAVE+1) THEN - TEMPB=SUM - END IF - 250 CONTINUE - IF (ISAVE .EQ. 0) TEMPA=SUM - IF (ISAVE .EQ. IU) TEMPB=DENOLD + DO I=1,IU + ANGLE=DBLE(I)*TEMP + PAR(2)=cos(ANGLE) + PAR(3)=sin(ANGLE) + DO J=4,8,2 + PAR(J)=PAR(2)*PAR(J-2)-PAR(3)*PAR(J-1) + PAR(J+1)=PAR(2)*PAR(J-1)+PAR(3)*PAR(J-2) + END DO + SUMOLD=SUM + SUM=ZERO + DO J=1,9 + SUM=SUM+DENEX(J)*PAR(J) + END DO + IF (DABS(SUM) > DABS(DENMAX)) THEN + DENMAX=SUM + ISAVE=I + TEMPA=SUMOLD + ELSE IF (I == ISAVE+1) THEN + TEMPB=SUM + END IF + END DO + IF (ISAVE == 0) TEMPA=SUM + IF (ISAVE == IU) TEMPB=DENOLD STEP=ZERO - IF (TEMPA .NE. TEMPB) THEN + IF (TEMPA /= TEMPB) THEN TEMPA=TEMPA-DENMAX TEMPB=TEMPB-DENMAX STEP=HALF*(TEMPA-TEMPB)/(TEMPA+TEMPB) @@ -919,67 +986,78 @@ SUBROUTINE BIGDEN (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KOPT, ! PAR(2)=cos(ANGLE) PAR(3)=sin(ANGLE) - DO 260 J=4,8,2 - PAR(J)=PAR(2)*PAR(J-2)-PAR(3)*PAR(J-1) - 260 PAR(J+1)=PAR(2)*PAR(J-1)+PAR(3)*PAR(J-2) + DO J=4,8,2 + PAR(J)=PAR(2)*PAR(J-2)-PAR(3)*PAR(J-1) + PAR(J+1)=PAR(2)*PAR(J-1)+PAR(3)*PAR(J-2) + END DO BETA=ZERO DENMAX=ZERO - DO 270 J=1,9 - BETA=BETA+DEN(J)*PAR(J) - 270 DENMAX=DENMAX+DENEX(J)*PAR(J) - DO 280 K=1,NDIM - VLAG(K)=ZERO - DO 280 J=1,5 - 280 VLAG(K)=VLAG(K)+PROD(K,J)*PAR(J) + DO J=1,9 + BETA=BETA+DEN(J)*PAR(J) + DENMAX=DENMAX+DENEX(J)*PAR(J) + END DO + DO K=1,NDIM + VLAG(K)=ZERO + DO J=1,5 + VLAG(K)=VLAG(K)+PROD(K,J)*PAR(J) + END DO + END DO TAU=VLAG(KNEW) DD=ZERO TEMPA=ZERO TEMPB=ZERO - DO 290 I=1,N - D(I)=PAR(2)*D(I)+PAR(3)*S(I) - W(I)=XOPT(I)+D(I) - DD=DD+D(I)**2 - TEMPA=TEMPA+D(I)*W(I) - 290 TEMPB=TEMPB+W(I)*W(I) - IF (ITERC .GE. N) GOTO 340 - IF (ITERC .GT. 1) DENSAV=DMAX1(DENSAV,DENOLD) - IF (DABS(DENMAX) .LE. 1.1D0*DABS(DENSAV)) GOTO 340 + DO I=1,N + D(I)=PAR(2)*D(I)+PAR(3)*S(I) + W(I)=XOPT(I)+D(I) + DD=DD+D(I)**2 + TEMPA=TEMPA+D(I)*W(I) + TEMPB=TEMPB+W(I)*W(I) + END DO + IF (ITERC >= N) GOTO 340 + IF (ITERC > 1) DENSAV=DMAX1(DENSAV,DENOLD) + IF (DABS(DENMAX) <= 1.1D0*DABS(DENSAV)) GOTO 340 DENSAV=DENMAX ! ! Set S to half the gradient of the denominator with respect to D. ! Then branch for the next iteration. ! - DO 300 I=1,N - TEMP=TEMPA*XOPT(I)+TEMPB*D(I)-VLAG(NPT+I) - 300 S(I)=TAU*BMAT(KNEW,I)+ALPHA*TEMP - DO 320 K=1,NPT - SUM=ZERO - DO 310 J=1,N - 310 SUM=SUM+XPT(K,J)*W(J) - TEMP=(TAU*W(N+K)-ALPHA*VLAG(K))*SUM - DO 320 I=1,N - 320 S(I)=S(I)+TEMP*XPT(K,I) + DO I=1,N + TEMP=TEMPA*XOPT(I)+TEMPB*D(I)-VLAG(NPT+I) + S(I)=TAU*BMAT(KNEW,I)+ALPHA*TEMP + END DO + DO K=1,NPT + SUM=ZERO + DO J=1,N + SUM=SUM+XPT(K,J)*W(J) + END DO + TEMP=(TAU*W(N+K)-ALPHA*VLAG(K))*SUM + DO I=1,N + S(I)=S(I)+TEMP*XPT(K,I) + END DO + END DO SS=ZERO DS=ZERO - DO 330 I=1,N - SS=SS+S(I)**2 - 330 DS=DS+D(I)*S(I) + DO I=1,N + SS=SS+S(I)**2 + DS=DS+D(I)*S(I) + END DO SSDEN=DD*SS-DS*DS - IF (SSDEN .GE. 1.0D-8*DD*SS) GOTO 70 + IF (SSDEN >= 1.0D-8*DD*SS) GOTO 70 ! ! Set the vector W before the RETURN from the subroutine. ! - 340 DO 350 K=1,NDIM + 340 DO K=1,NDIM W(K)=ZERO - DO 350 J=1,5 - 350 W(K)=W(K)+WVEC(K,J)*PAR(J) + DO J=1,5 + W(K)=W(K)+WVEC(K,J)*PAR(J) + END DO + END DO VLAG(KOPT)=VLAG(KOPT)+ONE RETURN END SUBROUTINE BIGDEN - SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, - 1 DELTA,D,ALPHA,HCOL,GC,GD,S,W) + SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW,DELTA,D,ALPHA,HCOL,GC,GD,S,W) IMPLICIT real(dp) (A-H,O-Z) DIMENSION XOPT(*),XPT(NPT,*),BMAT(NDIM,*),ZMAT(NPT,*),D(*), 1 HCOL(*),GC(*),GD(*),S(*),W(*) @@ -998,7 +1076,7 @@ SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, ! HCOL, GC, GD, S and W will be used for working space. ! ! The step D is calculated in a way that attempts to maximize the modulus -! of LFUNC(XOPT+D), subject to the bound ||D|| .LE. DELTA, where LFUNC is +! of LFUNC(XOPT+D), subject to the bound ||D|| <= DELTA, where LFUNC is ! the KNEW-th Lagrange function. ! ! Set some constants. @@ -1014,35 +1092,42 @@ SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, ! KNEW-th column of H. ! ITERC=0 - DO 10 K=1,NPT - 10 HCOL(K)=ZERO - DO 20 J=1,NPTM - TEMP=ZMAT(KNEW,J) - IF (J .LT. IDZ) TEMP=-TEMP - DO 20 K=1,NPT - 20 HCOL(K)=HCOL(K)+TEMP*ZMAT(K,J) + DO K=1,NPT + HCOL(K)=ZERO + END DO + DO J=1,NPTM + TEMP=ZMAT(KNEW,J) + IF (J < IDZ) TEMP=-TEMP + DO K=1,NPT + HCOL(K)=HCOL(K)+TEMP*ZMAT(K,J) + END DO + END DO ALPHA=HCOL(KNEW) ! ! Set the unscaled initial direction D. Form the gradient of LFUNC at ! XOPT, and multiply D by the second derivative matrix of LFUNC. ! DD=ZERO - DO 30 I=1,N - D(I)=XPT(KNEW,I)-XOPT(I) - GC(I)=BMAT(KNEW,I) - GD(I)=ZERO - 30 DD=DD+D(I)**2 - DO 50 K=1,NPT - TEMP=ZERO - SUM=ZERO - DO 40 J=1,N - TEMP=TEMP+XPT(K,J)*XOPT(J) - 40 SUM=SUM+XPT(K,J)*D(J) - TEMP=HCOL(K)*TEMP - SUM=HCOL(K)*SUM - DO 50 I=1,N - GC(I)=GC(I)+TEMP*XPT(K,I) - 50 GD(I)=GD(I)+SUM*XPT(K,I) + DO I=1,N + D(I)=XPT(KNEW,I)-XOPT(I) + GC(I)=BMAT(KNEW,I) + GD(I)=ZERO + DD=DD+D(I)**2 + END DO + DO K=1,NPT + TEMP=ZERO + SUM=ZERO + DO J=1,N + TEMP=TEMP+XPT(K,J)*XOPT(J) + SUM=SUM+XPT(K,J)*D(J) + END DO + TEMP=HCOL(K)*TEMP + SUM=HCOL(K)*SUM + DO I=1,N + GC(I)=GC(I)+TEMP*XPT(K,I) + GD(I)=GD(I)+SUM*XPT(K,I) + END DO + END DO ! ! Scale D and GD, with a sign change if required. Set S to another ! vector in the initial two dimensional subspace. @@ -1050,20 +1135,22 @@ SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, GG=ZERO SP=ZERO DHD=ZERO - DO 60 I=1,N - GG=GG+GC(I)**2 - SP=SP+D(I)*GC(I) - 60 DHD=DHD+D(I)*GD(I) + DO I=1,N + GG=GG+GC(I)**2 + SP=SP+D(I)*GC(I) + DHD=DHD+D(I)*GD(I) + END DO SCALE=DELTA/DSQRT(DD) - IF (SP*DHD .LT. ZERO) SCALE=-SCALE + IF (SP*DHD < ZERO) SCALE=-SCALE TEMP=ZERO - IF (SP*SP .GT. 0.99D0*DD*GG) TEMP=ONE + IF (SP*SP > 0.99D0*DD*GG) TEMP=ONE TAU=SCALE*(DABS(SP)+HALF*SCALE*DABS(DHD)) - IF (GG*DELSQ .LT. 0.01D0*TAU*TAU) TEMP=ONE - DO 70 I=1,N - D(I)=SCALE*D(I) - GD(I)=SCALE*GD(I) - 70 S(I)=GC(I)+TEMP*GD(I) + IF (GG*DELSQ < 0.01D0*TAU*TAU) TEMP=ONE + DO I=1,N + D(I)=SCALE*D(I) + GD(I)=SCALE*GD(I) + S(I)=GC(I)+TEMP*GD(I) + END DO ! ! Begin the iteration by overwriting S with a vector that has the ! required length and direction, except that termination occurs if @@ -1073,38 +1160,44 @@ SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, DD=ZERO SP=ZERO SS=ZERO - DO 90 I=1,N - DD=DD+D(I)**2 - SP=SP+D(I)*S(I) - 90 SS=SS+S(I)**2 + DO I=1,N + DD=DD+D(I)**2 + SP=SP+D(I)*S(I) + SS=SS+S(I)**2 + END DO TEMP=DD*SS-SP*SP - IF (TEMP .LE. 1.0D-8*DD*SS) GOTO 160 + IF (TEMP <= 1.0D-8*DD*SS) GOTO 160 DENOM=DSQRT(TEMP) - DO 100 I=1,N - S(I)=(DD*S(I)-SP*D(I))/DENOM - 100 W(I)=ZERO + DO I=1,N + S(I)=(DD*S(I)-SP*D(I))/DENOM + W(I)=ZERO + END DO ! ! Calculate the coefficients of the objective function on the circle, ! beginning with the multiplication of S by the second derivative matrix. ! - DO 120 K=1,NPT - SUM=ZERO - DO 110 J=1,N - 110 SUM=SUM+XPT(K,J)*S(J) - SUM=HCOL(K)*SUM - DO 120 I=1,N - 120 W(I)=W(I)+SUM*XPT(K,I) + DO K=1,NPT + SUM=ZERO + DO J=1,N + SUM=SUM+XPT(K,J)*S(J) + END DO + SUM=HCOL(K)*SUM + DO I=1,N + W(I)=W(I)+SUM*XPT(K,I) + END DO + END DO CF1=ZERO CF2=ZERO CF3=ZERO CF4=ZERO CF5=ZERO - DO 130 I=1,N - CF1=CF1+S(I)*W(I) - CF2=CF2+D(I)*GC(I) - CF3=CF3+S(I)*GC(I) - CF4=CF4+D(I)*GD(I) - 130 CF5=CF5+S(I)*GD(I) + DO I=1,N + CF1=CF1+S(I)*W(I) + CF2=CF2+D(I)*GC(I) + CF3=CF3+S(I)*GC(I) + CF4=CF4+D(I)*GD(I) + CF5=CF5+S(I)*GD(I) + END DO CF1=HALF*CF1 CF4=HALF*CF4-CF1 ! @@ -1116,23 +1209,24 @@ SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, ISAVE=0 IU=49 TEMP=TWOPI/DBLE(IU+1) - DO 140 I=1,IU - ANGLE=DBLE(I)*TEMP - CTH=cos(ANGLE) - STH=sin(ANGLE) - TAU=CF1+(CF2+CF4*CTH)*CTH+(CF3+CF5*CTH)*STH - IF (DABS(TAU) .GT. DABS(TAUMAX)) THEN - TAUMAX=TAU - ISAVE=I - TEMPA=TAUOLD - ELSE IF (I .EQ. ISAVE+1) THEN - TEMPB=TAU - END IF - 140 TAUOLD=TAU - IF (ISAVE .EQ. 0) TEMPA=TAU - IF (ISAVE .EQ. IU) TEMPB=TAUBEG + DO I=1,IU + ANGLE=DBLE(I)*TEMP + CTH=cos(ANGLE) + STH=sin(ANGLE) + TAU=CF1+(CF2+CF4*CTH)*CTH+(CF3+CF5*CTH)*STH + IF (DABS(TAU) > DABS(TAUMAX)) THEN + TAUMAX=TAU + ISAVE=I + TEMPA=TAUOLD + ELSE IF (I == ISAVE+1) THEN + TEMPB=TAU + END IF + TAUOLD=TAU + END DO + IF (ISAVE == 0) TEMPA=TAU + IF (ISAVE == IU) TEMPB=TAUBEG STEP=ZERO - IF (TEMPA .NE. TEMPB) THEN + IF (TEMPA /= TEMPB) THEN TEMPA=TEMPA-TAUMAX TEMPB=TEMPB-TAUMAX STEP=HALF*(TEMPA-TEMPB)/(TEMPA+TEMPB) @@ -1144,17 +1238,17 @@ SUBROUTINE BIGLAG (N,NPT,XOPT,XPT,BMAT,ZMAT,IDZ,NDIM,KNEW, CTH=cos(ANGLE) STH=sin(ANGLE) TAU=CF1+(CF2+CF4*CTH)*CTH+(CF3+CF5*CTH)*STH - DO 150 I=1,N - D(I)=CTH*D(I)+STH*S(I) - GD(I)=CTH*GD(I)+STH*W(I) - 150 S(I)=GC(I)+GD(I) - IF (DABS(TAU) .LE. 1.1D0*DABS(TAUBEG)) GOTO 160 - IF (ITERC .LT. N) GOTO 80 + DO I=1,N + D(I)=CTH*D(I)+STH*S(I) + GD(I)=CTH*GD(I)+STH*W(I) + S(I)=GC(I)+GD(I) + END DO + IF (DABS(TAU) <= 1.1D0*DABS(TAUBEG)) GOTO 160 + IF (ITERC < N) GOTO 80 160 RETURN END SUBROUTINE BIGLAG - SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, - 1 D,G,HD,HS,CRVMIN) + SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP,D,G,HD,HS,CRVMIN) IMPLICIT real(dp) (A-H,O-Z) DIMENSION XOPT(*),XPT(NPT,*),GQ(*),HQ(*),PQ(*),STEP(*), 1 D(*),G(*),HD(*),HS(*) @@ -1184,22 +1278,24 @@ SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, ITERC=0 ITERMAX=N ITERSW=ITERMAX - DO 10 I=1,N - 10 D(I)=XOPT(I) + DO I=1,N + D(I)=XOPT(I) + END DO GOTO 170 ! ! Prepare for the first line search. ! 20 QRED=ZERO DD=ZERO - DO 30 I=1,N - STEP(I)=ZERO - HS(I)=ZERO - G(I)=GQ(I)+HD(I) - D(I)=-G(I) - 30 DD=DD+D(I)**2 + DO I=1,N + STEP(I)=ZERO + HS(I)=ZERO + G(I)=GQ(I)+HD(I) + D(I)=-G(I) + DD=DD+D(I)**2 + END DO CRVMIN=ZERO - IF (DD .EQ. ZERO) GOTO 160 + IF (DD == ZERO) GOTO 160 DS=ZERO SS=ZERO GG=DD @@ -1212,15 +1308,16 @@ SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, BSTEP=TEMP/(DS+DSQRT(DS*DS+DD*TEMP)) GOTO 170 50 DHD=ZERO - DO 60 J=1,N - 60 DHD=DHD+D(J)*HD(J) + DO J=1,N + DHD=DHD+D(J)*HD(J) + END DO ! ! Update CRVMIN and set the step-length ALPHA. ! ALPHA=BSTEP - IF (DHD .GT. ZERO) THEN + IF (DHD > ZERO) THEN TEMP=DHD/DD - IF (ITERC .EQ. 1) CRVMIN=TEMP + IF (ITERC == 1) CRVMIN=TEMP CRVMIN=DMIN1(CRVMIN,TEMP) ALPHA=DMIN1(ALPHA,GG/DHD) END IF @@ -1231,43 +1328,46 @@ SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, ! GGSAV=GG GG=ZERO - DO 70 I=1,N - STEP(I)=STEP(I)+ALPHA*D(I) - HS(I)=HS(I)+ALPHA*HD(I) - 70 GG=GG+(G(I)+HS(I))**2 + DO I=1,N + STEP(I)=STEP(I)+ALPHA*D(I) + HS(I)=HS(I)+ALPHA*HD(I) + GG=GG+(G(I)+HS(I))**2 + END DO ! ! Begin another conjugate direction iteration if required. ! - IF (ALPHA .LT. BSTEP) THEN - IF (QADD .LE. 0.01D0*QRED) GOTO 160 - IF (GG .LE. 1.0D-4*GGBEG) GOTO 160 - IF (ITERC .EQ. ITERMAX) GOTO 160 + IF (ALPHA < BSTEP) THEN + IF (QADD <= 0.01D0*QRED) GOTO 160 + IF (GG <= 1.0D-4*GGBEG) GOTO 160 + IF (ITERC == ITERMAX) GOTO 160 TEMP=GG/GGSAV DD=ZERO DS=ZERO SS=ZERO - DO 80 I=1,N - D(I)=TEMP*D(I)-G(I)-HS(I) - DD=DD+D(I)**2 - DS=DS+D(I)*STEP(I) - 80 SS=SS+STEP(I)**2 - IF (DS .LE. ZERO) GOTO 160 - IF (SS .LT. DELSQ) GOTO 40 + DO I=1,N + D(I)=TEMP*D(I)-G(I)-HS(I) + DD=DD+D(I)**2 + DS=DS+D(I)*STEP(I) + SS=SS+STEP(I)**2 + END DO + IF (DS <= ZERO) GOTO 160 + IF (SS < DELSQ) GOTO 40 END IF CRVMIN=ZERO ITERSW=ITERC ! ! Test whether an alternative iteration is required. ! - 90 IF (GG .LE. 1.0D-4*GGBEG) GOTO 160 + 90 IF (GG <= 1.0D-4*GGBEG) GOTO 160 SG=ZERO SHS=ZERO - DO 100 I=1,N - SG=SG+STEP(I)*G(I) - 100 SHS=SHS+STEP(I)*HS(I) + DO I=1,N + SG=SG+STEP(I)*G(I) + SHS=SHS+STEP(I)*HS(I) + END DO SGK=SG+SHS ANGTEST=SGK/DSQRT(GG*DELSQ) - IF (ANGTEST .LE. -0.99D0) GOTO 160 + IF (ANGTEST <= -0.99D0) GOTO 160 ! ! Begin the alternative iteration by calculating D and HD and some ! scalar products. @@ -1276,16 +1376,18 @@ SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, TEMP=DSQRT(DELSQ*GG-SGK*SGK) TEMPA=DELSQ/TEMP TEMPB=SGK/TEMP - DO 110 I=1,N - 110 D(I)=TEMPA*(G(I)+HS(I))-TEMPB*STEP(I) + DO I=1,N + D(I)=TEMPA*(G(I)+HS(I))-TEMPB*STEP(I) + END DO GOTO 170 120 DG=ZERO DHD=ZERO DHS=ZERO - DO 130 I=1,N - DG=DG+D(I)*G(I) - DHD=DHD+HD(I)*D(I) - 130 DHS=DHS+HD(I)*STEP(I) + DO I=1,N + DG=DG+D(I)*G(I) + DHD=DHD+HD(I)*D(I) + DHS=DHS+HD(I)*STEP(I) + END DO ! ! Seek the value of the angle that minimizes Q. ! @@ -1296,23 +1398,24 @@ SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, ISAVE=0 IU=49 TEMP=TWOPI/DBLE(IU+1) - DO 140 I=1,IU - ANGLE=DBLE(I)*TEMP - CTH=cos(ANGLE) - STH=sin(ANGLE) - QNEW=(SG+CF*CTH)*CTH+(DG+DHS*CTH)*STH - IF (QNEW .LT. QMIN) THEN - QMIN=QNEW - ISAVE=I - TEMPA=QSAV - ELSE IF (I .EQ. ISAVE+1) THEN - TEMPB=QNEW - END IF - 140 QSAV=QNEW - IF (ISAVE .EQ. ZERO) TEMPA=QNEW - IF (ISAVE .EQ. IU) TEMPB=QBEG + DO I=1,IU + ANGLE=DBLE(I)*TEMP + CTH=cos(ANGLE) + STH=sin(ANGLE) + QNEW=(SG+CF*CTH)*CTH+(DG+DHS*CTH)*STH + IF (QNEW < QMIN) THEN + QMIN=QNEW + ISAVE=I + TEMPA=QSAV + ELSE IF (I == ISAVE+1) THEN + TEMPB=QNEW + END IF + QSAV=QNEW + END DO + IF (ISAVE == ZERO) TEMPA=QNEW + IF (ISAVE == IU) TEMPB=QBEG ANGLE=ZERO - IF (TEMPA .NE. TEMPB) THEN + IF (TEMPA /= TEMPB) THEN TEMPA=TEMPA-QMIN TEMPB=TEMPB-QMIN ANGLE=HALF*(TEMPA-TEMPB)/(TEMPA+TEMPB) @@ -1325,13 +1428,14 @@ SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, STH=sin(ANGLE) REDUC=QBEG-(SG+CF*CTH)*CTH-(DG+DHS*CTH)*STH GG=ZERO - DO 150 I=1,N - STEP(I)=CTH*STEP(I)+STH*D(I) - HS(I)=CTH*HS(I)+STH*HD(I) - 150 GG=GG+(G(I)+HS(I))**2 + DO I=1,N + STEP(I)=CTH*STEP(I)+STH*D(I) + HS(I)=CTH*HS(I)+STH*HD(I) + GG=GG+(G(I)+HS(I))**2 + END DO QRED=QRED+REDUC RATIO=REDUC/QRED - IF (ITERC .LT. ITERMAX .AND. RATIO .GT. 0.01D0) GOTO 90 + IF (ITERC < ITERMAX .AND. RATIO > 0.01D0) GOTO 90 160 RETURN ! ! The following instructions act as a subroutine for setting the vector @@ -1339,23 +1443,29 @@ SUBROUTINE TRSAPP (N,NPT,XOPT,XPT,GQ,HQ,PQ,DELTA,STEP, ! They are called from three different places, which are distinguished ! by the value of ITERC. ! - 170 DO 180 I=1,N - 180 HD(I)=ZERO - DO 200 K=1,NPT - TEMP=ZERO - DO 190 J=1,N - 190 TEMP=TEMP+XPT(K,J)*D(J) - TEMP=TEMP*PQ(K) - DO 200 I=1,N - 200 HD(I)=HD(I)+TEMP*XPT(K,I) + 170 DO I=1,N + HD(I)=ZERO + END DO + DO K=1,NPT + TEMP=ZERO + DO J=1,N + TEMP=TEMP+XPT(K,J)*D(J) + END DO + TEMP=TEMP*PQ(K) + DO I=1,N + HD(I)=HD(I)+TEMP*XPT(K,I) + END DO + END DO IH=0 - DO 210 J=1,N - DO 210 I=1,J - IH=IH+1 - IF (I .LT. J) HD(J)=HD(J)+HQ(IH)*D(I) - 210 HD(I)=HD(I)+HQ(IH)*D(J) - IF (ITERC .EQ. 0) GOTO 20 - IF (ITERC .LE. ITERSW) GOTO 50 + DO J=1,N + DO I=1,J + IH=IH+1 + IF (I < J) HD(J)=HD(J)+HQ(IH)*D(I) + HD(I)=HD(I)+HQ(IH)*D(J) + END DO + END DO + IF (ITERC == 0) GOTO 20 + IF (ITERC <= ITERSW) GOTO 50 GOTO 120 END SUBROUTINE TRSAPP @@ -1378,31 +1488,32 @@ SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,IDZ,NDIM,VLAG,BETA,KNEW,W) ! Apply the rotations that put zeros in the KNEW-th row of ZMAT. ! JL=1 - DO 20 J=2,NPTM - IF (J .EQ. IDZ) THEN - JL=IDZ - ELSE IF (ZMAT(KNEW,J) .NE. ZERO) THEN - TEMP=DSQRT(ZMAT(KNEW,JL)**2+ZMAT(KNEW,J)**2) - TEMPA=ZMAT(KNEW,JL)/TEMP - TEMPB=ZMAT(KNEW,J)/TEMP - DO 10 I=1,NPT - TEMP=TEMPA*ZMAT(I,JL)+TEMPB*ZMAT(I,J) - ZMAT(I,J)=TEMPA*ZMAT(I,J)-TEMPB*ZMAT(I,JL) - 10 ZMAT(I,JL)=TEMP - ZMAT(KNEW,J)=ZERO - END IF - 20 CONTINUE + DO J=2,NPTM + IF (J == IDZ) THEN + JL=IDZ + ELSE IF (ZMAT(KNEW,J) /= ZERO) THEN + TEMP=DSQRT(ZMAT(KNEW,JL)**2+ZMAT(KNEW,J)**2) + TEMPA=ZMAT(KNEW,JL)/TEMP + TEMPB=ZMAT(KNEW,J)/TEMP + DO I=1,NPT + TEMP=TEMPA*ZMAT(I,JL)+TEMPB*ZMAT(I,J) + ZMAT(I,J)=TEMPA*ZMAT(I,J)-TEMPB*ZMAT(I,JL) + ZMAT(I,JL)=TEMP + END DO + ZMAT(KNEW,J)=ZERO + END IF + END DO ! ! Put the first NPT components of the KNEW-th column of HLAG into W, ! and calculate the parameters of the updating formula. ! TEMPA=ZMAT(KNEW,1) - IF (IDZ .GE. 2) TEMPA=-TEMPA - IF (JL .GT. 1) TEMPB=ZMAT(KNEW,JL) - DO 30 I=1,NPT - W(I)=TEMPA*ZMAT(I,1) - IF (JL .GT. 1) W(I)=W(I)+TEMPB*ZMAT(I,JL) - 30 CONTINUE + IF (IDZ >= 2) TEMPA=-TEMPA + IF (JL > 1) TEMPB=ZMAT(KNEW,JL) + DO I=1,NPT + W(I)=TEMPA*ZMAT(I,1) + IF (JL > 1) W(I)=W(I)+TEMPB*ZMAT(I,JL) + END DO ALPHA=W(KNEW) TAU=VLAG(KNEW) TAUSQ=TAU*TAU @@ -1414,20 +1525,21 @@ SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,IDZ,NDIM,VLAG,BETA,KNEW,W) ! then the first column of ZMAT will be exchanged with another one later. ! IFLAG=0 - IF (JL .EQ. 1) THEN + IF (JL == 1) THEN TEMP=DSQRT(DABS(DENOM)) TEMPB=TEMPA/TEMP TEMPA=TAU/TEMP - DO 40 I=1,NPT - 40 ZMAT(I,1)=TEMPA*ZMAT(I,1)-TEMPB*VLAG(I) - IF (IDZ .EQ. 1 .AND. TEMP .LT. ZERO) IDZ=2 - IF (IDZ .GE. 2 .AND. TEMP .GE. ZERO) IFLAG=1 + DO I=1,NPT + ZMAT(I,1)=TEMPA*ZMAT(I,1)-TEMPB*VLAG(I) + END DO + IF (IDZ == 1 .AND. TEMP < ZERO) IDZ=2 + IF (IDZ >= 2 .AND. TEMP >= ZERO) IFLAG=1 ELSE ! ! Complete the updating of ZMAT in the alternative case. ! JA=1 - IF (BETA .GE. ZERO) JA=JL + IF (BETA >= ZERO) JA=JL JB=JL+1-JA TEMP=ZMAT(KNEW,JB)/DENOM TEMPA=TEMP*BETA @@ -1435,41 +1547,42 @@ SUBROUTINE UPDATE (N,NPT,BMAT,ZMAT,IDZ,NDIM,VLAG,BETA,KNEW,W) TEMP=ZMAT(KNEW,JA) SCALA=ONE/DSQRT(DABS(BETA)*TEMP*TEMP+TAUSQ) SCALB=SCALA*DSQRT(DABS(DENOM)) - DO 50 I=1,NPT - ZMAT(I,JA)=SCALA*(TAU*ZMAT(I,JA)-TEMP*VLAG(I)) - 50 ZMAT(I,JB)=SCALB*(ZMAT(I,JB)-TEMPA*W(I)-TEMPB*VLAG(I)) - IF (DENOM .LE. ZERO) THEN - IF (BETA .LT. ZERO) IDZ=IDZ+1 - IF (BETA .GE. ZERO) IFLAG=1 + DO I=1,NPT + ZMAT(I,JA)=SCALA*(TAU*ZMAT(I,JA)-TEMP*VLAG(I)) + ZMAT(I,JB)=SCALB*(ZMAT(I,JB)-TEMPA*W(I)-TEMPB*VLAG(I)) + END DO + IF (DENOM <= ZERO) THEN + IF (BETA < ZERO) IDZ=IDZ+1 + IF (BETA >= ZERO) IFLAG=1 END IF END IF ! ! IDZ is reduced in the following case, and usually the first column ! of ZMAT is exchanged with a later one. ! - IF (IFLAG .EQ. 1) THEN + IF (IFLAG == 1) THEN IDZ=IDZ-1 - DO 60 I=1,NPT - TEMP=ZMAT(I,1) - ZMAT(I,1)=ZMAT(I,IDZ) - 60 ZMAT(I,IDZ)=TEMP + DO I=1,NPT + TEMP=ZMAT(I,1) + ZMAT(I,1)=ZMAT(I,IDZ) + ZMAT(I,IDZ)=TEMP + END DO END IF ! ! Finally, update the matrix BMAT. ! - DO 70 J=1,N - JP=NPT+J - W(JP)=BMAT(KNEW,J) - TEMPA=(ALPHA*VLAG(JP)-TAU*W(JP))/DENOM - TEMPB=(-BETA*W(JP)-TAU*VLAG(JP))/DENOM - DO 70 I=1,JP - BMAT(I,J)=BMAT(I,J)+TEMPA*VLAG(I)+TEMPB*W(I) - IF (I .GT. NPT) BMAT(JP,I-NPT)=BMAT(I,J) - 70 CONTINUE + DO J=1,N + JP=NPT+J + W(JP)=BMAT(KNEW,J) + TEMPA=(ALPHA*VLAG(JP)-TAU*W(JP))/DENOM + TEMPB=(-BETA*W(JP)-TAU*VLAG(JP))/DENOM + DO I=1,JP + BMAT(I,J)=BMAT(I,J)+TEMPA*VLAG(I)+TEMPB*W(I) + IF (I > NPT) BMAT(JP,I-NPT)=BMAT(I,J) + END DO + END DO RETURN END SUBROUTINE UPDATE - end module mod_newuoa - diff --git a/num/private/mod_rosenbrock.f b/num/private/mod_rosenbrock.f index 07e015f11..277e22b60 100644 --- a/num/private/mod_rosenbrock.f +++ b/num/private/mod_rosenbrock.f @@ -341,7 +341,7 @@ subroutine coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name end subroutine coeffs end interface #include "rodas_args.dek" @@ -662,7 +662,7 @@ subroutine coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name end subroutine coeffs #include "num_solout.dek" #include "num_mas.dek" @@ -688,7 +688,7 @@ end subroutine coeffs real(dp) :: ros_alpha(ns), ros_gamma(ns) integer :: ros_elo logical :: ros_newf(ns) - character*12 :: ros_name + character (len=12) :: ros_name ! args integer, intent(inout), pointer :: ipar(:) ! (lipar) @@ -1240,7 +1240,7 @@ subroutine ros2_coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name real(dp) :: g no_aux_in_error = .true. @@ -1296,7 +1296,7 @@ subroutine rose2_coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name real(dp) :: g, e32 real(dp), parameter :: sqrt2 = 1.4142135623731d0 ! sqrt(2d0) no_aux_in_error = .true. @@ -1372,7 +1372,7 @@ subroutine ros3p_coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name no_aux_in_error = .true. !~~~> name of the method ros_name = 'ros3p' @@ -1435,7 +1435,7 @@ subroutine ros3pl_coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name no_aux_in_error = .true. !~~~> name of the method ros_name = 'ros3pl' @@ -1519,7 +1519,7 @@ subroutine rodas3_coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name ra = 0 rc = 0 rd = 0 @@ -1597,7 +1597,7 @@ subroutine rodas4_coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name no_aux_in_error = .false. rd = 0 @@ -1715,7 +1715,7 @@ subroutine rodasp_coeffs (ns,ra,rc,rd,ros_d,ros_m,ros_e,ros_alpha, real(dp), intent(inout) :: ros_alpha(ns), ros_gamma(ns) integer, intent(out) :: ros_elo logical, intent(out) :: no_aux_in_error, ros_newf(ns) - character*12, intent(out) :: ros_name + character (len=12), intent(out) :: ros_name no_aux_in_error = .false. rd = 0 !~~~> name of the method diff --git a/num/private/slvrad.dek b/num/private/slvrad.dek index ebe4d7f24..53c2e9373 100644 --- a/num/private/slvrad.dek +++ b/num/private/slvrad.dek @@ -11,6 +11,9 @@ #include "mtx_decsolc.dek" #include"mtx_decsolcs.dek" end interface + integer :: ldjac, mljac, mujac, ldmas, mlmas, mumas, m1, m2, nm1, lde1, ier, ijob + integer :: n, mle, mue, mbjac, mbb, mdiag, mdiff, mbdiag, nzmax, isparse, lcd, lrd, lid + integer :: iphes(n) integer :: ia(:) ! (n+1) integer :: ja(:) ! (nzmax) double precision :: sa(nzmax), sar(nzmax), sai(nzmax) @@ -21,9 +24,6 @@ double precision, pointer :: e1_1D(:) double precision :: e2r(lde1,nm1), e2i(lde1,nm1), cont(n) double precision, pointer, dimension(:) :: z1, z2, z3, f1, f2, f3 ! (n) - integer :: ldjac, mljac, mujac, ldmas, mlmas, mumas, m1, m2, nm1, lde1, ier, ijob - integer :: n, mle, mue, mbjac, mbb, mdiag, mdiff, mbdiag, nzmax, isparse, lcd, lrd, lid - integer :: iphes(n) integer, pointer, dimension(:) :: ip1, ip2 ! (nm1) diff --git a/num/private/slvrod.dek b/num/private/slvrod.dek index 971361846..8c9e8399e 100644 --- a/num/private/slvrod.dek +++ b/num/private/slvrod.dek @@ -40,8 +40,8 @@ real(dp), pointer, dimension(:,:,:) :: uf_lblk, uf_dblk, uf_ublk ! - if (hd.eq.0.d0) then - do i=1,n + if (hd == 0.d0) then + do i=1,n ak(i)=dy(i) end do else @@ -58,7 +58,7 @@ if (nvar*nz /= n) stop 'bad nvar*nz /= n' if (not_stage1) then - !do i=1,n + !do i=1,n ! write(*,*) 'in ak ynew', i, ak(i), ynew(i) !end do do i=1,n @@ -66,7 +66,7 @@ end do end if - !do i=1,n + !do i=1,n ! write(*,*) 'in', i, ak(i) !end do @@ -87,7 +87,7 @@ - !do i=1,n + !do i=1,n ! write(*,*) 'out', i, ak(i) !end do !write(*,*) @@ -114,7 +114,7 @@ sum = sum + abs(r_ary(i)) end do - do i=1,n + do i=1,n write(*,*) 'res', i, r_ary(i) end do write(*,*) @@ -186,9 +186,9 @@ 9 continue ! --- b is a banded matrix, jacobian a sparse matrix if (not_stage1) then - do i=1,n + do i=1,n sum=0.d0 - do j=max(1,i-mlmas),min(n,i+mumas) + do j=max(1,i-mlmas),min(n,i+mumas) sum=sum+fmas(i-j+mbdiag,j)*ynew(j) end do ak(i)=ak(i)+sum @@ -232,7 +232,7 @@ 2 continue ! --- b=identity, jacobian a banded matrix if (not_stage1) then - !do i=1,n + !do i=1,n ! write(*,*) 'in ak ynew', i, ak(i), ynew(i) !end do do i=1,n @@ -240,13 +240,13 @@ end do end if - !do i=1,n + !do i=1,n ! write(*,*) 'in', i, ak(i) !end do call decsol(1,n,lde,e_1D,mle,mue,ak,ip,lrd,rpar_decsol,lid,ipar_decsol,ier) - !do i=1,n + !do i=1,n ! write(*,*) 'out', i, ak(i) !end do !write(*,*) @@ -287,9 +287,9 @@ 3 continue ! --- b is a banded matrix, jacobian a full matrix if (not_stage1) then - do i=1,n + do i=1,n sum=0.d0 - do j=max(1,i-mlmas),min(n,i+mumas) + do j=max(1,i-mlmas),min(n,i+mumas) sum=sum+fmas(i-j+mbdiag,j)*ynew(j) end do ak(i)=ak(i)+sum @@ -317,7 +317,7 @@ ! ak(im1)=ak(im1)+sum ! end do ! end if -! if (ijob.eq.14) goto 45 +! if (ijob == 14) goto 45 ! goto 48 ! ! ----------------------------------------------------------- @@ -379,11 +379,13 @@ ! --- b is a full matrix, jacobian a banded matrix ! --- this option is not provided if (not_stage1) then - do 624 i=1,n + do i=1,n sum=0.d0 - do 623 j=1,n - 623 sum=sum+fmas(i,j)*ynew(j) - 624 ak(i)=ak(i)+sum + do j=1,n + sum=sum+fmas(i,j)*ynew(j) + end do + ak(i)=ak(i)+sum + end do call decsol(1,n,lde,e_1D,mle,mue,ak,ip,lrd,rpar_decsol,lid,ipar_decsol,ier) end if return diff --git a/num/test/make/makefile_base b/num/test/make/makefile_base index 0e379c86c..5ab88af39 100644 --- a/num/test/make/makefile_base +++ b/num/test/make/makefile_base @@ -77,42 +77,20 @@ nodeps : $(.DEFAULT_GOAL) # # COMPILATION RULES -COMPILE_NC = $(FC) $(FCbasic) $(FCopenmp) $(FCstatic) $(FCopt) $(FCfixed) $(TEST_INCLUDES) -c - -COMPILE_LEGACY_NC = $(filter-out -std=f2008, $(COMPILE_NC)) -std=legacy -TEST_COMPILE_LEGACY = $(filter-out -std=f2008, $(TEST_COMPILE)) -std=legacy - -test_brent.o test_simplex.o : %.o : %.f -ifneq ($(QUIET),) - @echo TEST_COMPILE_LEGACY $< - @$(TEST_COMPILE_LEGACY) $(FCfree) $< -else - $(TEST_COMPILE_LEGACY) $(FCfree) $< -endif - -test_bobyqa.o test_newuoa.o : %.o : %.f -ifneq ($(QUIET),) - @echo TEST_COMPILE_LEGACY $< - @$(TEST_COMPILE_LEGACY) $(FCfixed) $< -else - $(TEST_COMPILE_LEGACY) $(FCfixed) $< -endif - -bari_vdpol.o bari_vdpol3.o bari_vdpol_x.o bari_vdpol3_x.o bari_medakzo.o bari_hires.o \ - bari_pollu.o bari_rober.o bari_beam.o bari_chemakzo.o : %.o : %.f +%.o : %.f ifneq ($(QUIET),) - @echo COMPILE_LEGACY_NC $< - @$(COMPILE_LEGACY_NC) $< + @echo TEST_COMPILE fixed $< + @$(TEST_COMPILE) $(FCfixed) -fimplicit-none $< else - $(COMPILE_LEGACY_NC) $< + $(TEST_COMPILE) $(FCfixed)-fimplicit-none $< endif -%.o: %.f +%.o: %.f90 ifneq ($(QUIET),) - @echo TEST_COMPILE_LEGACY $< - @$(TEST_COMPILE_LEGACY) $(FCfree) $< + @echo TEST_COMPILE free $< + @$(TEST_COMPILE) $(FCfree) -fimplicit-none $< else - $(TEST_COMPILE_LEGACY) $(FCfree) $< + $(TEST_COMPILE) $(FCfree) -fimplicit-none $< endif ################################################################# @@ -122,6 +100,7 @@ endif SRC_PATH = $(TEST_SRC_DIR) vpath %.f $(SRC_PATH) +vpath %.f90 $(SRC_PATH) vpath %.mod $(LOCAL_LIB_DIR):$(MESA_DIR)/include diff --git a/num/test/src/bari_beam.f b/num/test/src/bari_beam.f index 04707809a..49ded6697 100644 --- a/num/test/src/bari_beam.f +++ b/num/test/src/bari_beam.f @@ -1,222 +1,233 @@ -c----------------------------------------------------------------------- -c----------------------------------------------------------------------- -c -c This file is part of the Test Set for IVP solvers -c http://www.dm.uniba.it/~testset/ -c -c Beam (ODE case) -c ODE of dimension 80 -c -c DISCLAIMER: see -c http://www.dm.uniba.it/~testset/disclaimer.php -c -c The most recent version of this source file can be found at -c http://www.dm.uniba.it/~testset/src/problems/beam.f -c -c This is revision -c $Id: beam.F,v 1.2 2006/10/02 10:29:13 testset Exp $ -c -c----------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! +! This file is part of the Test Set for IVP solvers +! http://www.dm.uniba.it/~testset/ +! +! Beam (ODE case) +! ODE of dimension 80 +! +! DISCLAIMER: see +! http://www.dm.uniba.it/~testset/disclaimer.php +! +! The most recent version of this source file can be found at +! http://www.dm.uniba.it/~testset/src/problems/beam.f +! +! This is revision +! $Id: beam.F,v 1.2 2006/10/02 10:29:13 testset Exp $ +! +! ---------------------------------------------------------------------- subroutine beam_init(neqn,y,yprime,consis) - integer neqn - double precision y(neqn),yprime(neqn) - logical consis + use const_def, only: dp + integer :: neqn + real(dp) :: y(neqn),yprime(neqn) + logical :: consis - integer i + integer :: i - do 10 i=1,neqn + do i=1,neqn y(i) = 0d0 - 10 continue + end do return end -c----------------------------------------------------------------------- +! ---------------------------------------------------------------------- subroutine beam_feval(nvar,t,th,df,ierr,rpar,ipar) + use const_def, only: dp use math_lib - IMPLICIT real*8 (A-H,O-Z) - integer ierr,ipar(*) + IMPLICIT real(dp) (A-H,O-Z) + integer ierr,nvar,i,ipar(*) integer, parameter :: N=40, NN=2*N, NCOM=N, NSQ=N*N, NQUATR=NSQ*NSQ, NNCOM=NN - double precision rpar(*), an, deltas + real(dp) rpar(*), an, deltas DIMENSION DF(NN),TH(150),U(150),V(150),W(150) DIMENSION ALPHA(150),BETA(150),STH(150),CTH(150) -C --- SET DEFAULT VALUES +! --- SET DEFAULT VALUES if (nvar /= nn) stop 'bad nvar for beam_feval' AN=N DELTAS=1.0D+0/AN -C ----- CALCUL DES TH(I) ET DES SIN ET COS ------------- - DO 22 I=2,N - THDIFF=TH(I)-TH(I-1) - STH(I)=sin(THDIFF) - 22 CTH(I)=cos(THDIFF) -C -------- CALCUL DU COTE DROIT DU SYSTEME LINEAIRE ----- - IF(T.GT.3.14159265358979324D0)THEN -C --------- CASE T GREATER PI ------------ -C ---------- I=1 ------------ +! ----- CALCUL DES TH(I) ET DES SIN ET COS ------------- + DO I=2,N + THDIFF=TH(I)-TH(I-1) + STH(I)=sin(THDIFF) + CTH(I)=cos(THDIFF) + END DO +! -------- CALCUL DU COTE DROIT DU SYSTEME LINEAIRE ----- + IF(T > 3.14159265358979324D0)THEN +! --------- CASE T GREATER PI ------------ +! ---------- I=1 ------------ TERM1=(-3.D0*TH(1)+TH(2))*NQUATR V(1)=TERM1 -C -------- I=2,..,N-1 ----------- - DO 32 I=2,N-1 - TERM1=(TH(I-1)-2.D0*TH(I)+TH(I+1))*NQUATR - 32 V(I)=TERM1 -C ----------- I=N ------------- +! -------- I=2,..,N-1 ----------- + DO I=2,N-1 + TERM1=(TH(I-1)-2.D0*TH(I)+TH(I+1))*NQUATR + V(I)=TERM1 + END DO +! ----------- I=N ------------- TERM1=(TH(N-1)-TH(N))*NQUATR V(N)=TERM1 ELSE -C --------- CASE T LESS EQUAL PI ------------ +! --------- CASE T LESS EQUAL PI ------------ FABS=1.5D0*sin(T)*sin(T) FX=-FABS FY= FABS -C ---------- I=1 ------------ +! ---------- I=1 ------------ TERM1=(-3.D0*TH(1)+TH(2))*NQUATR TERM2=NSQ*(FY*cos(TH(1))-FX*sin(TH(1))) V(1)=TERM1+TERM2 -C -------- I=2,..,N-1 ----------- - DO 34 I=2,N-1 - TERM1=(TH(I-1)-2.D0*TH(I)+TH(I+1))*NQUATR - TERM2=NSQ*(FY*cos(TH(I))-FX*sin(TH(I))) - 34 V(I)=TERM1+TERM2 -C ----------- I=N ------------- +! -------- I=2,..,N-1 ----------- + DO I=2,N-1 + TERM1=(TH(I-1)-2.D0*TH(I)+TH(I+1))*NQUATR + TERM2=NSQ*(FY*cos(TH(I))-FX*sin(TH(I))) + V(I)=TERM1+TERM2 + END DO +! ----------- I=N ------------- TERM1=(TH(N-1)-TH(N))*NQUATR TERM2=NSQ*(FY*cos(TH(N))-FX*sin(TH(N))) V(N)=TERM1+TERM2 END IF -C -------- COMPUTE PRODUCT DV=W ------------ +! -------- COMPUTE PRODUCT DV=W ------------ W(1)=STH(2)*V(2) - DO 43 I=2,N-1 - 43 W(I)=-STH(I)*V(I-1)+STH(I+1)*V(I+1) + DO I=2,N-1 + W(I)=-STH(I)*V(I-1)+STH(I+1)*V(I+1) + END DO W(N)=-STH(N)*V(N-1) -C -------- TERME 3 ----------------- - DO 435 I=1,N - 435 W(I)=W(I)+TH(N+I)*TH(N+I) -C ------- SOLVE SYSTEM CW=W --------- +! -------- TERME 3 ----------------- + DO I=1,N + W(I)=W(I)+TH(N+I)*TH(N+I) + END DO +! ------- SOLVE SYSTEM CW=W --------- ALPHA(1)=1.D0 - DO 44 I=2,N - ALPHA(I)=2.D0 - 44 BETA(I-1)=-CTH(I) + DO I=2,N + ALPHA(I)=2.D0 + BETA(I-1)=-CTH(I) + END DO ALPHA(N)=3.D0 - DO 45 I=N-1,1,-1 - Q=BETA(I)/ALPHA(I+1) - W(I)=W(I)-W(I+1)*Q - 45 ALPHA(I)=ALPHA(I)-BETA(I)*Q + DO I=N-1,1,-1 + Q=BETA(I)/ALPHA(I+1) + W(I)=W(I)-W(I+1)*Q + ALPHA(I)=ALPHA(I)-BETA(I)*Q + END DO W(1)=W(1)/ALPHA(1) - DO 46 I=2,N - 46 W(I)=(W(I)-BETA(I-1)*W(I-1))/ALPHA(I) -C -------- COMPUTE U=CV+DW --------- + DO I=2,N + W(I)=(W(I)-BETA(I-1)*W(I-1))/ALPHA(I) + END DO +! -------- COMPUTE U=CV+DW --------- U(1)=V(1)-CTH(2)*V(2)+STH(2)*W(2) - DO 47 I=2,N-1 - 47 U(I)=2.D0*V(I)-CTH(I)*V(I-1)-CTH(I+1)*V(I+1) - & -STH(I)*W(I-1)+STH(I+1)*W(I+1) + DO I=2,N-1 + U(I)=2.D0*V(I)-CTH(I)*V(I-1)-CTH(I+1)*V(I+1) + & -STH(I)*W(I-1)+STH(I+1)*W(I+1) + END DO U(N)=3.D0*V(N)-CTH(N)*V(N-1)-STH(N)*W(N-1) -C -------- PUT DERIVATIVES IN RIGHT PLACE ------------- - DO 54 I=1,N - DF(I)=TH(N+I) - 54 DF(N+I)=U(I) +! -------- PUT DERIVATIVES IN RIGHT PLACE ------------- + DO I=1,N + DF(I)=TH(N+I) + DF(N+I)=U(I) + END DO RETURN END -c----------------------------------------------------------------------- +! ---------------------------------------------------------------------- subroutine beam_jeval(ldim,neqn,t,y,yprime,dfdy,ierr,rpar,ipar) + use const_def, only: dp integer ldim,neqn,ierr,ipar(*) - double precision t,y(neqn),yprime(neqn),dfdy(ldim,neqn),rpar(*) -c -c dummy subroutine -c + real(dp) t,y(neqn),yprime(neqn),dfdy(ldim,neqn),rpar(*) +! +! dummy subroutine +! + return end -c----------------------------------------------------------------------- +! ---------------------------------------------------------------------- subroutine beam_solut(neqn,t,y) + use const_def, only: dp integer neqn - double precision t,y(neqn) -c -c -c computed using double precision RADAU on an -c Alphaserver DS20E, with a 667 MHz EV67 processor. -c -c uround = 1.01d-19 -c rtol = atol = h0 = 1.1d-18 -c -c - y( 1) = -0.5792366591285007D-002 - y( 2) = -0.1695298550721735D-001 - y( 3) = -0.2769103312973094D-001 - y( 4) = -0.3800815655879158D-001 - y( 5) = -0.4790616859743763D-001 - y( 6) = -0.5738710435274594D-001 - y( 7) = -0.6645327313454617D-001 - y( 8) = -0.7510730581979037D-001 - y( 9) = -0.8335219765414992D-001 - y( 10) = -0.9119134654647947D-001 - y( 11) = -0.9862858700132091D-001 - y( 12) = -0.1056682200378002D+000 - y( 13) = -0.1123150395409595D+000 - y( 14) = -0.1185743552727245D+000 - y( 15) = -0.1244520128755561D+000 - y( 16) = -0.1299544113264161D+000 - y( 17) = -0.1350885180610398D+000 - y( 18) = -0.1398618819194422D+000 - y( 19) = -0.1442826441015242D+000 - y( 20) = -0.1483595472463012D+000 - y( 21) = -0.1521019429001447D+000 - y( 22) = -0.1555197978061129D+000 - y( 23) = -0.1586236993420229D+000 - y( 24) = -0.1614248603702127D+000 - y( 25) = -0.1639351238193223D+000 - y( 26) = -0.1661669673440852D+000 - y( 27) = -0.1681335081778558D+000 - y( 28) = -0.1698485080602243D+000 - y( 29) = -0.1713263782440888D+000 - y( 30) = -0.1725821847462537D+000 - y( 31) = -0.1736316537975654D+000 - y( 32) = -0.1744911773840049D+000 - y( 33) = -0.1751778187863392D+000 - y( 34) = -0.1757093178712902D+000 - y( 35) = -0.1761040960228576D+000 - y( 36) = -0.1763812607175549D+000 - y( 37) = -0.1765606097564671D+000 - y( 38) = -0.1766626352260565D+000 - y( 39) = -0.1767085270807460D+000 - y( 40) = -0.1767201761075488D+000 - y( 41) = 0.3747362681329794D-001 - y( 42) = 0.1099117880217593D+000 - y( 43) = 0.1798360474312799D+000 - y( 44) = 0.2472427305442391D+000 - y( 45) = 0.3121293820596567D+000 - y( 46) = 0.3744947377019500D+000 - y( 47) = 0.4343386073492798D+000 - y( 48) = 0.4916620354601748D+000 - y( 49) = 0.5464677854586807D+000 - y( 50) = 0.5987609702624270D+000 - y( 51) = 0.6485493611110740D+000 - y( 52) = 0.6958435169132503D+000 - y( 53) = 0.7406572668520808D+000 - y( 54) = 0.7830081747813241D+000 - y( 55) = 0.8229176659201515D+000 - y( 56) = 0.8604110305190560D+000 - y( 57) = 0.8955175502377805D+000 - y( 58) = 0.9282708263127953D+000 - y( 59) = 0.9587089334522034D+000 - y( 60) = 0.9868747821728363D+000 - y( 61) = 0.1012816579961883D+001 - y( 62) = 0.1036587736679858D+001 - y( 63) = 0.1058246826481355D+001 - y( 64) = 0.1077857811433353D+001 - y( 65) = 0.1095490222005369D+001 - y( 66) = 0.1111219164294898D+001 - y( 67) = 0.1125125269286501D+001 - y( 68) = 0.1137294526609229D+001 - y( 69) = 0.1147818025153607D+001 - y( 70) = 0.1156792132004482D+001 - y( 71) = 0.1164318845130183D+001 - y( 72) = 0.1170505992596124D+001 - y( 73) = 0.1175467424299550D+001 - y( 74) = 0.1179323003228859D+001 - y( 75) = 0.1182198586299667D+001 - y( 76) = 0.1184226111223146D+001 - y( 77) = 0.1185543909805575D+001 - y( 78) = 0.1186297084203716D+001 - y( 79) = 0.1186637618908127D+001 - y( 80) = 0.1186724615113034D+001 - + real(dp) t,y(neqn) +! computed using real(dp) RADAU on an +! Alphaserver DS20E, with a 667 MHz EV67 processor. +! +! uround = 1.01d-19 +! rtol = atol = h0 = 1.1d-18 + y( 1) = -0.5792366591285007D-002 + y( 2) = -0.1695298550721735D-001 + y( 3) = -0.2769103312973094D-001 + y( 4) = -0.3800815655879158D-001 + y( 5) = -0.4790616859743763D-001 + y( 6) = -0.5738710435274594D-001 + y( 7) = -0.6645327313454617D-001 + y( 8) = -0.7510730581979037D-001 + y( 9) = -0.8335219765414992D-001 + y(10) = -0.9119134654647947D-001 + y(11) = -0.9862858700132091D-001 + y(12) = -0.1056682200378002D+000 + y(13) = -0.1123150395409595D+000 + y(14) = -0.1185743552727245D+000 + y(15) = -0.1244520128755561D+000 + y(16) = -0.1299544113264161D+000 + y(17) = -0.1350885180610398D+000 + y(18) = -0.1398618819194422D+000 + y(19) = -0.1442826441015242D+000 + y(20) = -0.1483595472463012D+000 + y(21) = -0.1521019429001447D+000 + y(22) = -0.1555197978061129D+000 + y(23) = -0.1586236993420229D+000 + y(24) = -0.1614248603702127D+000 + y(25) = -0.1639351238193223D+000 + y(26) = -0.1661669673440852D+000 + y(27) = -0.1681335081778558D+000 + y(28) = -0.1698485080602243D+000 + y(29) = -0.1713263782440888D+000 + y(30) = -0.1725821847462537D+000 + y(31) = -0.1736316537975654D+000 + y(32) = -0.1744911773840049D+000 + y(33) = -0.1751778187863392D+000 + y(34) = -0.1757093178712902D+000 + y(35) = -0.1761040960228576D+000 + y(36) = -0.1763812607175549D+000 + y(37) = -0.1765606097564671D+000 + y(38) = -0.1766626352260565D+000 + y(39) = -0.1767085270807460D+000 + y(40) = -0.1767201761075488D+000 + y(41) = 0.3747362681329794D-001 + y(42) = 0.1099117880217593D+000 + y(43) = 0.1798360474312799D+000 + y(44) = 0.2472427305442391D+000 + y(45) = 0.3121293820596567D+000 + y(46) = 0.3744947377019500D+000 + y(47) = 0.4343386073492798D+000 + y(48) = 0.4916620354601748D+000 + y(49) = 0.5464677854586807D+000 + y(50) = 0.5987609702624270D+000 + y(51) = 0.6485493611110740D+000 + y(52) = 0.6958435169132503D+000 + y(53) = 0.7406572668520808D+000 + y(54) = 0.7830081747813241D+000 + y(55) = 0.8229176659201515D+000 + y(56) = 0.8604110305190560D+000 + y(57) = 0.8955175502377805D+000 + y(58) = 0.9282708263127953D+000 + y(59) = 0.9587089334522034D+000 + y(60) = 0.9868747821728363D+000 + y(61) = 0.1012816579961883D+001 + y(62) = 0.1036587736679858D+001 + y(63) = 0.1058246826481355D+001 + y(64) = 0.1077857811433353D+001 + y(65) = 0.1095490222005369D+001 + y(66) = 0.1111219164294898D+001 + y(67) = 0.1125125269286501D+001 + y(68) = 0.1137294526609229D+001 + y(69) = 0.1147818025153607D+001 + y(70) = 0.1156792132004482D+001 + y(71) = 0.1164318845130183D+001 + y(72) = 0.1170505992596124D+001 + y(73) = 0.1175467424299550D+001 + y(74) = 0.1179323003228859D+001 + y(75) = 0.1182198586299667D+001 + y(76) = 0.1184226111223146D+001 + y(77) = 0.1185543909805575D+001 + y(78) = 0.1186297084203716D+001 + y(79) = 0.1186637618908127D+001 + y(80) = 0.1186724615113034D+001 + return end diff --git a/num/test/src/sample_ode_solver.f b/num/test/src/sample_ode_solver.f90 similarity index 100% rename from num/test/src/sample_ode_solver.f rename to num/test/src/sample_ode_solver.f90 diff --git a/num/test/src/test_beam.f b/num/test/src/test_beam.f90 similarity index 100% rename from num/test/src/test_beam.f rename to num/test/src/test_beam.f90 diff --git a/num/test/src/test_bobyqa.f b/num/test/src/test_bobyqa.f deleted file mode 100644 index fddf3596d..000000000 --- a/num/test/src/test_bobyqa.f +++ /dev/null @@ -1,85 +0,0 @@ - module test_bobyqa - - use num_def - use num_lib - - integer :: nfcn - - contains - - subroutine do_test_bobyqa - IMPLICIT real(dp) (A-H,O-Z) - DIMENSION X(100),XL(100),XU(100),W(10000) - real(dp), parameter :: max_valid_value = 1d99 - include 'formats' - BDL=-1.0D0 - BDU=1.0D0 - IPRINT=0 - MAXFUN=5000 - RHOEND=1.0D-6 - DO 30 N=2,6,2 - nfcn = 0 - NPT=2*N+1 - DO 10 I=1,N - XL(I)=BDL - XU(I)=BDU - 10 X(I)=DBLE(I)/DBLE(N+1) - RHOBEG=0.2D0*X(1) - PRINT 20, N,NPT - 20 FORMAT (4X,'test BOBYQA with N =',I2,' and NPT =',I3) - CALL BOBYQA (N,NPT,X,XL,XU,RHOBEG,RHOEND,IPRINT,MAXFUN,W,CALFUN,max_valid_value) - call calfun(n,x,f) - !write(*,2) 'f', nfcn, f - if (abs(f) > 1d-10) write(*,*) 'failed in test of BOBYQA: min f', f - 30 CONTINUE - END subroutine do_test_bobyqa - - - - subroutine calfun(n,x,f) - use const_def, only: dp - integer, intent(in) :: n - real(dp), intent(in) :: x(*) - real(dp), intent(out) :: f - - real(dp) :: Y(10,10) - nfcn = nfcn + 1 - DO 10 J=1,N - Y(1,J)=1.0D0 - 10 Y(2,J)=2.0D0*X(J)-1.0D0 - DO 20 I=2,N - DO 20 J=1,N - 20 Y(I+1,J)=2.0D0*Y(2,J)*Y(I,J)-Y(I-1,J) - F=0.0D0 - NP=N+1 - IW=1 - DO 40 I=1,NP - SUM=0.0D0 - DO 30 J=1,N - 30 SUM=SUM+Y(I,J) - SUM=SUM/DBLE(N) - IF (IW .GT. 0) SUM=SUM+1.0D0/DBLE(I*I-2*I) - IW=-IW - 40 F=F+SUM*SUM - RETURN - END SUBROUTINE CALFUN - - - SUBROUTINE xCALFUN (N,X,F) - implicit none - integer, intent(in) :: n - real(dp), intent(in) :: x(*) - real(dp), intent(out) :: f - integer :: i, j - real(dp) :: temp - F=0.0D0 - DO 10 I=4,N,2 - DO 10 J=2,I-2,2 - TEMP=(X(I-1)-X(J-1))**2+(X(I)-X(J))**2 - TEMP=DMAX1(TEMP,1.0D-6) - 10 F=F+1.0D0/DSQRT(TEMP) - RETURN - END SUBROUTINE xCALFUN - - - end module test_bobyqa diff --git a/num/test/src/test_bobyqa.f90 b/num/test/src/test_bobyqa.f90 new file mode 100644 index 000000000..63a6883a7 --- /dev/null +++ b/num/test/src/test_bobyqa.f90 @@ -0,0 +1,93 @@ +module test_bobyqa + + use num_def + use num_lib + + implicit none + + integer :: nfcn + +contains + + subroutine do_test_bobyqa + real(dp), dimension(100) :: X, XL, XU + real(dp), dimension(10000) :: W + real(dp), parameter :: max_valid_value = 1d99 + real(dp), parameter :: BDL = -1.0d0 + real(dp), parameter :: BDU = 1.0d0 + real(dp) :: f, RHOBEG, RHOend + integer :: I, IPRINT, N, MAXFUN, NPT + include 'formats' + IPRINT = 0 + MAXFUN = 5000 + RHOend = 1.0D-6 + do N = 2, 6, 2 + nfcn = 0 + NPT = 2*N + 1 + do I = 1, N + XL(I) = BDL + XU(I) = BDU + X(I) = DBLE(I)/DBLE(N + 1) + end do + RHOBEG = 0.2D0*X(1) + write (*, '(4X,A,I2,A,I3)') 'test BOBYQA with N =', N, ' and NPT =', NPT + call BOBYQA(N, NPT, X, XL, XU, RHOBEG, RHOend, IPRINT, MAXFUN, W, CALFUN, max_valid_value) + call calfun(n, x, f) + !write(*,2) 'f', nfcn, f + if (abs(f) > 1d-10) write (*, *) 'failed in test of BOBYQA: min f', f + end do + end subroutine do_test_bobyqa + + subroutine calfun(n, x, f) + use const_def, only: dp + integer, intent(in) :: n + real(dp), intent(in) :: x(*) + real(dp), intent(out) :: f + integer :: i, j, iw, np + real(dp) :: sum + + real(dp) :: Y(10, 10) + nfcn = nfcn + 1 + do J = 1, N + Y(1, J) = 1.0D0 + Y(2, J) = 2.0D0*X(J) - 1.0D0 + end do + do I = 2, N + do J = 1, N + Y(I + 1, J) = 2.0D0*Y(2, J)*Y(I, J) - Y(I - 1, J) + end do + end do + F = 0.0D0 + NP = N + 1 + IW = 1 + do I = 1, NP + SUM = 0.0D0 + do J = 1, N + SUM = SUM + Y(I, J) + end do + SUM = SUM/DBLE(N) + IF (IW .GT. 0) SUM = SUM + 1.0D0/DBLE(I*I - 2*I) + IW = -IW + F = F + SUM*SUM + end do + RETURN + end subroutine CALFUN + + subroutine xCALFUN(N, X, F) + integer, intent(in) :: n + real(dp), intent(in) :: x(*) + real(dp), intent(out) :: f + integer :: i, j + real(dp) :: temp + F = 0.0D0 + do I = 4, N, 2 + do J = 2, I - 2, 2 + TEMP = (X(I - 1) - X(J - 1))**2 + (X(I) - X(J))**2 + TEMP = DMAX1(TEMP, 1.0D-6) + F = F + 1.0D0/DSQRT(TEMP) + end do + end do + RETURN + end subroutine xCALFUN + +end module test_bobyqa diff --git a/num/test/src/test_brent.f b/num/test/src/test_brent.f90 similarity index 77% rename from num/test/src/test_brent.f rename to num/test/src/test_brent.f90 index e2ce34f93..16f5a80bd 100644 --- a/num/test/src/test_brent.f +++ b/num/test/src/test_brent.f90 @@ -4,6 +4,7 @@ module test_brent use num_lib use math_lib use utils_lib, only: mesa_error + use const_def, only: dp implicit none @@ -45,13 +46,13 @@ subroutine test_global_min_all ! implicit none - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) c - real ( kind = 8 ) e - real ( kind = 8 ) m - real ( kind = 8 ) machep - real ( kind = 8 ) t + real(dp) a + real(dp) b + real(dp) c + real(dp) e + real(dp) m + real(dp) machep + real(dp) t write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST_GLOMIN_ALL' @@ -133,18 +134,19 @@ end subroutine test_global_min_all subroutine test_glomin_one ( a, b, c, m, machep, e, t, f, title ) - real*8, intent(in) :: a, b, c, m, machep, e, t + real(dp), intent(in) :: a, b, c, m, machep, e, t interface - real*8 function f(x) - real*8, intent(in) :: x + real(dp) function f(x) + use const_def, only: dp + real(dp), intent(in) :: x end function f end interface - real ( kind = 8 ) fa - real ( kind = 8 ) fb - real ( kind = 8 ) fx + real (dp) fa + real (dp) fb + real (dp) fx character ( len = * ) title - real ( kind = 8 ) x + real (dp) x integer :: max_tries, ierr include 'formats' @@ -167,28 +169,28 @@ end function f end subroutine test_glomin_one - real*8 function h_01 ( x ) - real*8, intent(in) :: x + real(dp) function h_01 ( x ) + real(dp), intent(in) :: x h_01 = 2.0D+00 - x end function h_01 - real*8 function h_02 ( x ) - real*8, intent(in) :: x + real(dp) function h_02 ( x ) + real(dp), intent(in) :: x h_02 = x * x end function h_02 - real*8 function h_03 ( x ) - real*8, intent(in) :: x + real(dp) function h_03 ( x ) + real(dp), intent(in) :: x h_03 = x * x * ( x + 1.0D+00 ) end function h_03 - real*8 function h_04 ( x ) - real*8, intent(in) :: x + real(dp) function h_04 ( x ) + real(dp), intent(in) :: x h_04 = ( x + sin ( x ) ) * exp( - x * x ) end function h_04 - real*8 function h_05 ( x ) - real*8, intent(in) :: x + real(dp) function h_05 ( x ) + real(dp), intent(in) :: x h_05 = ( x - sin ( x ) ) * exp( - x * x ) end function h_05 @@ -213,10 +215,10 @@ subroutine test_local_min_all ! implicit none - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) eps - real ( kind = 8 ) t + real(dp) a + real(dp) b + real(dp) eps + real(dp) t write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST_LOCAL_MIN_ALL' @@ -281,31 +283,32 @@ subroutine test_local_min_one ( a, b, eps, t, f, title ) ! ! Parameters: ! - ! Input, real ( kind = 8 ) A, B, the endpoints of the interval. + ! Input, real(dp) A, B, the endpoints of the interval. ! - ! Input, real ( kind = 8 ) EPS, a positive relative error tolerance. + ! Input, real(dp) EPS, a positive relative error tolerance. ! - ! Input, real ( kind = 8 ) T, a positive absolute error tolerance. + ! Input, real(dp) T, a positive absolute error tolerance. ! - ! Input, external real ( kind = 8 ) F, the name of a user-supplied + ! Input, external real(dp) F, the name of a user-supplied ! function, of the form "FUNCTION F ( X )", which evaluates the ! function whose local minimum is being sought. ! ! Input, character ( LEN = * ) TITLE, a title for the problem. ! implicit none - real*8, intent(in) :: a, b, eps, t + real(dp), intent(in) :: a, b, eps, t interface - real*8 function f(x) - real*8, intent(in) :: x + real(dp) function f(x) + use const_def, only: dp + real(dp), intent(in) :: x end function f end interface character (len=*) :: title - real ( kind = 8 ) fa - real ( kind = 8 ) fb - real ( kind = 8 ) fx - real ( kind = 8 ) x + real (dp) fa + real (dp) fb + real (dp) fx + real (dp) x integer :: max_tries, ierr include 'formats' @@ -327,86 +330,86 @@ end function f return end subroutine test_local_min_one - real*8 function g_01 ( x ) - real*8, intent(in) :: x + real(dp) function g_01 ( x ) + real(dp), intent(in) :: x g_01 = ( x - 2.0D+00 ) * ( x - 2.0D+00 ) + 1.0D+00 end function g_01 - real*8 function g_02 ( x ) - real*8, intent(in) :: x + real(dp) function g_02 ( x ) + real(dp), intent(in) :: x g_02 = x * x + exp( - x ) end function g_02 - real*8 function g_03 ( x ) - real*8, intent(in) :: x + real(dp) function g_03 ( x ) + real(dp), intent(in) :: x g_03 = ( ( x * x + 2.0D+00 ) * x + 1.0D+00 ) * x + 3.0D+00 end function g_03 - real*8 function g_04 ( x ) - real*8, intent(in) :: x + real(dp) function g_04 ( x ) + real(dp), intent(in) :: x g_04 = exp( x ) + 0.01D+00 / x end function g_04 - real*8 function g_05 ( x ) - real*8, intent(in) :: x + real(dp) function g_05 ( x ) + real(dp), intent(in) :: x g_05 = exp( x ) - 2.0D+00 * x + 0.01D+00 / x - 0.000001D+00 / x / x end function g_05 - real*8 function f_01 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) + real(dp) function f_01 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar - real*8, intent(in) :: x - real*8, intent(out) :: dfdx + real(dp), intent(in) :: x + real(dp), intent(out) :: dfdx integer, intent(inout), pointer :: ipar(:) ! (lipar) - real*8, intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr f_01 = sin ( x ) - 0.5D+00 * x ierr = 0 dfdx = 0 end function f_01 - real*8 function f_02 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) + real(dp) function f_02 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar - real*8, intent(in) :: x - real*8, intent(out) :: dfdx + real(dp), intent(in) :: x + real(dp), intent(out) :: dfdx integer, intent(inout), pointer :: ipar(:) ! (lipar) - real*8, intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr f_02 = 2.0D+00 * x - exp( - x ) ierr = 0 dfdx = 0 end function f_02 - real*8 function f_03 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) + real(dp) function f_03 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar - real*8, intent(in) :: x - real*8, intent(out) :: dfdx + real(dp), intent(in) :: x + real(dp), intent(out) :: dfdx integer, intent(inout), pointer :: ipar(:) ! (lipar) - real*8, intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr f_03 = x * exp( - x ) ierr = 0 dfdx = 0 end function f_03 - real*8 function f_04 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) + real(dp) function f_04 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar - real*8, intent(in) :: x - real*8, intent(out) :: dfdx + real(dp), intent(in) :: x + real(dp), intent(out) :: dfdx integer, intent(inout), pointer :: ipar(:) ! (lipar) - real*8, intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr f_04 = exp( x ) - 1.0D+00 / 100.0D+00 / x / x ierr = 0 dfdx = 0 end function f_04 - real*8 function f_05 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) + real(dp) function f_05 ( x, dfdx, lrpar, rpar, lipar, ipar, ierr ) integer, intent(in) :: lrpar, lipar - real*8, intent(in) :: x - real*8, intent(out) :: dfdx + real(dp), intent(in) :: x + real(dp), intent(out) :: dfdx integer, intent(inout), pointer :: ipar(:) ! (lipar) - real*8, intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) integer, intent(out) :: ierr f_05 = ( x + 3.0D+00 ) * ( x - 1.0D+00 ) * ( x - 1.0D+00 ) ierr = 0 @@ -434,10 +437,10 @@ subroutine test_brent_zero ( ) ! implicit none - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) machep - real ( kind = 8 ) t + real(dp) a + real(dp) b + real(dp) machep + real(dp) t machep = epsilon ( machep ) t = machep @@ -497,15 +500,15 @@ subroutine test_zero_one ( a, b, machep, t, f, title ) ! ! Parameters: ! - ! Input, real ( kind = 8 ) A, B, the two endpoints of the change of sign + ! Input, real(dp) A, B, the two endpoints of the change of sign ! interval. ! - ! Input, real ( kind = 8 ) MACHEP, an estimate for the relative machine + ! Input, real(dp) MACHEP, an estimate for the relative machine ! precision. ! - ! Input, real ( kind = 8 ) T, a positive error tolerance. + ! Input, real(dp) T, a positive error tolerance. ! - ! Input, external real ( kind = 8 ) F, the name of a user-supplied + ! Input, external real(dp) F, the name of a user-supplied ! function, of the form "FUNCTION F ( X )", which evaluates the ! function whose zero is being sought. ! @@ -517,22 +520,22 @@ subroutine test_zero_one ( a, b, machep, t, f, title ) include 'num_root_fcn.dek' ! f provides function values end interface - real ( kind = 8 ) a - real ( kind = 8 ) b - real ( kind = 8 ) fa - real ( kind = 8 ) fb - real ( kind = 8 ) fz - real ( kind = 8 ) machep - real ( kind = 8 ) t + real(dp) a + real(dp) b + real(dp) fa + real(dp) fb + real(dp) fz + real(dp) machep + real(dp) t character ( len = * ) title - real ( kind = 8 ) z - real ( kind = 8 ) dfdx + real(dp) z + real(dp) dfdx integer, parameter :: lrpar = 0, lipar = 0 integer :: ierr - real*8, target :: rpar_ary(lrpar) + real(dp), target :: rpar_ary(lrpar) integer, target :: ipar_ary(lipar) - real*8, pointer :: rpar(:) + real(dp), pointer :: rpar(:) integer, pointer :: ipar(:) include 'formats' diff --git a/num/test/src/test_chemakzo.f b/num/test/src/test_chemakzo.f90 similarity index 100% rename from num/test/src/test_chemakzo.f rename to num/test/src/test_chemakzo.f90 diff --git a/num/test/src/test_diffusion.f b/num/test/src/test_diffusion.f90 similarity index 100% rename from num/test/src/test_diffusion.f rename to num/test/src/test_diffusion.f90 diff --git a/num/test/src/test_int_support.f b/num/test/src/test_int_support.f90 similarity index 100% rename from num/test/src/test_int_support.f rename to num/test/src/test_int_support.f90 diff --git a/num/test/src/test_integrate.f b/num/test/src/test_integrate.f90 similarity index 100% rename from num/test/src/test_integrate.f rename to num/test/src/test_integrate.f90 diff --git a/num/test/src/test_medakzo.f b/num/test/src/test_medakzo.f deleted file mode 100644 index bafadf9d3..000000000 --- a/num/test/src/test_medakzo.f +++ /dev/null @@ -1,415 +0,0 @@ - module test_medakzo - use num_def - use num_lib - use mtx_lib - use mtx_def - use test_int_support, only: i_nfcn, i_njac - use utils_lib, only: mesa_error - - implicit none - - integer :: mljac, mujac - - contains - - - subroutine medakzo_feval_for_blk_dble(neqn,t,y,yprime,f,ierr,rpar,ipar) - integer neqn,ierr,ipar(:) - double precision t,y(:),yprime(:),f(:),rpar(:) - - integer N,i,j - double precision zeta,dzeta,dzeta2,k,c,phi,alpha,beta,gama,dum - parameter(k=100d0,c=4d0) - - include 'formats' - - N = neqn/2 - dzeta = 1d0/dble(N) - dzeta2 = dzeta*dzeta - dum = (dzeta-1d0)*(dzeta-1d0)/c - alpha = 2d0*(dzeta-1d0)*dum/c - beta = dum*dum - - if (t.le.5d0) then - phi = 2d0 - else - phi = 0d0 - endif - - f(1) = (phi-2d0*y(1)+y(3))*beta/dzeta2+alpha*(y(3)-phi)/(2d0*dzeta)-k*y(1)*y(2) - f(2) = -k*y(1)*y(2) - - do 10 j=2,N-1 - i = 2*j-1 - zeta = j*dzeta - dum = (zeta-1d0)*(zeta-1d0)/c - alpha = 2d0*(zeta-1d0)*dum/c - beta = dum*dum - gama = (y(i-2)-2d0*y(i)+y(i+2))*beta/dzeta2+alpha*(y(i+2)-y(i-2))/(2d0*dzeta) - f(i) = gama-k*y(i)*y(i+1) - i = 2*j - f(i) = -k*y(i)*y(i-1) - 10 continue - - f(2*N-1) = -k*y(2*N-1)*y(2*N) - f(2*N) = -k*y(2*N-1)*y(2*N) - - return - end subroutine medakzo_feval_for_blk_dble - - - subroutine medakzo_jeval_for_blk_dble(ldim,neqn,t,y,yprime,dfdy,ierr,rpar,ipar) - integer ldim,neqn,ierr,ipar(:) - double precision t,y(:),yprime(:),dfdy(:,:),rpar(:) - - integer N,i,j - double precision zeta,dzeta,dzeta2,alpha,beta,k,c,dum,bz - parameter(k=100d0,c=4d0) - - do 20 j=1,neqn - do 10 i=1,5 - dfdy(i,j) = 0d0 - 10 continue - 20 continue - - N = neqn/2 - dzeta = 1d0/dble(N) - dzeta2 = dzeta*dzeta - dum = (dzeta-1d0)*(dzeta-1d0)/c - alpha = 2d0*(dzeta-1d0)*dum/c - beta = dum*dum - - dfdy(3,1) = -beta*2d0/dzeta2-k*y(2) - dfdy(1,3) = beta/dzeta2+alpha/(2d0*dzeta) - dfdy(2,2) = -k*y(1) - dfdy(4,1) = -k*y(2) - dfdy(3,2) = -k*y(1) - - do 30 j=2,N-1 - i = 2*j-1 - zeta = j*dzeta - dum = (zeta-1d0)*(zeta-1d0)/c - alpha = 2d0*(zeta-1d0)*dum/c - beta = dum*dum - bz = beta/dzeta2 - dfdy(5,i-2) = bz-alpha/(2d0*dzeta) - dfdy(3,i) = -2d0*bz-k*y(i+1) - dfdy(1,i+2) = bz+alpha/(2d0*dzeta) - dfdy(2,i+1) = -k*y(i) - i = 2*j - dfdy(4,i-1) = -k*y(i) - dfdy(3,i) = -k*y(i-1) - 30 continue - - dfdy(3,2*N-1) = -k*y(2*N) - dfdy(2,2*N) = -k*y(2*N-1) - dfdy(4,2*N-1) = -k*y(2*N) - dfdy(3,2*N) = -k*y(2*N-1) - - return - end subroutine medakzo_jeval_for_blk_dble - - - subroutine medakzo_fcn_blk_dble(n,caller_id,nvar,nz,x,h,y,f,lrpar,rpar,lipar,ipar,ierr) - use const_def, only: dp - integer, intent(in) :: n, caller_id, nvar, nz, lrpar, lipar - real(dp), intent(in) :: x,h - real(dp), intent(inout), pointer :: y(:) ! (n) - real(dp), intent(inout), pointer :: f(:) ! (n) ! dy/dx - integer, intent(inout), pointer :: ipar(:) ! (lipar) - real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - integer, intent(out) :: ierr - real(dp), target :: yprime_ary(n) - real(dp), pointer :: yprime(:) - ierr = 0 - ipar(i_nfcn) = ipar(i_nfcn) + 1 - yprime => yprime_ary - call medakzo_feval_for_blk_dble(n,x,y,yprime,f,ierr,rpar,ipar) - end subroutine medakzo_fcn_blk_dble - - - subroutine medakzo_derivs(n, x, h, vars, dvars_dx, lrpar, rpar, lipar, ipar, ierr) - integer, intent(in) :: n, lrpar, lipar - real(dp), intent(in) :: x,h - real(dp), intent(inout) :: vars(:) ! (n) - real(dp), intent(inout) :: dvars_dx(:) ! (n) - integer, intent(inout), pointer :: ipar(:) ! (lipar) - real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - real(dp) :: yprime(n) - integer, intent(out) :: ierr - include 'formats' - ierr = 0 - ipar(i_nfcn) = ipar(i_nfcn) + 1 - call medakzo_feval(n,x,vars,yprime,dvars_dx,ierr,rpar,ipar) - end subroutine medakzo_derivs - - - subroutine medakzo_jac_blk_dble(n,caller_id,nvar,nz,x,h,y,f,lblk1,dblk1,ublk1,lrpar,rpar,lipar,ipar,ierr) - use const_def,only: dp - integer,intent(in) :: n,caller_id,nvar,nz,lrpar,lipar - real(dp),intent(in) :: x,h - real(dp),intent(inout), pointer :: y(:) ! (n) - real(dp),intent(inout), pointer :: f(:) ! (n) ! dy/dx - real(dp),dimension(:),pointer,intent(inout) :: lblk1,dblk1,ublk1 ! =(nvar,nvar,nz) - integer,intent(inout),pointer :: ipar(:) ! (lipar) - real(dp),intent(inout),pointer :: rpar(:) ! (lrpar) - integer,intent(out) :: ierr - - real(dp),dimension(:,:,:),pointer :: lblk,dblk,ublk ! =(nvar,nvar,nz) - integer, parameter :: ld_dfdy = 5 ! for medakzo - real(dp), target :: dfdy1(ld_dfdy*n) - real(dp), pointer :: dfdy(:,:) - !real(dp), pointer :: banded(:,:,:) - integer :: i, k - ierr = 0 - dfdy(1:ld_dfdy,1:n) => dfdy1(1:ld_dfdy*n) - - ierr = 0 - ipar(i_njac) = ipar(i_njac) + 1 - call medakzo_jeval_for_blk_dble(ld_dfdy,n,x,y,f,dfdy,ierr,rpar,ipar) - if (ierr == 0) call medakzo_fcn_blk_dble(n,caller_id,nvar,nz,x,h,y,f,lrpar,rpar,lipar,ipar,ierr) - - !banded(1:ld_dfdy,1:nvar,1:nz) => dfdy1(1:ld_dfdy*n) - lblk(1:nvar,1:nvar,1:nz) => lblk1(1:nvar*nvar*nz) - dblk(1:nvar,1:nvar,1:nz) => dblk1(1:nvar*nvar*nz) - ublk(1:nvar,1:nvar,1:nz) => ublk1(1:nvar*nvar*nz) - - ! convert from banded to block tridiagonal - ! lblk(:,:,1) is not used; ublk(:,:,nz) is not used. - k = 1 - dblk(1,1,k) = dfdy(3,1) ! partial of f(1,k) wrt var(1,k) dfdy(3,i) - dblk(1,2,k) = dfdy(2,2) ! partial of f(1,k) wrt var(2,k) dfdy(2,i+1) - dblk(2,1,k) = dfdy(4,1) ! partial of f(2,k) wrt var(1,k) dfdy(4,i) - dblk(2,2,k) = dfdy(3,2) ! partial of f(2,k) wrt var(2,k) dfdy(3,i+1) - ublk(1,1,k) = dfdy(1,3) ! partial of f(1,k) wrt var(1,k+1) dfdy(1,i+2) - -!dfdy(1,i+2) partial of f(1,k) wrt var(1,k+1) -!dfdy(2,i+1) partial of f(1,k) wrt var(2,k) -!dfdy(3,i) partial of f(1,k) wrt var(1,k) -!dfdy(3,i+1) partial of f(2,k) wrt var(2,k) -!dfdy(4,i) partial of f(2,k) wrt var(1,k) -!dfdy(5,i-2) partial of f(1,k) wrt var(1,k-1) - - do k=2,nz-1 - i = 2*k-1 - ! set lblk - lblk(1,1,k) = dfdy(5,i-2) ! partial of f(1,k) wrt var(1,k-1) - lblk(1,2,k) = 0 ! partial of f(1,k) wrt var(2,k-1) - lblk(2,1,k) = 0 ! partial of f(2,k) wrt var(1,k-1) - lblk(2,2,k) = 0 ! partial of f(2,k) wrt var(2,k-1) - ! set dblk - dblk(1,1,k) = dfdy(3,i) ! partial of f(1,k) wrt var(1,k) dfdy(3,i) - dblk(1,2,k) = dfdy(2,i+1) ! partial of f(1,k) wrt var(2,k) dfdy(2,i+1) - dblk(2,1,k) = dfdy(4,i) ! partial of f(2,k) wrt var(1,k) dfdy(4,i) - dblk(2,2,k) = dfdy(3,i+1) ! partial of f(2,k) wrt var(2,k) dfdy(3,i+1) - ! set ublk - ublk(1,1,k) = dfdy(1,i+2) ! partial of f(1,k) wrt var(1,k+1) dfdy(1,i+2) - ublk(2,1,k) = 0 ! partial of f(2,k) wrt var(1,k+1) - ublk(1,2,k) = 0 ! partial of f(1,k) wrt var(2,k+1) - ublk(2,2,k) = 0 ! partial of f(2,k) wrt var(2,k+1) - end do - - k = nz - i = 2*k-1 - dblk(1,1,k) = dfdy(3,i) ! partial of f(1,k) wrt var(1,k) - dblk(1,2,k) = dfdy(2,i+1) ! partial of f(1,k) wrt var(2,k) - dblk(2,1,k) = dfdy(4,i) ! partial of f(2,k) wrt var(1,k) - dblk(2,2,k) = dfdy(3,i+1) ! partial of f(2,k) wrt var(2,k) - - end subroutine medakzo_jac_blk_dble - - - subroutine medakzo_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) - integer, intent(in) :: n, ld_dfdy, lrpar, lipar - real(dp), intent(in) :: x, h - real(dp), intent(inout) :: y(:) - real(dp), intent(inout) :: f(:), dfdy(:,:) - integer, intent(inout), pointer :: ipar(:) ! (lipar) - real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - real(dp) :: yprime(n) - integer, intent(out) :: ierr - include 'formats' - ierr = 0 - ipar(i_njac) = ipar(i_njac) + 1 - call medakzo_jeval(ld_dfdy,n,x,y,yprime,dfdy,ierr,rpar,ipar) - if (ierr == 0) call medakzo_derivs(n, x, h, y, f, lrpar,rpar,lipar,ipar, ierr) - !write(*,*) - !write(*,2)'medakzo_jacob', ipar(i_njac), x, y(1), dfdy(3,1:2) - end subroutine medakzo_jacob - - - subroutine medakzo_sjac(n,x,h,y,f,nzmax,ia,ja,values,lrpar,rpar,lipar,ipar,ierr) - ! sparse jacobian. format either compressed row or compressed column. - use mtx_lib,only:band_to_row_sparse_with_diag,band_to_col_sparse_with_diag,mtx_rcond_banded - use test_int_support,only:ipar_sparse_format - integer, intent(in) :: n, nzmax, lrpar, lipar - real(dp), intent(in) :: x, h - real(dp), intent(inout) :: y(:) ! (n) - real(dp), intent(inout) :: f(:) ! (n) ! dy/dx - integer, intent(inout) :: ia(:) ! (n+1) - integer, intent(inout) :: ja(:) ! (nzmax) - real(dp), intent(inout) :: values(:) ! (nzmax) - integer, intent(inout), pointer :: ipar(:) ! (lipar) - real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - integer, intent(out) :: ierr ! nonzero means terminate integration - - real(dp) :: dfdy(n,n) - integer :: ld_dfdy, nz - ld_dfdy = n - ierr = 0 - call medakzo_jacob(n,x,h,y,f,dfdy,ld_dfdy,lrpar,rpar,lipar,ipar,ierr) - if (ierr /= 0) return - if (ipar(ipar_sparse_format) == 0) then - call band_to_row_sparse_with_diag(n,mljac,mujac,dfdy,ld_dfdy,nzmax,nz,ia,ja,values,ierr) - else - call band_to_col_sparse_with_diag(n,mljac,mujac,dfdy,ld_dfdy,nzmax,nz,ia,ja,values,ierr) - end if - end subroutine medakzo_sjac - - - subroutine do_test_medakzo(which_solver,which_decsol,numerical_jacobian,show_all,quiet) - use test_support,only:show_results,show_statistics,check_results - use test_int_support,only:do_test_stiff_int - integer, intent(in) :: which_solver,which_decsol - logical, intent(in) :: numerical_jacobian,show_all,quiet - - integer, parameter :: nvar = 2, nz = 200 - integer, parameter :: n = nvar*nz ! the number of variables in the "medakzo" system of ODEs - real(dp), target :: y_ary(n), yprime(n), yexact(n) - real(dp), pointer :: y(:) - integer, parameter :: lrpar = 1, lipar = 3, iout=1 - logical :: consis - integer, parameter :: ndisc = 1, n_soln=11 - real(dp) :: result(n_soln), soln(n_soln), h0, t(0:ndisc+1), atol(1), rtol(1) - integer :: j, k, matrix_type_spec, ierr, imas, mlmas, mumas, m1, m2, itol, nstep - real(dp), target :: rpar_ary(lrpar) - integer, target :: ipar_ary(lipar) - real(dp), pointer :: rpar(:) - integer, pointer :: ipar(:) - integer :: caller_id, nvar_blk_dble, nz_blk_dble - real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) - real(dp), dimension(:), pointer :: uf_lblk, uf_dblk, uf_ublk ! =(nvar,nvar,nz) - logical, parameter :: dbg = .false. - - include 'formats' - - rpar => rpar_ary - ipar => ipar_ary - y => y_ary - - if (.not. quiet) write(*,*) 'medakzo' - - nullify(lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk) - caller_id = 0 - nvar_blk_dble = 0 - nz_blk_dble = 0 - - t(0) = 0d0 - if (dbg) then - t(1) = 0.05d0 - t(2) = 0.20d0 - else - t(1) = 5d0 - t(2) = 20d0 - end if - - itol = 0 ! scalar tolerances - rtol = 1d-6 - atol = 1d-6 - h0 = 1d-9 ! initial step size - - matrix_type_spec = banded_matrix_type - mljac = 2 - mujac = 2 - - imas = 0 - mlmas = 0 - mumas = 0 - - m1 = 0 - m2 = 0 - - call medakzo_init(n,y,yprime,consis) - nstep=0 - - if (nvar_blk_dble == 0) then - call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & - medakzo_derivs,medakzo_jacob,medakzo_sjac,medakzo_solout,iout, & - null_fcn_blk_dble,null_jac_blk_dble, & - caller_id,nvar_blk_dble,nz_blk_dble,lblk,dblk,ublk,uf_lblk,uf_dblk,uf_ublk, & - n,ndisc,mljac,mujac,matrix_type_spec,null_mas,imas,mlmas,mumas,m1,m2, & - t,rtol,atol,itol,h0,y,nstep,lrpar,rpar,lipar,ipar,quiet,ierr) - else - call do_test_stiff_int(which_solver,which_decsol,numerical_jacobian, & - null_fcn,null_jac,null_sjac,medakzo_solout,iout, & - medakzo_fcn_blk_dble,medakzo_jac_blk_dble, & - caller_id,nvar_blk_dble,nz_blk_dble,lblk,dblk,ublk,uf_lblk,uf_dblk,uf_ublk, & - n,ndisc,mljac,mujac,matrix_type_spec,null_mas,imas,mlmas,mumas,m1,m2, & - t,rtol,atol,itol,h0,y,nstep,lrpar,rpar,lipar,ipar,quiet,ierr) - end if - if (ierr /= 0) then - write(*,*) 'test_medakzo ierr', ierr - call mesa_error(__FILE__,__LINE__) - end if - - call medakzo_solut(n,0d0,yexact) - j = 1 - do k = 1, n/2, max(1,(n/2-1)/11) - if (j > n_soln) exit - result(j) = y(1+2*(k-1)) - soln(j) = yexact(1+2*(k-1)) - j = j+1 - end do - - if (.not. dbg) then - call check_results(n,y,yexact,rtol(1)*50,ierr) - if (ierr /= 0) then - write(*,*) 'check results ierr', ierr - !call mesa_error(__FILE__,__LINE__) ! do_test_medakzo - end if - end if - - if (quiet) return - - call show_results(n_soln,result,soln,show_all) - call show_statistics(ipar(i_nfcn),ipar(i_njac),nstep,show_all) - - end subroutine do_test_medakzo - - - subroutine medakzo_solout(nr,xold,x,n,y,rwork,iwork,interp_y,lrpar,rpar,lipar,ipar,irtrn) - ! nr is the step number. - ! x is the current x value; xold is the previous x value. - ! y is the current y value. - ! irtrn negative means terminate integration. - ! rwork and iwork hold info for - integer, intent(in) :: nr, n, lrpar, lipar - real(dp), intent(in) :: xold, x - real(dp), intent(inout) :: y(:) ! (n) - real(dp), intent(inout), target :: rwork(*) - integer, intent(inout), target :: iwork(*) - integer, intent(inout), pointer :: ipar(:) ! (lipar) - real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) - interface - ! this subroutine can be called from your solout routine. - ! it computes interpolated values for y components during the just completed step. - real(dp) function interp_y(i,s,rwork,iwork,ierr) - use const_def, only: dp - integer, intent(in) :: i ! result is interpolated approximation of y(i) at x=s. - real(dp), intent(in) :: s ! interpolation x value (between xold and x). - real(dp), intent(inout), target :: rwork(*) - integer, intent(inout), target :: iwork(*) - integer, intent(out) :: ierr - end function interp_y - end interface - integer, intent(out) :: irtrn - integer :: ierr - include 'formats' - !if (mod(nr,10) == 0) write(*,2) 'step', nr, x, y(1:2) - !if (nr >= 100) stop - ierr = 0 - irtrn = 0 - end subroutine medakzo_solout - - - end module test_medakzo diff --git a/num/test/src/test_medakzo.f90 b/num/test/src/test_medakzo.f90 new file mode 100644 index 000000000..9176fae49 --- /dev/null +++ b/num/test/src/test_medakzo.f90 @@ -0,0 +1,405 @@ +module test_medakzo + use num_def + use num_lib + use mtx_lib + use mtx_def + use test_int_support, only: i_nfcn, i_njac + use utils_lib, only: mesa_error + + implicit none + + integer :: mljac, mujac + +contains + + subroutine medakzo_feval_for_blk_dble(neqn, t, y, yprime, f, ierr, rpar, ipar) + integer neqn, ierr, ipar(:) + double precision t, y(:), yprime(:), f(:), rpar(:) + + integer N, i, j + double precision zeta, dzeta, dzeta2, k, c, phi, alpha, beta, gama, dum + parameter(k=100d0, c=4d0) + + include 'formats' + + N = neqn/2 + dzeta = 1d0/dble(N) + dzeta2 = dzeta*dzeta + dum = (dzeta - 1d0)*(dzeta - 1d0)/c + alpha = 2d0*(dzeta - 1d0)*dum/c + beta = dum*dum + + if (t .le. 5d0) then + phi = 2d0 + else + phi = 0d0 + end if + + f(1) = (phi - 2d0*y(1) + y(3))*beta/dzeta2 + alpha*(y(3) - phi)/(2d0*dzeta) - k*y(1)*y(2) + f(2) = -k*y(1)*y(2) + + do j = 2, N - 1 + i = 2*j - 1 + zeta = j*dzeta + dum = (zeta - 1d0)*(zeta - 1d0)/c + alpha = 2d0*(zeta - 1d0)*dum/c + beta = dum*dum + gama = (y(i - 2) - 2d0*y(i) + y(i + 2))*beta/dzeta2 + alpha*(y(i + 2) - y(i - 2))/(2d0*dzeta) + f(i) = gama - k*y(i)*y(i + 1) + i = 2*j + f(i) = -k*y(i)*y(i - 1) + end do + + f(2*N - 1) = -k*y(2*N - 1)*y(2*N) + f(2*N) = -k*y(2*N - 1)*y(2*N) + + return + end subroutine medakzo_feval_for_blk_dble + + subroutine medakzo_jeval_for_blk_dble(ldim, neqn, t, y, yprime, dfdy, ierr, rpar, ipar) + integer ldim, neqn, ierr, ipar(:) + double precision t, y(:), yprime(:), dfdy(:, :), rpar(:) + + integer N, i, j + double precision zeta, dzeta, dzeta2, alpha, beta, k, c, dum, bz + parameter(k=100d0, c=4d0) + + do j = 1, neqn + do i = 1, 5 + dfdy(i, j) = 0d0 + end do + end do + + N = neqn/2 + dzeta = 1d0/dble(N) + dzeta2 = dzeta*dzeta + dum = (dzeta - 1d0)*(dzeta - 1d0)/c + alpha = 2d0*(dzeta - 1d0)*dum/c + beta = dum*dum + + dfdy(3, 1) = -beta*2d0/dzeta2 - k*y(2) + dfdy(1, 3) = beta/dzeta2 + alpha/(2d0*dzeta) + dfdy(2, 2) = -k*y(1) + dfdy(4, 1) = -k*y(2) + dfdy(3, 2) = -k*y(1) + + do j = 2, N - 1 + i = 2*j - 1 + zeta = j*dzeta + dum = (zeta - 1d0)*(zeta - 1d0)/c + alpha = 2d0*(zeta - 1d0)*dum/c + beta = dum*dum + bz = beta/dzeta2 + dfdy(5, i - 2) = bz - alpha/(2d0*dzeta) + dfdy(3, i) = -2d0*bz - k*y(i + 1) + dfdy(1, i + 2) = bz + alpha/(2d0*dzeta) + dfdy(2, i + 1) = -k*y(i) + i = 2*j + dfdy(4, i - 1) = -k*y(i) + dfdy(3, i) = -k*y(i - 1) + end do + + dfdy(3, 2*N - 1) = -k*y(2*N) + dfdy(2, 2*N) = -k*y(2*N - 1) + dfdy(4, 2*N - 1) = -k*y(2*N) + dfdy(3, 2*N) = -k*y(2*N - 1) + + return + end subroutine medakzo_jeval_for_blk_dble + + subroutine medakzo_fcn_blk_dble(n, caller_id, nvar, nz, x, h, y, f, lrpar, rpar, lipar, ipar, ierr) + use const_def, only: dp + integer, intent(in) :: n, caller_id, nvar, nz, lrpar, lipar + real(dp), intent(in) :: x, h + real(dp), intent(inout), pointer :: y(:) ! (n) + real(dp), intent(inout), pointer :: f(:) ! (n) ! dy/dx + integer, intent(inout), pointer :: ipar(:) ! (lipar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + integer, intent(out) :: ierr + real(dp), target :: yprime_ary(n) + real(dp), pointer :: yprime(:) + ierr = 0 + ipar(i_nfcn) = ipar(i_nfcn) + 1 + yprime => yprime_ary + call medakzo_feval_for_blk_dble(n, x, y, yprime, f, ierr, rpar, ipar) + end subroutine medakzo_fcn_blk_dble + + subroutine medakzo_derivs(n, x, h, vars, dvars_dx, lrpar, rpar, lipar, ipar, ierr) + integer, intent(in) :: n, lrpar, lipar + real(dp), intent(in) :: x, h + real(dp), intent(inout) :: vars(:) ! (n) + real(dp), intent(inout) :: dvars_dx(:) ! (n) + integer, intent(inout), pointer :: ipar(:) ! (lipar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp) :: yprime(n) + integer, intent(out) :: ierr + include 'formats' + ierr = 0 + ipar(i_nfcn) = ipar(i_nfcn) + 1 + call medakzo_feval(n, x, vars, yprime, dvars_dx, ierr, rpar, ipar) + end subroutine medakzo_derivs + + subroutine medakzo_jac_blk_dble(n, caller_id, nvar, nz, x, h, y, f, lblk1, dblk1, ublk1, lrpar, rpar, lipar, ipar, ierr) + use const_def, only: dp + integer, intent(in) :: n, caller_id, nvar, nz, lrpar, lipar + real(dp), intent(in) :: x, h + real(dp), intent(inout), pointer :: y(:) ! (n) + real(dp), intent(inout), pointer :: f(:) ! (n) ! dy/dx + real(dp), dimension(:), pointer, intent(inout) :: lblk1, dblk1, ublk1 ! =(nvar,nvar,nz) + integer, intent(inout), pointer :: ipar(:) ! (lipar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + integer, intent(out) :: ierr + + real(dp), dimension(:, :, :), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) + integer, parameter :: ld_dfdy = 5 ! for medakzo + real(dp), target :: dfdy1(ld_dfdy*n) + real(dp), pointer :: dfdy(:, :) + !real(dp), pointer :: banded(:,:,:) + integer :: i, k + ierr = 0 + dfdy(1:ld_dfdy, 1:n) => dfdy1(1:ld_dfdy*n) + + ierr = 0 + ipar(i_njac) = ipar(i_njac) + 1 + call medakzo_jeval_for_blk_dble(ld_dfdy, n, x, y, f, dfdy, ierr, rpar, ipar) + if (ierr == 0) call medakzo_fcn_blk_dble(n, caller_id, nvar, nz, x, h, y, f, lrpar, rpar, lipar, ipar, ierr) + + !banded(1:ld_dfdy,1:nvar,1:nz) => dfdy1(1:ld_dfdy*n) + lblk(1:nvar, 1:nvar, 1:nz) => lblk1(1:nvar*nvar*nz) + dblk(1:nvar, 1:nvar, 1:nz) => dblk1(1:nvar*nvar*nz) + ublk(1:nvar, 1:nvar, 1:nz) => ublk1(1:nvar*nvar*nz) + + ! convert from banded to block tridiagonal + ! lblk(:,:,1) is not used; ublk(:,:,nz) is not used. + k = 1 + dblk(1, 1, k) = dfdy(3, 1) ! partial of f(1,k) wrt var(1,k) dfdy(3,i) + dblk(1, 2, k) = dfdy(2, 2) ! partial of f(1,k) wrt var(2,k) dfdy(2,i+1) + dblk(2, 1, k) = dfdy(4, 1) ! partial of f(2,k) wrt var(1,k) dfdy(4,i) + dblk(2, 2, k) = dfdy(3, 2) ! partial of f(2,k) wrt var(2,k) dfdy(3,i+1) + ublk(1, 1, k) = dfdy(1, 3) ! partial of f(1,k) wrt var(1,k+1) dfdy(1,i+2) + +!dfdy(1,i+2) partial of f(1,k) wrt var(1,k+1) +!dfdy(2,i+1) partial of f(1,k) wrt var(2,k) +!dfdy(3,i) partial of f(1,k) wrt var(1,k) +!dfdy(3,i+1) partial of f(2,k) wrt var(2,k) +!dfdy(4,i) partial of f(2,k) wrt var(1,k) +!dfdy(5,i-2) partial of f(1,k) wrt var(1,k-1) + + do k = 2, nz - 1 + i = 2*k - 1 + ! set lblk + lblk(1, 1, k) = dfdy(5, i - 2) ! partial of f(1,k) wrt var(1,k-1) + lblk(1, 2, k) = 0 ! partial of f(1,k) wrt var(2,k-1) + lblk(2, 1, k) = 0 ! partial of f(2,k) wrt var(1,k-1) + lblk(2, 2, k) = 0 ! partial of f(2,k) wrt var(2,k-1) + ! set dblk + dblk(1, 1, k) = dfdy(3, i) ! partial of f(1,k) wrt var(1,k) dfdy(3,i) + dblk(1, 2, k) = dfdy(2, i + 1) ! partial of f(1,k) wrt var(2,k) dfdy(2,i+1) + dblk(2, 1, k) = dfdy(4, i) ! partial of f(2,k) wrt var(1,k) dfdy(4,i) + dblk(2, 2, k) = dfdy(3, i + 1) ! partial of f(2,k) wrt var(2,k) dfdy(3,i+1) + ! set ublk + ublk(1, 1, k) = dfdy(1, i + 2) ! partial of f(1,k) wrt var(1,k+1) dfdy(1,i+2) + ublk(2, 1, k) = 0 ! partial of f(2,k) wrt var(1,k+1) + ublk(1, 2, k) = 0 ! partial of f(1,k) wrt var(2,k+1) + ublk(2, 2, k) = 0 ! partial of f(2,k) wrt var(2,k+1) + end do + + k = nz + i = 2*k - 1 + dblk(1, 1, k) = dfdy(3, i) ! partial of f(1,k) wrt var(1,k) + dblk(1, 2, k) = dfdy(2, i + 1) ! partial of f(1,k) wrt var(2,k) + dblk(2, 1, k) = dfdy(4, i) ! partial of f(2,k) wrt var(1,k) + dblk(2, 2, k) = dfdy(3, i + 1) ! partial of f(2,k) wrt var(2,k) + + end subroutine medakzo_jac_blk_dble + + subroutine medakzo_jacob(n, x, h, y, f, dfdy, ld_dfdy, lrpar, rpar, lipar, ipar, ierr) + integer, intent(in) :: n, ld_dfdy, lrpar, lipar + real(dp), intent(in) :: x, h + real(dp), intent(inout) :: y(:) + real(dp), intent(inout) :: f(:), dfdy(:, :) + integer, intent(inout), pointer :: ipar(:) ! (lipar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + real(dp) :: yprime(n) + integer, intent(out) :: ierr + include 'formats' + ierr = 0 + ipar(i_njac) = ipar(i_njac) + 1 + call medakzo_jeval(ld_dfdy, n, x, y, yprime, dfdy, ierr, rpar, ipar) + if (ierr == 0) call medakzo_derivs(n, x, h, y, f, lrpar, rpar, lipar, ipar, ierr) + !write(*,*) + !write(*,2)'medakzo_jacob', ipar(i_njac), x, y(1), dfdy(3,1:2) + end subroutine medakzo_jacob + + subroutine medakzo_sjac(n, x, h, y, f, nzmax, ia, ja, values, lrpar, rpar, lipar, ipar, ierr) + ! sparse jacobian. format either compressed row or compressed column. + use mtx_lib, only: band_to_row_sparse_with_diag, band_to_col_sparse_with_diag, mtx_rcond_banded + use test_int_support, only: ipar_sparse_format + integer, intent(in) :: n, nzmax, lrpar, lipar + real(dp), intent(in) :: x, h + real(dp), intent(inout) :: y(:) ! (n) + real(dp), intent(inout) :: f(:) ! (n) ! dy/dx + integer, intent(inout) :: ia(:) ! (n+1) + integer, intent(inout) :: ja(:) ! (nzmax) + real(dp), intent(inout) :: values(:) ! (nzmax) + integer, intent(inout), pointer :: ipar(:) ! (lipar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + integer, intent(out) :: ierr ! nonzero means terminate integration + + real(dp) :: dfdy(n, n) + integer :: ld_dfdy, nz + ld_dfdy = n + ierr = 0 + call medakzo_jacob(n, x, h, y, f, dfdy, ld_dfdy, lrpar, rpar, lipar, ipar, ierr) + if (ierr /= 0) return + if (ipar(ipar_sparse_format) == 0) then + call band_to_row_sparse_with_diag(n, mljac, mujac, dfdy, ld_dfdy, nzmax, nz, ia, ja, values, ierr) + else + call band_to_col_sparse_with_diag(n, mljac, mujac, dfdy, ld_dfdy, nzmax, nz, ia, ja, values, ierr) + end if + end subroutine medakzo_sjac + + subroutine do_test_medakzo(which_solver, which_decsol, numerical_jacobian, show_all, quiet) + use test_support, only: show_results, show_statistics, check_results + use test_int_support, only: do_test_stiff_int + integer, intent(in) :: which_solver, which_decsol + logical, intent(in) :: numerical_jacobian, show_all, quiet + + integer, parameter :: nvar = 2, nz = 200 + integer, parameter :: n = nvar*nz ! the number of variables in the "medakzo" system of ODEs + real(dp), target :: y_ary(n), yprime(n), yexact(n) + real(dp), pointer :: y(:) + integer, parameter :: lrpar = 1, lipar = 3, iout = 1 + logical :: consis + integer, parameter :: ndisc = 1, n_soln = 11 + real(dp) :: result(n_soln), soln(n_soln), h0, t(0:ndisc + 1), atol(1), rtol(1) + integer :: j, k, matrix_type_spec, ierr, imas, mlmas, mumas, m1, m2, itol, nstep + real(dp), target :: rpar_ary(lrpar) + integer, target :: ipar_ary(lipar) + real(dp), pointer :: rpar(:) + integer, pointer :: ipar(:) + integer :: caller_id, nvar_blk_dble, nz_blk_dble + real(dp), dimension(:), pointer :: lblk, dblk, ublk ! =(nvar,nvar,nz) + real(dp), dimension(:), pointer :: uf_lblk, uf_dblk, uf_ublk ! =(nvar,nvar,nz) + logical, parameter :: dbg = .false. + + include 'formats' + + rpar => rpar_ary + ipar => ipar_ary + y => y_ary + + if (.not. quiet) write (*, *) 'medakzo' + + nullify (lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk) + caller_id = 0 + nvar_blk_dble = 0 + nz_blk_dble = 0 + + t(0) = 0d0 + if (dbg) then + t(1) = 0.05d0 + t(2) = 0.20d0 + else + t(1) = 5d0 + t(2) = 20d0 + end if + + itol = 0 ! scalar tolerances + rtol = 1d-6 + atol = 1d-6 + h0 = 1d-9 ! initial step size + + matrix_type_spec = banded_matrix_type + mljac = 2 + mujac = 2 + + imas = 0 + mlmas = 0 + mumas = 0 + + m1 = 0 + m2 = 0 + + call medakzo_init(n, y, yprime, consis) + nstep = 0 + + if (nvar_blk_dble == 0) then + call do_test_stiff_int(which_solver, which_decsol, numerical_jacobian, & + medakzo_derivs, medakzo_jacob, medakzo_sjac, medakzo_solout, iout, & + null_fcn_blk_dble, null_jac_blk_dble, & + caller_id, nvar_blk_dble, nz_blk_dble, lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & + n, ndisc, mljac, mujac, matrix_type_spec, null_mas, imas, mlmas, mumas, m1, m2, & + t, rtol, atol, itol, h0, y, nstep, lrpar, rpar, lipar, ipar, quiet, ierr) + else + call do_test_stiff_int(which_solver, which_decsol, numerical_jacobian, & + null_fcn, null_jac, null_sjac, medakzo_solout, iout, & + medakzo_fcn_blk_dble, medakzo_jac_blk_dble, & + caller_id, nvar_blk_dble, nz_blk_dble, lblk, dblk, ublk, uf_lblk, uf_dblk, uf_ublk, & + n, ndisc, mljac, mujac, matrix_type_spec, null_mas, imas, mlmas, mumas, m1, m2, & + t, rtol, atol, itol, h0, y, nstep, lrpar, rpar, lipar, ipar, quiet, ierr) + end if + if (ierr /= 0) then + write (*, *) 'test_medakzo ierr', ierr + call mesa_error(__FILE__, __LINE__) + end if + + call medakzo_solut(n, 0d0, yexact) + j = 1 + do k = 1, n/2, max(1, (n/2 - 1)/11) + if (j > n_soln) exit + result(j) = y(1 + 2*(k - 1)) + soln(j) = yexact(1 + 2*(k - 1)) + j = j + 1 + end do + + if (.not. dbg) then + call check_results(n, y, yexact, rtol(1)*50, ierr) + if (ierr /= 0) then + write (*, *) 'check results ierr', ierr + !call mesa_error(__FILE__,__LINE__) ! do_test_medakzo + end if + end if + + if (quiet) return + + call show_results(n_soln, result, soln, show_all) + call show_statistics(ipar(i_nfcn), ipar(i_njac), nstep, show_all) + + end subroutine do_test_medakzo + + subroutine medakzo_solout(nr, xold, x, n, y, rwork, iwork, interp_y, lrpar, rpar, lipar, ipar, irtrn) + ! nr is the step number. + ! x is the current x value; xold is the previous x value. + ! y is the current y value. + ! irtrn negative means terminate integration. + ! rwork and iwork hold info for + integer, intent(in) :: nr, n, lrpar, lipar + real(dp), intent(in) :: xold, x + real(dp), intent(inout) :: y(:) ! (n) + real(dp), intent(inout), target :: rwork(*) + integer, intent(inout), target :: iwork(*) + integer, intent(inout), pointer :: ipar(:) ! (lipar) + real(dp), intent(inout), pointer :: rpar(:) ! (lrpar) + interface + ! this subroutine can be called from your solout routine. + ! it computes interpolated values for y components during the just completed step. + real(dp) function interp_y(i, s, rwork, iwork, ierr) + use const_def, only: dp + integer, intent(in) :: i ! result is interpolated approximation of y(i) at x=s. + real(dp), intent(in) :: s ! interpolation x value (between xold and x). + real(dp), intent(inout), target :: rwork(*) + integer, intent(inout), target :: iwork(*) + integer, intent(out) :: ierr + end function interp_y + end interface + integer, intent(out) :: irtrn + integer :: ierr + include 'formats' + !if (mod(nr,10) == 0) write(*,2) 'step', nr, x, y(1:2) + !if (nr >= 100) stop + ierr = 0 + irtrn = 0 + end subroutine medakzo_solout + +end module test_medakzo diff --git a/num/test/src/test_newton.f b/num/test/src/test_newton.f90 similarity index 100% rename from num/test/src/test_newton.f rename to num/test/src/test_newton.f90 diff --git a/num/test/src/test_newuoa.f b/num/test/src/test_newuoa.f deleted file mode 100644 index fc377f520..000000000 --- a/num/test/src/test_newuoa.f +++ /dev/null @@ -1,68 +0,0 @@ - module test_newuoa - - use num_def - use num_lib - - integer :: nfcn - - contains - - subroutine do_test_newuoa - -! -! The Chebyquad test problem (Fletcher, 1965) for N = 2,4,6 and 8, -! with NPT = 2N+1. -! - IMPLICIT real(dp) (A-H,O-Z) - DIMENSION X(10),W(10000) - real(dp), parameter :: max_valid_value = 1d99 - include 'formats' - IPRINT=0 - MAXFUN=5000 - RHOEND=1.0D-6 - DO 30 N=2,6,2 - nfcn = 0 - NPT=2*N+1 - DO 10 I=1,N - 10 X(I)=DBLE(I)/DBLE(N+1) - RHOBEG=0.2D0*X(1) - PRINT 20, N,NPT - 20 FORMAT (4X,'test NEWUOA with N =',I2,' and NPT =',I3) - CALL NEWUOA (N,NPT,X,RHOBEG,RHOEND,IPRINT,MAXFUN,W,CALFUN,max_valid_value) - call calfun(n,x,f) - !write(*,2) 'f', nfcn, f - if (abs(f) > 1d-10) write(*,*) 'failed in test of newuoa: min f', f - 30 CONTINUE - END subroutine do_test_newuoa - - - - subroutine calfun(n,x,f) - use const_def, only: dp - integer, intent(in) :: n - real(dp), intent(in) :: x(*) - real(dp), intent(out) :: f - - real(dp) :: Y(10,10) - nfcn = nfcn + 1 - DO 10 J=1,N - Y(1,J)=1.0D0 - 10 Y(2,J)=2.0D0*X(J)-1.0D0 - DO 20 I=2,N - DO 20 J=1,N - 20 Y(I+1,J)=2.0D0*Y(2,J)*Y(I,J)-Y(I-1,J) - F=0.0D0 - NP=N+1 - IW=1 - DO 40 I=1,NP - SUM=0.0D0 - DO 30 J=1,N - 30 SUM=SUM+Y(I,J) - SUM=SUM/DBLE(N) - IF (IW .GT. 0) SUM=SUM+1.0D0/DBLE(I*I-2*I) - IW=-IW - 40 F=F+SUM*SUM - RETURN - END SUBROUTINE CALFUN - - end module test_newuoa diff --git a/num/test/src/test_newuoa.f90 b/num/test/src/test_newuoa.f90 new file mode 100644 index 000000000..d44c3788b --- /dev/null +++ b/num/test/src/test_newuoa.f90 @@ -0,0 +1,76 @@ +module test_newuoa + + use num_def + use num_lib + use const_def, only: dp + + implicit none + + integer :: nfcn + +contains + + subroutine do_test_newuoa + +! The Chebyquad test problem (Fletcher, 1965) for N = 2,4,6 and 8, +! with NPT = 2N+1. +! + real(dp), dimension(10) :: X + real(dp), dimension(10000) :: W + real(dp), parameter :: max_valid_value = 1d99 + real(dp) :: f, RHOBEG, RHOend + integer :: IPRINT, I, N, NPT, MAXFUN + include 'formats' + IPRINT = 0 + MAXFUN = 5000 + RHOend = 1.0D-6 + do N = 2, 6, 2 + nfcn = 0 + NPT = 2*N + 1 + do I = 1, N + X(I) = DBLE(I)/DBLE(N + 1) + end do + RHOBEG = 0.2D0*X(1) + write (*, '(4X,A,I2,A,I3)') 'test NEWUOA with N =', N, ' and NPT =', NPT + call NEWUOA(N, NPT, X, RHOBEG, RHOend, IPRINT, MAXFUN, W, CALFUN, max_valid_value) + call calfun(n, x, f) + !write(*,2) 'f', nfcn, f + if (abs(f) > 1d-10) write (*, *) 'failed in test of newuoa: min f', f + end do + end subroutine do_test_newuoa + + subroutine calfun(n, x, f) + use const_def, only: dp + integer, intent(in) :: n + real(dp), intent(in) :: x(*) + real(dp), intent(out) :: f + + integer :: I, J, IW, MAXFUN, NP + real(dp) :: Y(10, 10), sum + nfcn = nfcn + 1 + do J = 1, N + Y(1, J) = 1.0D0 + Y(2, J) = 2.0D0*X(J) - 1.0D0 + end do + do I = 2, N + do J = 1, N + Y(I + 1, J) = 2.0D0*Y(2, J)*Y(I, J) - Y(I - 1, J) + end do + end do + F = 0.0D0 + NP = N + 1 + IW = 1 + do I = 1, NP + SUM = 0.0D0 + do J = 1, N + SUM = SUM + Y(I, J) + end do + SUM = SUM/DBLE(N) + IF (IW > 0) SUM = SUM + 1.0D0/DBLE(I*I - 2*I) + IW = -IW + F = F + SUM*SUM + end do + return + end subroutine CALFUN + +end module test_newuoa diff --git a/num/test/src/test_num.f b/num/test/src/test_num.f90 similarity index 100% rename from num/test/src/test_num.f rename to num/test/src/test_num.f90 diff --git a/num/test/src/test_pollu.f b/num/test/src/test_pollu.f90 similarity index 100% rename from num/test/src/test_pollu.f rename to num/test/src/test_pollu.f90 diff --git a/num/test/src/test_simplex.f b/num/test/src/test_simplex.f90 similarity index 100% rename from num/test/src/test_simplex.f rename to num/test/src/test_simplex.f90 diff --git a/num/test/src/test_support.f b/num/test/src/test_support.f90 similarity index 100% rename from num/test/src/test_support.f rename to num/test/src/test_support.f90 diff --git a/num/test/src/test_vdpol.f b/num/test/src/test_vdpol.f90 similarity index 100% rename from num/test/src/test_vdpol.f rename to num/test/src/test_vdpol.f90 diff --git a/star/private/evolve.f90 b/star/private/evolve.f90 index f305d2d23..f2890c3f2 100644 --- a/star/private/evolve.f90 +++ b/star/private/evolve.f90 @@ -536,7 +536,8 @@ integer function do_step_part2(id, first_try) surf_omega_div_omega_crit_limit, dt integer :: ph_k, mdot_action - real(dp) :: implicit_mdot, ph_x, ph_L, iwind_tolerance, iwind_lambda + real(dp) :: implicit_mdot, ph_L, iwind_tolerance, iwind_lambda + real(dp) :: dummy1, dummy2, dummy3, dummy4, dummy5, dummy6, dummy7, dummy8 integer :: iwind_redo_cnt, iwind_max_redo_cnt integer, parameter :: exit_loop = 1, cycle_loop = 0 @@ -798,7 +799,7 @@ integer function select_mdot_action(ierr) if (iwind_redo_cnt < iwind_max_redo_cnt .and. iwind_lambda > 0d0) then ! check mdot calculated at end of step - call get_phot_info(s, ph_x, ph_x, ph_x, ph_L, ph_x, ph_x, ph_x, ph_x, ph_x, ph_k) + call get_phot_info(s, dummy1, dummy2, dummy3, ph_L, dummy4, dummy5, dummy6, dummy7, dummy8, ph_k) call set_mdot(s, ph_L, s% mstar, s% Teff, ierr) if (ierr /= 0) then do_step_part2 = retry diff --git a/utils/makefile_header b/utils/makefile_header index 6b964fefe..368d5ab90 100644 --- a/utils/makefile_header +++ b/utils/makefile_header @@ -247,7 +247,7 @@ LOCAL_LIB_DIR = $(PACKAGE_DIR)/make MESA_LIB_DIR = $(MESA_DIR)/lib MESA_INCLUDE_DIR = $(MESA_DIR)/include TEST_INCLUDES = -I$(LOCAL_LIB_DIR) -I$(PACKAGE_DIR)/public -I$(MESA_INCLUDE_DIR) -TEST_COMPILE_FLAGS = $(FCbasic) $(FCopenmp) $(TEST_INCLUDES) $(FCchecks) $(FCdebug) $(LIB_FLAGS) -c +TEST_COMPILE_FLAGS = $(FCbasic) $(FCopenmp) $(TEST_INCLUDES) $(FCchecks) $(FCdebug) $(LIB_FLAGS) $(FCstandard) $(FCimpno) -c TEST_COMPILE = $(FC) $(TEST_COMPILE_FLAGS) $(LD_FLAGS) # Library lists / linking commands