program main !*****************************************************************************80 ! !! MAIN is the main program for ARBY4. ! ! Discussion: ! ! ARBY4 solves a fluid flow problem which has several parameters. ! ! ARBY4 can solve the problem using the finite element method. The ! resulting solution will be called a "full" solution. ! ! Once a full solution has been calculated, ARBY4 can compute the ! first several derivatives of the solution with respect to the ! Reynolds number, derive a reduced basis, and find reduced ! solutions to the problem at a variety of Reynolds numbers. ! ! Diary: ! ! 12 December 2000 ! ! Double precision constants REQUIRE D+00 or something similar, otherwise ! they are computed as though they were REAL. So I tried to fix that, ! quickly. ! ! 14 September 1996 ! ! Mr Lee wants a code that will solve the driven cavity problem. ! I thought I would get FLOW4, but somehow ARBY4 may be the ! quicker solution. ! ! 12 September 1996 ! ! Worked on GFL2RB and GRB2FL. ! ! 11 September 1996 ! ! Max urged me to write a reduced basis paper, as Kazi Ito has already ! done so. ! ! I updated GFL2RB. ! ! 17 August 1996 ! ! OK, making transition BACK to representation of full solution as ! GFL(GRB) = GFLRB + Q * GRB. ! ! 16 August 1996 ! ! GFLRB is already stored. So now I have to reformulate the representation. ! ! 15 August 1996 ! ! I decided that I had to treat boundary conditions as follows: ! ! The reduced solution is represented as Y = Y0 + YBC*cbc + YFE*cfe ! ! Here, Y0 is the point at which the basis was generated. ! Each column of YBC corresponds to the flow solution of the problem ! at Y0 with boundary conditions differentiated with respect to ! parameter I. The YFE stuff is as usual. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 December 2008 ! ! Author: ! ! John Burkardt ! implicit none ! ! Set parameters that are independent. ! integer, parameter :: liv = 60 integer, parameter :: maxbcrb = 3 integer, parameter :: maxferb = 6 integer, parameter :: maxnx = 21 integer, parameter :: maxny = 21 integer, parameter :: maxparb = 5 integer, parameter :: maxparf = 5 ! ! Set parameters that are dependent on parameters. ! ! The assignment of LDAFL should really read (ldafl = 29*min(nx,ny)). ! integer, parameter :: ldafl = 29 * maxny integer, parameter :: maxcofrb = maxbcrb + maxferb integer, parameter :: maxelm = 2 * ( maxnx - 1 ) * ( maxny - 1 ) integer, parameter :: maxnfl = & 2 * ( 2 * maxnx - 1 ) * ( 2 * maxny - 1 ) + maxnx * maxny integer, parameter :: maxnp = ( 2 * maxnx - 1 ) * ( 2 * maxny - 1 ) integer, parameter :: maxpar = maxparb + maxparf + 1 ! ! Set parameters that are dependent on parameters that are dependent ! on parameters. ! integer, parameter :: lv = 78+maxpar*(maxpar+21)/2 double precision afl(ldafl,maxnfl) double precision arb(maxcofrb,maxcofrb) double precision area(3,maxelm) character ( len = 9 ) chtime character ( len = 80 ) command double precision cost double precision cost0 double precision costb double precision costp double precision costu double precision costv character ( len = 8 ) date double precision detlog double precision detman double precision difcof(maxcofrb) character ( len = 30 ) disfil double precision dopt(maxpar) double precision dpar double precision drey logical dvneq logical echo double precision epsdif character ( len = 2 ) eqn(maxnfl) real estart real estop double precision etaq(3) double precision factj double precision gfl(maxnfl) double precision gflafl(maxnfl) double precision gflnrm double precision gflopt(maxnfl) double precision gflrb(maxnfl) double precision gflsav(maxnfl) double precision gflsen(maxnfl) double precision gfltar(maxnfl) double precision gfltay(maxnfl) double precision gfltmp(maxnfl) double precision grb(maxcofrb) double precision grbarb(maxcofrb) double precision grbopt(maxcofrb) double precision grbsav(maxcofrb) double precision grbsen(maxcofrb) double precision grbtay(maxcofrb) character ( len = 20 ) gridx character ( len = 20 ) gridy double precision gsen(maxcofrb) double precision hx double precision hy integer i integer ibs integer ibump integer icolrb(maxcofrb) integer ierror integer ifs integer ihi integer ijac integer ilo integer indx(3,maxnp) integer info integer iopt(maxpar) integer ios integer ipar integer ipivfl(maxnfl) integer ipivrb(maxcofrb) integer iprint integer isotri(maxelm) integer itemp integer ival integer ival1 integer ival2 integer ivopt(liv) integer iwrite integer j integer jhi integer jlo integer jtay integer klo integer lchar integer lenc logical s_eqi integer maxnew integer maxopt integer maxsim integer mhi integer mlo integer nbcrb integer ncofrb integer nelem integer neqnfl integer nferb integer nhi integer nlband integer nlo integer node(6,maxelm) integer nodelm(maxnp) integer np integer npar integer nparb integer nparf integer npe integer nprof(2*maxny-1) integer nsenfl integer ntay integer numdif integer numnew integer numopt integer numsim integer nx integer ny double precision p(maxnp) double precision par(maxpar) double precision parafl(maxpar) double precision pararb(maxpar) double precision pardif ( maxpar) double precision paropt(maxpar) double precision parrb(maxpar) double precision parsav(maxpar) double precision parsen(maxpar) double precision partar(maxpar) double precision phifl(3,6,10,maxelm) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) character ( len = 20 ) region double precision resfl(maxnfl) double precision resflsav(maxnfl) double precision resfltmp(maxnfl) double precision resrb(maxcofrb) double precision reynld double precision reytay double precision rbase(maxcofrb,maxcofrb) double precision rmax double precision senfl(maxnfl,maxcofrb) double precision senrb(maxcofrb,maxcofrb) double precision splbmp(maxparb+2) double precision splflo(maxparf) real tarray(2) double precision taubmp(maxparb+2) double precision tauflo(maxparf) character ( len = 30 ) tecfil double precision temp character ( len = 10 ) time double precision tolnew double precision tolopt double precision tolsim character ( len = 10 ) tstart character ( len = 10 ) tstop double precision u(maxnp) double precision v(maxnp) double precision value double precision vopt(lv) double precision wateb double precision watep double precision wateu double precision watev double precision wquad(3) double precision xbl double precision xbr double precision xc(maxnp) double precision xmax double precision xmin double precision xopt(maxpar) double precision xprof double precision xquad(3,maxelm) double precision xrange double precision xsiq(3) double precision ybl double precision ybr double precision yc(maxnp) double precision ymax double precision ymin double precision yquad(3,maxelm) double precision yrange call timestamp ( ) iprint = 1 ! ! Get initial CPU clock reading. ! call etime ( tarray, estart ) echo = .false. call hello ( maxnx, maxny ) ! ! Get the starting time. ! call date_and_time ( date, time ) tstart = time ! ! Open the file in which we record the user input. ! open ( unit = 17, file = 'arby.in', status = 'replace' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARBY4 - Init: Initialize all data.' call init(afl,arb,area,command,cost,costb,costp,costu, & costv,difcof,disfil,drey,epsdif,eqn,etaq,gfl,gflafl, & gflrb,gflsav,gflsen,gfltar,gfltay,grb,grbarb,grbsav, & grbsen,grbtay,gridx,gridy,hx,hy,ibs,ibump,icolrb,ierror, & ifs,ihi,ijac,ilo,indx,iopt,ipar, & ipivfl,ipivrb,isotri,iwrite,jhi,jlo, & ldafl,maxcofrb,maxelm,maxnew,maxnfl,maxnp, & maxny,maxopt,maxpar,maxparb,maxparf,maxsim, & nbcrb,ncofrb,nelem,neqnfl,nferb, & nlband,node,nodelm,np,npar,nparb,nparf,npe,nprof,nsenfl,ntay, & numnew,numopt,numsim,nx, & ny,par,parafl,pararb,pardif,parrb,parsav,parsen,partar, & phifl,phirb,rbase,rb,region,resfl,resflsav,resrb,reynld, & reytay,senfl, & senrb,splbmp,splflo,taubmp,tauflo,tecfil,tolnew,tolopt, & tolsim,value,wateb,watep,wateu,watev,wquad,xbl,xbr, & xc,xmax,xmin,xprof,xquad,xrange,xsiq, & ybl,ybr,yc,ymax,ymin,yquad,yrange) ! ! Read the next command from the user ! command = '?' do if ( command(1:1) /= '#' .and. len_trim ( command ) /= 0 ) then if ( 0 < iprint ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Enter command:' end if end if read ( *, '(a)', iostat = ios ) command if ( ios /= 0 ) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Fatal error!' write ( *, * ) ' I/O error for the input file.' stop end if if ( echo ) then write ( *, '(a)' ) trim ( command ) end if write ( 17, '(a)' ) trim ( command ) ! ! Check for output-suppressing semicolon at end. ! if ( 0 < lenc ) then if ( command(lenc:lenc) == ';' ) then iprint = 0 command(lenc:lenc) = ' ' lenc = lenc-1 else iprint = 1 end if end if 15 continue if ( command(1:1) == '#') then cycle else if ( command == ' ') then cycle end if if ( 0 < iprint ) then write ( *, '(a)' ) ' ' end if ! ! COMPARE ! if ( s_eqi ( command,'compare')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - Compare:' write ( *, '(a)' ) ' Compare full solutions GFL and GFLSAV.' end if call fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar,nparf, & par,phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) call fxfl(area,eqn,gflsav,ifs,indx,nelem,neqnfl,node,np,npar, & nparf,par,phifl,region,resflsav,splflo,tauflo,xrange,yc,yrange) gfltmp(1:neqnfl) = gfl(1:neqnfl) - gflsav(1:neqnfl) resfltmp(1:neqnfl) = resfl(1:neqnfl) - resflsav(1:neqnfl) call nrmflo ( gfltmp, indx, neqnfl, np, resfltmp ) ! ! COSTFL ! else if ( s_eqi ( command,'costfl')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - Cost FL:' write ( *, '(a)' ) ' Evaluate the cost function for GFL.' write ( *, '(a)' ) ' ' end if call getcst(cost,costb,costp,costu,costv,gfl,gfltar,indx,neqnfl,np, & nparb,nprof,ny,splbmp,taubmp,wateb,watep,wateu,watev,xbl,xbr,ybl,ybr,yc) write ( *, '(a,g14.6)' ) 'Cost of GFL:',cost ! ! COSTRB ! else if ( s_eqi ( command,'costrb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - Cost RB:' write ( *, '(a)' ) ' Evaluate the cost function for GRB.' write ( *, '(a)' ) ' ' end if call grb2fl(gfl,gflrb,grb,maxnfl,ncofrb,neqnfl,rb) call getcst(cost,costb,costp,costu,costv,gfl,gfltar,indx,neqnfl,np, & nparb,nprof,ny,splbmp,taubmp,wateb,watep,wateu,watev,xbl,xbr,ybl,ybr,yc) write ( *, '(a,g14.6)' ) 'Cost of GRB:',cost ! ! DETFPFL ! else if ( s_eqi ( command,'detfpfl')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - DET FP FL' write ( *, '(a)' ) ' Compute determinant of full jacobian.' end if call fpfl(afl,area,eqn,gfl,indx,ldafl,maxelm,nelem,neqnfl, & nlband,node,np,npar,par,phifl) call dfacfl(afl,ldafl,neqnfl,nlband,nlband,ipivfl,info) call ddetfl(afl,detlog,detman,ipivfl,ldafl,neqnfl,nlband,nlband) write ( *, '(a,g14.6,a,g14.6)' ) 'Determinant = ', detman, & ' * 10 ** ', detlog ! ! DETFPRB ! else if ( s_eqi ( command,'detfprb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - DET FP RB' write ( *, '(a)' ) ' Compute the reduced jacobian,' write ( *, '(a)' ) ' and its determinant.' end if call fprb(arb,area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb, & ncofrb,nelem,nferb,node,np,nx,ny,phirb,rb,reynld,xc,xrange,yc,yrange) call dfacrb(arb,maxcofrb,ncofrb,ipivrb,info) call ddetrb(arb,detlog,detman,ipivrb,maxcofrb,ncofrb) write ( *, '(a,g14.6,a,g14.6)' ) 'Determinant = ', detman, & ' * 10 ** ', detlog ! ! DIFFPRB ! else if ( s_eqi ( command,'diffprb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - DIF FP RB' write ( *, '(a)' ) ' Estimate reduced jacobian by finite diff.' end if pararb(1:npar) = par(1:npar) grbarb(1:ncofrb) = grb(1:ncofrb) arb(1:maxcofrb,1:maxcofrb) = 0.0D+00 call diffprb(arb,area,epsdif,grb,indx,maxcofrb,maxelm, & maxnfl,nbcrb,ncofrb,nelem,nferb,node,np,npar,nparf,nx, & ny,par,phirb,rb,resrb,reynld,tauflo,xc,xrange,yc,yrange) ! ! DIFSENFL ! else if ( s_eqi ( command,'difsenfl')) then if ( ipar <= 0 .or. npar < ipar ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARBY4 - Warning!' write ( *, '(a)' ) ' Cancelling the DIFSENFL command.' write ( *, '(a,i6)' ) ' IPAR = ',ipar write ( *, '(a)' ) ' but IPAR must be at least 0' write ( *, '(a,i6)' ) ' and no more than NPAR = ',npar cycle end if if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - DifSenFL:' write ( *, '(a)' ) ' Estimate full solution sensitivity ' write ( *, '(a)' ) ' with respect to parameter ',ipar write ( *, '(a)' ) ' via finite differences.' end if ipar = npar dpar = drey parsen(1:npar) = par(1:npar) gflsen(1:neqnfl) = gfl(1:neqnfl) call difsenfl(afl,area,difcof,dpar,eqn,gfl,gflafl,ifs,ijac,indx,ipar, & ipivfl,iwrite,ldafl,maxcofrb,maxelm,maxnew,maxnfl,ncofrb,nelem,neqnfl, & nlband,node,np,npar,nparf,par,parafl,phifl,region,resfl,senfl,splflo, & tauflo,tolnew,xrange,yc,yrange) ! ! DIFSENRB ! else if ( s_eqi ( command,'difsenrb')) then if ( ipar <= 0 .or. npar < ipar ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARBY4 - Warning!' write ( *, '(a)' ) ' Cancelling the DIFSENRB command.' write ( *, '(a,i6)' ) ' IPAR = ', ipar write ( *, '(a)' ) ' but IPAR must be at least 0' write ( *, '(a,i6)' ) ' and no more than NPAR = ', npar cycle end if if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - Dif Sen RB:' write ( *, '(a)' ) ' Estimate reduced solution sensitivity ' write ( *, '(a,i6)' ) ' with respect to parameter ', ipar write ( *, '(a)' ) ' via finite differences.' end if ipar = npar dpar = drey parsen(1:npar) = par(1:npar) grbsen(1:ncofrb) = grb(1:ncofrb) call difsenrb(arb,area,difcof,dpar,grb,grbarb,indx,ipar,ipivrb,iwrite, & maxcofrb,maxelm,maxnew,maxnfl,nbcrb,ncofrb,nelem,nferb,node,np,npar, & nparf,nx,ny,par,pararb,phirb,rb,resrb,senrb,tauflo,tolnew,xc,xrange, & yc,yrange) ! ! DisPlot ! else if ( s_eqi ( command,'displot')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - DisPlot: Write data to DISPLAY plot file.' end if call intprs(gfl,indx,nelem,neqnfl,node,np,p) u(1:np) = gfl(indx(1,1:np)) v(1:np) = gfl(indx(2,1:np)) call wrdis(disfil,eqn,indx,isotri,maxcofrb,maxnfl,ncofrb,nelem,neqnfl, & node,np,npar,npe,nprof,nx,ny,p,par,rb,u,v,xc,xprof,yc) ! ! DREY = ! else if ( s_eqi ( command(1:4),'drey')) then if ( s_eqi ( command(1:5),'drey=')) then read(command(6:),*)drey else write ( *, '(a)' ) 'Enter value for DREY:' read(*,*)drey write(17,*)drey end if if ( 0 < iprint ) then write ( *, '(a,g14.6)' ) 'DREY set to ',drey end if ! ! EPSDIF = ! else if ( s_eqi ( command(1:6),'epsdif')) then if ( s_eqi ( command(1:7),'epsdif=')) then read(command(8:),*)epsdif else write ( *, '(a)' ) 'Enter value for EPSDIF:' read ( *, * ) epsdif write ( 17, '(g14.6)' ) epsdif end if if ( 0 < iprint ) then write ( *, '(a,g14.6)' ) 'EPSDIF set to ', epsdif end if ! ! ECHO ! else if ( s_eqi ( command,'echo')) then echo = .not.echo if ( echo) then write(*,'(a)')command if ( 0 < iprint ) then write ( *, '(a)' ) 'User commands will be echoed.' end if else if ( 0 < iprint ) then write ( *, '(a)' ) 'User commands will not be echoed.' end if end if ! ! EXPAND GRB ! else if ( s_eqi ( command,'expand grb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - Expand GRB:' write ( *, '(a)' ) ' Compute GFL = RB * GRB' end if call grb2fl(gfl,gflrb,grb,maxnfl,ncofrb,neqnfl,rb) ! ! DISFIL = ! else if ( s_eqi ( command(1:6),'disfil')) then if ( s_eqi ( command(1:7),'disfil=')) then disfil = command(8:) else write ( *, '(a)' ) 'Enter the DISPLAY output file name:' read(*,'(a)')disfil write(17,'(a)')disfil end if if ( 0 < iprint ) then write ( *, '(a)' ) 'DISPLAY output file name set to ' // trim ( disfil ) end if ! ! FILTEC = ! else if ( s_eqi ( command(1:6),'tecfil')) then if ( s_eqi ( command(1:7),'tecfil=')) then tecfil = command(8:) else write ( *, '(a)' ) 'Enter the TECPLOT output file name:' read(*,'(a)')tecfil write(17,'(a)')tecfil end if if ( 0 < iprint ) then write ( *, '(a)' ) 'TECPLOT output file name set to ' // trim ( tecfil ) end if ! ! FPFL ! else if ( s_eqi ( command,'fpfl')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FPFL - Evaluate full jacobian.' end if call fpfl(afl,area,eqn,gfl,indx,ldafl,maxelm,nelem,neqnfl, & nlband,node,np,npar,par,phifl) ! ! FPIRB ! else if ( s_eqi ( command,'fpirb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FPIRB:' write ( *, '(a)' ) ' Evaluate FP indirectly at reduced solution GRB,' write ( *, '(a)' ) ' by expanding GRB to GFL, evaluating FP(GFL),' write ( *, '(a)' ) ' and then reducing.' end if call fpirb(afl,arb,area,eqn,gflrb,grb,indx,ldafl,maxcofrb, & maxelm,maxnfl,nbcrb,ncofrb,nelem,neqnfl,nferb,nlband,node, & np,npar,nx,ny,par,phifl,rb,xc,xrange,yc,yrange) ! ! FPRB ! else if ( s_eqi ( command,'fprb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FPRB - Evaluate reduced jacobian.' end if pararb(1:npar) = par(1:npar) grbarb(1:ncofrb) = grb(1:ncofrb) call fprb(arb,area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb,nelem, & nferb,node,np,nx,ny,phirb,rb,reynld,xc,xrange,yc,yrange) ! ! FPRB = 0 ! else if ( s_eqi ( command,'fprb=0')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FPRB = 0 - Zero out the reduced jacobian.' end if arb(1:maxcofrb,1:maxcofrb) = 0.0D+00 ! ! FXFL ! else if ( s_eqi ( command,'fxfl')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FX FL:' write ( *, '(a)' ) ' Evaluate FXFL at full solution GFL.' end if call fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar,nparf,par, & phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) ! ! FXIRB ! else if ( s_eqi ( command,'fxirb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FX IRB:' write ( *, '(a)' ) ' Evaluate FX indirectly at reduced solution GRB,' write ( *, '(a)' ) ' by expanding GRB to GFL, evaluating F(GFL),' write ( *, '(a)' ) ' and then reducing.' end if call fxirb(area,eqn,gflrb,grb,ifs,indx,maxcofrb,maxnfl,nbcrb,ncofrb, & nelem,neqnfl,nferb,node,np,npar,nparf,nx,ny,par,phifl,rb,region,resrb, & splflo,tauflo,xc,xrange,yc,yrange) ! ! FXRB ! else if ( s_eqi ( command,'fxrb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FX RB:' write ( *, '(a)' ) ' Evaluate FX directly at reduced solution GRB.' end if reynld = par(npar) call fxrb(area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb,nelem,nferb, & node,np,npar,nparf,nx,ny,par,phirb,rb,resrb,reynld,tauflo,xc,xrange, & yc,yrange) ! ! FXRB = 0 ! else if ( s_eqi ( command,'fxrb=0')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - FXRB = 0' end if resrb(1:ncofrb) = 0.0D+00 ! ! GETGSEN ! else if ( s_eqi ( command,'getgsen')) then call getgsen(grb,gsen,icolrb,maxcofrb,nbcrb,ncofrb,nsenfl,rbase) ! ! GETRB ! else if ( s_eqi ( command,'getrb')) then if ( 0 < iprint ) then write ( *, '(a)' ) 'ARBY4 - Get RB:' write ( *, '(a)' ) ' Compute reduced basis RB at current GFL.' end if if ( ncofrb < 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARBY4 - Warning!' write ( *, '(a)' ) ' The GETRB command is being cancelled,' write ( *, '(a,i6)' ) ' since NCOFRB is ', ncofrb write ( *, '(a)' ) ' Please use the "NCOFRB = " command first!' end if if ( dvneq ( npar, par, parsen ) ) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Error!' write ( *, * ) ' Please compute the sensitivities first,' write ( *, * ) ' using the GETSENFL command!' cycle end if ! ! Save the affine displacement vector GFLRB. ! parrb(1:npar) = par(1:npar) gflrb(1:neqnfl) = gfl(1:neqnfl) ! ! Get boundary condition reduced basis vectors. ! call getbcrb(gflrb,maxcofrb,maxnfl,nbcrb,neqnfl,rb) ! ! Get finite element reduced basis vectors. ! call getferb(icolrb,maxcofrb,maxnfl,nbcrb,ncofrb,neqnfl, & nferb,nsenfl,rb,rbase,senfl,senrb) grb(1:ncofrb) = 0.0D+00 ! ! Compute PHIRB, the reduced basis functions at quadrature points. ! if ( 0 < iprint ) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Note:' write ( *, * ) ' Automatically evaluating PHIRB, the reduced' write ( *, * ) ' basis functions at quadrature points.' end if call setprb(eqn,indx,maxcofrb,maxelm,maxnfl,nelem,neqnfl, & ncofrb,node,np,phifl,phirb,rb) ! ! GETSENFL ! else if ( s_eqi ( command,'getsenfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Get Sen FL:' write ( *, * ) ' Compute full solution sensitivities with ' write ( *, * ) ' respect to the parameter REYNLD, up to order' write ( *, * ) ' NSENFL = ',nsenfl end if if ( nsenfl < 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' The GETSENFL command is being cancelled,' write ( *, * ) ' since NSENFL is ',nsenfl write ( *, * ) ' Please use the "NSENFL = " command first!' else parsen(1:npar) = par(1:npar) gflsen(1:neqnfl) = gfl(1:neqnfl) call getsenfl(afl,area,eqn,gfl,indx,ipivfl,ldafl,maxcofrb,maxnfl, & nelem,neqnfl,nlband,node,np,npar,nsenfl,par,phifl,resfl,senfl) end if ! ! GETSENRB ! else if ( s_eqi ( command,'getsenrb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Get Sen RB' write ( *, * ) ' Compute reduced basis sensitivities.' end if call getsenrb(maxcofrb,maxnfl,ncofrb,neqnfl,nsenfl,rb,senfl,senrb) ! ! GFL = 0, GFLSAV, GFLTAY, TAYLOR ! else if ( s_eqi ( command(1:4),'gfl=')) then if ( command(5:5) == '0') then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFL = 0' write ( *, * ) ' Set full solution estimate GFL to zero.' end if gfl(1:neqnfl) = 0.0D+00 else if ( s_eqi ( command(5:10),'gflsav')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFL = GFLSAV' write ( *, * ) ' Set full solution estimate GFL to GFLSAV.' end if gfl(1:neqnfl) = gflsav(1:neqnfl) else if ( s_eqi ( command(5:10),'gfltay')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFL = GFLTAY' write ( *, * ) ' Set full solution estimate GFL to GFLTAY.' end if gfl(1:neqnfl) = gfltay(1:neqnfl) else if ( s_eqi ( command(5:10),'taylor')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFL = TAYLOR' write ( *, * ) ' Set full solution GFL to Taylor prediction,' write ( *, * ) ' based at REYTAY = ',reytay write ( *, * ) ' using NTAY = ',ntay,' terms.' end if gfl(1:neqnfl) = gfltay(1:neqnfl) do i = 1, neqnfl do j = 1, ntay call fact(j,factj) temp = ((reynld-reytay)**j)/factj gfl(i) = gfl(i)+temp*senfl(i,j) end do end do end if ! ! GFLSAV = GFL ! else if ( s_eqi ( command,'gflsav=gfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLSAV = GFL' write ( *, * ) ' Save current full solution.' end if parsav(1:npar) = par(1:npar) gflsav(1:neqnfl) = gfl(1:neqnfl) resflsav(1:neqnfl) = resfl(1:neqnfl) ! ! GFLTAY = 0, GFL, GFLSAV ! else if ( s_eqi ( command(1:7),'gfltay=')) then if ( command(8:8) == '0') then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTAY = 0' write ( *, * ) ' Set Taylor base full solution to zero.' end if gfltay(1:neqnfl) = 0.0D+00 else if ( s_eqi ( command(8:13),'gflsav')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTAY = GFLSAV' write ( *, * ) ' Set Taylor base full solution to GFLSAV.' end if gfltay(1:neqnfl) = gflsav(1:neqnfl) else if ( s_eqi ( command(8:10),'gfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTAY = GFL' write ( *, * ) ' Set Taylor base full solution to GFL.' end if gfltay(1:neqnfl) = gfl(1:neqnfl) end if ! ! GFLTMP = 0/GFL/GFL-GFLSAV/GFL-GFLTAR/GFLSAV/GFLSAV-GFLTAY ! else if ( s_eqi ( command(1:7),'gfltmp=')) then if ( command(8:8) == '0') then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTMP = 0' end if gfltmp(1:neqnfl) = 0.0D+00 else if ( s_eqi ( command(8:),'gfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTMP = GFL' end if gfltmp(1:neqnfl) = gfl(1:neqnfl) else if ( s_eqi ( command(8:),'gfl-gflsav')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTMP = GFL-GFLSAV' end if gfltmp(1:neqnfl) = gfl(1:neqnfl) - gflsav(1:neqnfl) else if ( s_eqi ( command(8:),'gfl-gfltar')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTMP = GFL-GFLTAR' end if gfltmp(1:neqnfl) = gfl(1:neqnfl) - gfltar(1:neqnfl) else if ( s_eqi ( command(8:),'gflsav')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTMP = GFLSAV' end if gfltmp(1:neqnfl) = gflsav(1:neqnfl) else if ( s_eqi ( command(8:),'gflsav-gfltay')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GFLTMP = GFLSAV-GFLTAY' end if gfltmp(1:neqnfl) = gflsav(1:neqnfl) - gfltay(1:neqnfl) else write ( *, * ) 'ARBY4 - Error' write ( *, * ) ' Did not understand your command!' cycle end if ! ! GRB(*) = * ! else if ( s_eqi ( command(1:4),'grb(')) then call chrcti(command(5:),ival,ierror,lchar) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' ChrCTI returned nonzero error flag!' cycle end if if ( ival < 1 .or. ncofrb < ival ) then write ( *, * ) ' ' write ( *, * ) 'INPUT - Warning!' write ( *, * ) ' Index IVAL of GRB is out of bounds!' write ( *, * ) ' IVAL = ',ival cycle end if call chrctd(command(5+lchar+2:),value,ierror,lchar) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' ChrCTD returned nonzero error flag!' cycle end if grb(ival) = value if ( 0 < iprint ) then write ( *, * ) 'GRB(',ival,') set to ',grb(ival) end if ! ! GRB = 0, GRBSAV, GRBTAY, TAYLOR ! else if ( s_eqi ( command(1:4),'grb=')) then if ( s_eqi ( command(1:5),'grb=0')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRB = 0' write ( *, * ) ' Set reduced solution to 0.' end if grb(1:ncofrb) = 0.0D+00 else if ( s_eqi ( command,'grb=grbsav')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRB = GRBSAV' write ( *, * ) ' Set reduced solution to saved value.' end if grb(1:ncofrb) = grbsav(1:ncofrb) else if ( s_eqi ( command,'grb=grbtay')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRB = GRBTAY' write ( *, * ) ' Set reduced solution to Taylor base.' end if grb(1:ncofrb) = grbtay(1:ncofrb) else if ( s_eqi ( command,'grb=taylor')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRB = TAYLOR' write ( *, * ) ' Set reduced solution to Taylor prediction,' write ( *, * ) ' based at REYTAY, GRBTAY plus sensitivities.' end if do i = 1, ncofrb grb(i) = 0.0D+00 do j = 1, ntay jtay = j-1 call fact(jtay,factj) temp = ((reynld-reytay)**jtay)/factj grb(i) = grb(i)+temp*senrb(i,j) end do end do else if ( s_eqi ( command(1:5),'grb=(')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRB = (v0,v1,...,vNeqnRB)' end if klo = 6 do i = 1, ncofrb call chrctd(command(klo:),temp,ierror,lchar) if ( ierror /= 0) then write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' There was an error reading your data.' grb(i) = 0.0D+00 else grb(i) = temp end if klo = klo+lchar end do end if ! ! GRBSAV = 0, GRB ! else if ( s_eqi ( command(1:7),'grbsav=')) then if ( command(8:8) == '0') then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRBSAV = 0' end if grbsav(1:ncofrb) = 0.0D+00 else if ( s_eqi ( command,'grbsav=grb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRBSAV = GRB' end if grbsav(1:ncofrb) = grb(1:ncofrb) end if ! ! GRBTAY = 0, GRB, GRBSAV ! else if ( s_eqi ( command(1:7),'grbtay=')) then if ( command(8:8) == '0') then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRBTAY = 0' write ( *, * ) ' Set Taylor base reduced solution to zero.' end if grbtay(1:ncofrb) = 0.0D+00 else if ( s_eqi ( command(8:13),'grbsav')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRBTAY = GRBSAV' write ( *, * ) ' Set Taylor base reduced solution to GRBSAV.' end if grbtay(1:ncofrb) = grbsav(1:ncofrb) else if ( s_eqi ( command(8:10),'grb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - GRBTAY = GRB' write ( *, * ) ' Set Taylor base reduced solution to GRB.' end if grbtay(1:ncofrb) = grb(1:ncofrb) end if ! ! GRIDX = ! else if ( s_eqi ( command(1:5),'gridx')) then if ( s_eqi ( command(1:6),'gridx=')) then gridx = command(7:) else write ( *, * ) 'Enter GRIDX option: UNIFORM, COS, SINSQ:' read(*,'(a)')gridx write(17,'(a)')gridx end if if ( 0 < iprint ) then write ( *, * ) 'The GRIDX option set to '//gridx write ( *, * ) 'Remember to use the SETGEO command' write ( *, * ) 'before trying to solve your system!' end if ! ! GRIDY = ! else if ( s_eqi ( command(1:5),'gridy')) then if ( s_eqi ( command(1:6),'gridy=')) then gridy = command(7:) else write ( *, * ) 'Enter GRIDY option: UNIFORM, COS, SINSQ:' read(*,'(a)')gridy write(17,'(a)')gridy end if if ( 0 < iprint ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'The GRIDY option set to ' // trim ( gridy ) write ( *, '(a)' ) 'Remember to use the SETGEO command' write ( *, '(a)' ) 'before trying to solve your system!' end if ! ! HELLO ! else if ( s_eqi ( command,'hello')) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARBY4 - Hello' write ( *, '(a)' ) ' ' call hello ( maxnx, maxny ) ! ! HELP ! else if ( s_eqi ( command,'help')) then call help ! ! IBS = ! else if ( s_eqi ( command(1:3),'ibs')) then if ( s_eqi ( command(1:4),'ibs=')) then read(command(5:),*)ibs else write ( *, * ) 'Enter value for IBS:' read(*,*)ibs write(17,*)ibs end if if ( 0 < iprint ) then write ( *, * ) 'IBS set to ',ibs end if ! ! IBUMP = ! else if ( s_eqi ( command(1:5),'ibump')) then if ( s_eqi ( command(1:6),'ibump=')) then read(command(7:),*)ibump else write ( *, * ) 'Enter value for IBUMP:' read(*,*)ibump write(17,*)ibump end if if ( 0 < iprint ) then write ( *, * ) 'IBUMP set to ',ibump end if ! ! IFS = ! else if ( s_eqi ( command(1:3),'ifs')) then if ( s_eqi ( command(1:4),'ifs=')) then read(command(5:),*)ifs else write ( *, * ) 'Enter value for IFS:' read(*,*)ifs write(17,*)ifs end if if ( 0 < iprint ) then write ( *, * ) 'IFS set to ',ifs end if ! ! IHI = ! else if ( s_eqi ( command(1:3),'ihi')) then if ( s_eqi ( command(1:4),'ihi=')) then if ( s_eqi ( command,'ihi=ncofrb')) then ihi = ncofrb else if ( s_eqi ( command,'ihi=neqnfl')) then ihi = neqnfl else if ( s_eqi ( command,'ihi=np')) then ihi = np else read(command(5:),*)ihi end if else write ( *, * ) 'Enter value for IHI:' read(*,*)ihi write(17,*)ihi end if if ( 0 < iprint ) then write ( *, * ) 'IHI set to ',ihi end if ! ! IJAC = ! else if ( s_eqi ( command(1:4),'ijac')) then if ( s_eqi ( command(1:5),'ijac=')) then read(command(6:),*)ijac else write ( *, * ) 'Enter value for IJAC:' read(*,*)ijac write(17,*)ijac end if if ( 0 < iprint ) then write ( *, * ) 'IJAC set to ',ijac end if ! ! ILO = ! else if ( s_eqi ( command(1:3),'ilo')) then if ( s_eqi ( command(1:4),'ilo=')) then read(command(5:),*)ilo else write ( *, * ) 'Enter value for ILO:' read(*,*)ilo write(17,*)ilo end if if ( 0 < iprint ) then write ( *, * ) 'ILO set to ',ilo end if ! ! INIT ! else if ( s_eqi ( command,'init')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Init' write ( *, * ) ' Initialize all data to zero.' write ( *, * ) ' ' end if call init(afl,arb,area,command,cost,costb,costp,costu,costv,difcof, & disfil,drey,epsdif,eqn,etaq,gfl,gflafl,gflrb,gflsav,gflsen,gfltar, & gfltay,grb,grbarb,grbsav,grbsen,grbtay,gridx,gridy,hx,hy,ibs,ibump, & icolrb,ierror,ifs,ihi,ijac,ilo,indx,iopt,ipar,ipivfl,ipivrb,isotri, & iwrite,jhi,jlo,ldafl,maxcofrb,maxelm,maxnew,maxnfl,maxnp,maxny, & maxopt,maxpar,maxparb,maxparf,maxsim,nbcrb,ncofrb,nelem,neqnfl, & nferb,nlband,node,nodelm,np,npar,nparb,nparf,npe,nprof,nsenfl,ntay, & numnew,numopt,numsim,nx,ny,par,parafl,pararb,pardif,parrb,parsav, & parsen,partar,phifl,phirb,rbase,rb,region,resfl,resflsav,resrb, & reynld,reytay,senfl,senrb,splbmp,splflo,taubmp,tauflo,tecfil,tolnew, & tolopt,tolsim,value,wateb,watep,wateu,watev,wquad,xbl,xbr,xc, & xmax,xmin,xprof,xquad,xrange,xsiq,ybl,ybr,yc,ymax,ymin,yquad,yrange) ! ! IOPT(*) = ! else if ( s_eqi ( command(1:5),'iopt(')) then call chrcti(command(6:),ival1,ierror,lchar) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'INPUT - Fatal error!' write ( *, * ) ' ChrCTI returned nonzero error flag!' stop end if if ( ival1 < 1 .or. maxpar < ival1 ) then write ( *, * ) ' ' write ( *, * ) 'INPUT - Fatal error!' write ( *, * ) ' Index IVAL1 of IOPT is out of bounds!' write ( *, * ) ' IVAL1 = ', ival1 stop end if call chrcti(command(6+lchar+2:),ival2,ierror,lchar) iopt(ival1) = ival2 if ( 0 < iprint ) then write ( *, * ) 'IOPT(',ival1,' ) set to ',ival2 end if ! ! IWRITE = ! else if ( s_eqi ( command(1:6),'iwrite')) then if ( s_eqi ( command(1:7),'iwrite=')) then read(command(8:),*)iwrite else write ( *, * ) 'Enter value for IWRITE:' read(*,*)iwrite write(17,*)iwrite end if if ( 0 < iprint ) then write ( *, * ) 'IWRITE set to ',iwrite end if ! ! JHI = ! else if ( s_eqi ( command(1:3),'jhi')) then if ( s_eqi ( command(1:4),'jhi=')) then if ( s_eqi ( command,'jhi=ncofrb')) then jhi = ncofrb else if ( s_eqi ( command,'jhi=neqnfl')) then jhi = neqnfl else if ( s_eqi ( command,'jhi=nsenfl')) then jhi = nsenfl else read(command(5:),*)jhi end if else write ( *, * ) 'Enter value for JHI:' read(*,*)jhi write(17,*)jhi end if if ( 0 < iprint ) then write ( *, * ) 'JHI set to ',jhi end if ! ! JLO = ! else if ( s_eqi ( command(1:3),'jlo')) then if ( s_eqi ( command(1:4),'jlo=')) then read(command(5:),*)jlo else write ( *, * ) 'Enter value for JLO:' read(*,*)jlo write(17,*)jlo end if if ( 0 < iprint ) then write ( *, * ) 'JLO set to ',jlo end if ! ! L2NORM GFL/GFLSAV/GFLTAR/GFLTAY/GFLTMP ! else if ( s_eqi ( command(1:6),'l2norm')) then if ( s_eqi ( command(8:),'gfl')) then call l2norm(gfl,gflnrm,indx,nelem,neqnfl,node,np,xc,yc) write ( *, * ) 'ARBY4 - L2Norm of GFL = ',gflnrm else if ( s_eqi ( command(8:),'gflsav')) then call l2norm(gflsav,gflnrm,indx,nelem,neqnfl,node,np,xc,yc) write ( *, * ) 'ARBY4 - L2Norm of GFLSAV = ',gflnrm else if ( s_eqi ( command(8:),'gfltar')) then call l2norm(gfltar,gflnrm,indx,nelem,neqnfl,node,np,xc,yc) write ( *, * ) 'ARBY4 - L2Norm of GFLTAR = ',gflnrm else if ( s_eqi ( command(8:),'gfltay')) then call l2norm(gfltay,gflnrm,indx,nelem,neqnfl,node,np,xc,yc) write ( *, * ) 'ARBY4 - L2Norm of GFLTAY = ',gflnrm else if ( s_eqi ( command(8:),'gfltmp')) then call l2norm(gfltmp,gflnrm,indx,nelem,neqnfl,node,np,xc,yc) write ( *, * ) 'ARBY4 - L2Norm of GFLTMP = ',gflnrm else write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Error!' write ( *, * ) ' Legal choices were GFL/GFLSAV/GFLTAY/GFLTMP.' write ( *, * ) ' Your choice was '//command(8:) cycle end if ! ! MAXNEW = ! else if ( s_eqi ( command(1:6),'maxnew')) then if ( s_eqi ( command(1:7),'maxnew=')) then read(command(8:),*)maxnew else write ( *, * ) 'Enter value for MAXNEW:' read(*,*)maxnew write(17,*)maxnew end if if ( 0 < iprint ) then write ( *, * ) 'MAXNEW set to ',maxnew end if ! ! MAXOPT = ! else if ( s_eqi ( command(1:6),'maxopt')) then if ( s_eqi ( command(1:7),'maxopt=')) then read(command(8:),*)maxopt else write ( *, * ) 'Enter value for MAXOPT:' read(*,*)maxopt write(17,*)maxopt end if if ( 0 < iprint ) then write ( *, * ) 'MAXOPT set to ',maxopt end if ! ! MAXSIM = ! else if ( s_eqi ( command(1:6),'maxsim')) then if ( s_eqi ( command(1:7),'maxsim=')) then read(command(8:),*)maxsim else write ( *, * ) 'Enter value for MAXSIM:' read(*,*)maxsim write(17,*)maxsim end if if ( 0 < iprint ) then write ( *, * ) 'MAXSIM set to ',maxsim end if ! ! NBCRB = ! else if ( s_eqi ( command(1:5),'nbcrb')) then if ( s_eqi ( command(1:6),'nbcrb=')) then read(command(7:),*)nbcrb else write ( *, * ) 'Enter value for NBCRB:' read(*,*)nbcrb write(17,*)nbcrb end if if ( 0 < iprint ) then write ( *, * ) 'NBCRB set to ',nbcrb end if ! ! NEWTFL ! Apply Newton's method to full solution estimate. ! else if ( s_eqi ( command,'newtfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - NewtFL' write ( *, * ) ' Apply Newton to full solution estimate GFL.' end if call newtfl(afl,area,eqn,gfl,gflafl,ierror,ifs,ijac,indx,ipivfl,iwrite, & ldafl,maxelm,maxnew,nelem,neqnfl,nlband,node,np,npar,nparf,numnew,par, & parafl,phifl,region,resfl,rmax,splflo,tauflo,tolnew,xrange,yc,yrange) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Fatal error!' write ( *, * ) ' NEWTFL failed!' write ( *, * ) ' The parameters at which failure occurred:' write ( *, * ) ' ' call prpar(iopt,npar,nparb,nparf,par) ierror = 1 cycle else if ( iwrite <= 1) then write ( *, * ) ' Newton step ',numsim,' residual norm = ',rmax end if end if ! ! NEWTRB ! Apply Newton's method to reduced solution estimate. ! else if ( s_eqi ( command,'newtrb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - NewtRB' write ( *, * ) ' Apply Newton to reduced solution estimate GRB.' end if if ( ncofrb <= 0 ) then cycle end if call newtrb(arb,area,grb,grbarb,ierror,indx,ipivrb, & iwrite,maxcofrb,maxelm,maxnew,maxnfl,nbcrb,ncofrb,nelem, & nferb,node,np,npar,nparf,nx,ny,par,pararb,phirb, & rb,resrb,rmax,tauflo,tolnew,xc,xrange,yc,yrange) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Fatal error!' write ( *, * ) ' NEWTRB failed!' write ( *, * ) ' The parameters at which failure occurred:' call prpar(iopt,npar,nparb,nparf,par) ierror = 1 cycle else if ( iwrite <= 1) then write ( *, * ) ' Final Newton residual was MxNorm(FXRB) = ',rmax end if end if ! ! NPARB = ! else if ( s_eqi ( command(1:5),'nparb')) then if ( s_eqi ( command(1:6),'nparb=')) then read(command(7:),*)nparb else write ( *, * ) 'Enter value for NPARB:' read(*,*)nparb write(17,*)nparb end if if ( 0 < iprint ) then write ( *, * ) 'NPARB set to ',nparb end if ! ! NPARF = ! else if ( s_eqi ( command(1:5),'nparf')) then if ( s_eqi ( command(1:6),'nparf=')) then read(command(7:),*)nparf else write ( *, * ) 'Enter value for NPARF:' read(*,*)nparf write(17,*)nparf end if if ( 0 < iprint ) then write ( *, * ) 'NPARF set to ',nparf end if ! ! NSENFL = # ! else if ( s_eqi ( command(1:6),'nsenfl')) then if ( s_eqi ( command(1:7),'nsenfl=')) then read(command(8:),*)itemp else write ( *, * ) 'Enter value for NSENFL:' read(*,*)itemp write(17,*)itemp end if if ( itemp < 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' NSENFL must be at least 0!' write ( *, * ) ' but your value was ',itemp else nsenfl = itemp if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - NSENFL set to ',nsenfl end if end if ! ! NTAY = # ! NTAY = NCOFRB ! else if ( s_eqi ( command(1:4),'ntay')) then if ( s_eqi ( command(1:5),'ntay=')) then if ( s_eqi ( command(6:11),'ncofrb')) then itemp = ncofrb else read(command(6:),*)itemp end if else write ( *, * ) 'Enter value for NTAY:' read(*,*)itemp write(17,*)itemp end if if ( itemp < 0 .or. ncofrb < itemp ) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' NTAY must be between 0 and NCOFRB = ',ncofrb write ( *, * ) ' but your value was ',itemp else ntay = itemp if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - NTAY set to ',ntay end if end if ! ! NX = ! else if ( s_eqi ( command(1:2),'nx')) then if ( s_eqi ( command(1:3),'nx=')) then read(command(4:),*)itemp else write ( *, * ) 'Enter value for NX:' read(*,*)itemp write(17,*)itemp end if if ( itemp < 2 ) then write ( *, * ) 'ARBY4 - Unacceptable input.' write ( *, * ) ' NX must be at least 2.' write ( *, * ) ' Your value was ',itemp else if ( maxnx < itemp ) then write ( *, * ) 'ARBY4 - Unacceptable input.' write ( *, * ) ' NX must be no more than MAXNX = ',maxnx write ( *, * ) ' Your value was ',itemp else nx = itemp if ( 0 < iprint ) then write ( *, * ) 'NX set to ',nx write ( *, * ) 'Remember to use the SETLOG and SETGEO commands' write ( *, * ) 'before trying to solve your systems!' end if end if ! ! NY = ! else if ( s_eqi ( command(1:2),'ny')) then if ( s_eqi ( command(1:3),'ny=')) then read(command(4:),*)itemp else write ( *, * ) 'Enter value for NY:' read(*,*)itemp write(17,*)itemp end if if ( itemp < 2) then write ( *, * ) 'ARBY4 - Unacceptable input.' write ( *, * ) ' NY must be at least 2.' write ( *, * ) ' Your value was ',itemp else if ( maxny < itemp ) then write ( *, * ) 'ARBY4 - Unacceptable input.' write ( *, * ) ' NY must be no more than MAXNY = ',maxny write ( *, * ) ' Your value was ',itemp else ny = itemp if ( 0 < iprint ) then write ( *, * ) 'NY set to ',ny write ( *, * ) 'Remember to use the SETLOG and SETGEO commands' write ( *, * ) 'before trying to solve your system!' end if end if ! ! OPTFL ! else if ( s_eqi ( command,'optfl')) then write ( *, * ) 'ARBY4 - OPT FL:' write ( *, * ) ' Optimize the full system.' write ( *, * ) ' NO WAY, JOSE! NOT READY YET!' ! ! OPTDIFFL ! else if ( s_eqi ( command,'optdiffl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - OptDifFl:' write ( *, * ) ' Optimize the cost of the full system;' write ( *, * ) ' The optimization code will approximate cost' write ( *, * ) ' gradients by finite differences.' write ( *, * ) ' Initial estimate is (PAR,GFL,COST).' write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Note!' write ( *, * ) ' You must already have issued the TARGET command!' end if call optdiffl(afl,area,cost,dopt,eqn,etaq,gfl,gflafl, & gflopt,gfltar,gridx,gridy,ibs,ierror,ifs,ijac,indx,iopt, & ipivfl,isotri,ivopt,iwrite,ldafl,liv,lv,maxelm,maxnew,maxnfl, & maxnp,maxny,maxopt,maxpar,maxparb,maxparf,maxsim,nelem, & neqnfl,nlband,node,nodelm,np,npar,nparb,nparf,nprof,numdif, & numopt,nx,ny,par,parafl,paropt,phifl,region,resfl,splbmp, & splflo,taubmp,tauflo,tolnew,tolopt,tolsim,vopt,wateb,watep, & wateu,watev,wquad,xbl,xbr,xc,xopt,xquad,xrange,xsiq,ybl, & ybr,yc,yquad,yrange) if ( ierror == 0) then par(1:npar) = paropt(1:npar) gfl(1:neqnfl) = gflopt(1:neqnfl) write ( *, * ) ' ' write ( *, * ) 'Optimizing parameters:' call prpar(iopt,npar,nparb,nparf,par) write ( *, * ) ' ' write ( *, * ) 'Optimal cost = ',cost write ( *, * ) ' ' write ( *, * ) 'Number of standard full solutions:',numopt write ( *, * ) 'Number of auxilliary solutions: ',numdif else write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' The optimization was unsuccessful.' end if ! ! OPTDIFRB ! else if ( s_eqi ( command,'optdifrb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - OptDifRB:' write ( *, * ) ' Optimize the cost of the reduced system;' write ( *, * ) ' The optimization code will approximate cost' write ( *, * ) ' gradients by finite differences.' write ( *, * ) ' Initial estimate is (PAR,GRB,COST).' write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Note!' write ( *, * ) ' You must already have issued the commands:' write ( *, * ) ' SETLOG, SETGEO, NEWTFL, GETSEN, GETRB, TARGET!' end if call optdifrb(arb,area,cost,dopt,gflrb,gfltar,gfltmp, & grb,grbarb,grbopt,ierror,indx,iopt,ipivrb, & ivopt,iwrite,liv,lv,maxcofrb,maxelm,maxnew,maxnfl,maxnp, & maxny,maxopt,maxpar,maxparb,maxsim,nbcrb,ncofrb,nelem,neqnfl, & nferb,node,np,npar,nparb,nparf,nprof,numdif,numopt,nx,ny,par, & pararb,paropt,phirb,rb,resrb,splbmp,tauflo,taubmp,tolnew, & tolopt,tolsim,vopt,wateb,watep,wateu,watev,xbl,xbr,xc,xopt, & xrange,ybl,ybr,yc,yrange) if ( ierror == 0) then par(1:npar) = paropt(1:npar) grb(1:ncofrb) = grbopt(1:ncofrb) write ( *, * ) ' ' write ( *, * ) 'Optimizing parameters:' call prpar(iopt,npar,nparb,nparf,par) write ( *, * ) ' ' write ( *, * ) 'Optimal cost = ',cost write ( *, * ) ' ' write ( *, * ) 'Number of standard full solutions:',numopt write ( *, * ) 'Number of auxilliary solutions: ',numdif else write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' The optimization was unsuccessful.' end if ! ! PAR(*) = * ! else if ( s_eqi ( command(1:4),'par(')) then call chrcti(command(5:),ival,ierror,lchar) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' ChrCTI returned nonzero error flag!' cycle end if if ( ival < 1 .or. maxpar < ival ) then write ( *, * ) ' ' write ( *, * ) 'INPUT - Warning!' write ( *, * ) ' Index IVAL of PAR is out of bounds!' write ( *, * ) ' IVAL = ',ival cycle end if call chrctd(command(5+lchar+2:),value,ierror,lchar) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' ChrCTD returned nonzero error flag!' cycle end if par(ival) = value if ( 0 < iprint ) then write ( *, * ) 'PAR(',ival,') set to ',par(ival) end if ! ! PARTAR(*) = * ! else if ( s_eqi ( command(1:7),'partar(')) then call chrcti(command(8:),ival,ierror,lchar) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' ChrCTI returned nonzero error flag!' cycle end if if ( ival < 1 .or. maxpar < ival ) then write ( *, * ) ' ' write ( *, * ) 'INPUT - Warning!' write ( *, * ) ' Index IVAL of PARTAR is out of bounds!' write ( *, * ) ' IVAL = ', ival cycle end if call chrctd(command(8+lchar+2:),value,ierror,lchar) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' ChrCTD returned nonzero error flag!' cycle end if partar(ival) = value par(ival) = value if ( 0 < iprint ) then write ( *, * ) 'PARTAR(',ival,') set to ',partar(ival) end if ! ! PICFL ! else if ( s_eqi ( command,'picfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - PicFL:' write ( *, * ) ' Apply Picard to full solution estimate GFL.' end if call picfl(afl,area,eqn,gfl,ierror,ifs,indx,ipivfl,iwrite,ldafl,maxsim, & nelem,neqnfl,nlband,node,np,npar,nparf,numsim,par,phifl,region,resfl, & rmax,splflo,tauflo,tolsim,xc,xrange,yc,yrange) if ( iwrite <= 1) then write ( *, * ) ' Picard step ',numsim,' residual norm = ',rmax end if ! ! PICRB ! else if ( s_eqi ( command,'picrb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - PicRB:' write ( *, * ) ' Apply Picard to reduced solution estimate GRB.' end if if ( ncofrb <= 0) then cycle end if call picrb(arb,area,grb,ierror,indx,ipivrb,iwrite,maxcofrb,maxelm,maxnfl, & maxsim,nbcrb,ncofrb,nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb, & resrb,rmax,tauflo,tolsim,xc,xrange,yc,yrange) if ( iwrite <= 1) then write ( *, * ) ' Final Picard residual was MxNorm(FXRB) = ',rmax end if ! ! PRFPFL ! else if ( s_eqi ( command,'prfpfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr FP FL:' write ( *, * ) ' Print full jacobian.' write ( *, * ) ' Rows ILO = ',ilo,' to IHI=',ihi write ( *, * ) ' Cols JLO = ',jlo,' to JHI=',jhi write ( *, * ) ' ' write ( *, * ) ' Parameters for matrix, PARAFL:' call prpar(iopt,npar,nparb,nparf,parafl) end if call prbmat(afl,ihi,ilo,jhi,jlo,ldafl,neqnfl,nlband) ! ! PRFPRB ! else if ( s_eqi ( command,'prfprb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr FP RB:' write ( *, * ) ' Print reduced jacobian.' write ( *, * ) ' Rows ILO = ',ilo,' to IHI=',ihi write ( *, * ) ' Cols JLO = ',jlo,' to JHI=',jhi write ( *, * ) ' ' write ( *, * ) ' Parameters for matrix, PARARB:' call prpar(iopt,npar,nparb,nparf,pararb) end if mlo = 1 mhi = maxcofrb nlo = 1 nhi = maxcofrb call prdmat(arb,ihi,ilo,jhi,jlo,mhi,mlo,nhi,nlo) ! ! PRDAT ! else if ( s_eqi ( command,'prdat')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr Dat' write ( *, * ) ' Print current problem data.' end if call prdat(disfil,drey,epsdif,gridx,gridy,hx,hy,ibs,ibump,ifs,ijac,iopt, & maxnew,maxopt,maxsim,nbcrb,ncofrb,nelem,nferb,neqnfl,np,npar,nparb, & nparf,ntay,nx,ny,region,reytay,tecfil,tolnew,tolopt,tolsim,wateb, & watep,wateu,watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) ! ! PRELEM ! else if ( s_eqi ( command,'prelem')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr Elem' write ( *, * ) ' Print element data.' end if call prelem(ihi,ilo,nelem,node,np,xc,yc) ! ! PRFXFL ! else if ( s_eqi ( command,'prfxfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr FX FL' write ( *, * ) ' Print full residual FXFL.' end if call prvecfl(eqn,ihi,ilo,indx,neqnfl,np,resfl) ! ! PRFXFLNRM ! else if ( s_eqi ( command,'prfxflnrm')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr FX FL Nrm' write ( *, * ) ' Print norm of full residual FXFL.' end if call prfxfln(neqnfl,resfl) ! ! PRFXRB ! else if ( s_eqi ( command,'prfxrb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr FX RB' write ( *, * ) ' Print reduced residual FXRB.' end if nlo = 1 nhi = ncofrb call prvecrb(ihi,ilo,nhi,nlo,resrb) ! ! PRGFL ! else if ( s_eqi ( command,'prgfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr G FL:' write ( *, * ) ' Print full solution GFL.' write ( *, * ) ' ' write ( *, * ) ' Flow parameters, PAR:' call prpar(iopt,npar,nparb,nparf,par) end if call prvecfl(eqn,ihi,ilo,indx,neqnfl,np,gfl) ! ! PRGFLNRM ! else if ( s_eqi ( command,'prgflnrm')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr GFL Nrm:' write ( *, * ) ' Print norms of full solution GFL.' end if call fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar,nparf,par, & phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) call nrmflo(gfl,indx,neqnfl,np,resfl) ! ! PRGRB ! else if ( s_eqi ( command,'prgrb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr G RB:' write ( *, * ) ' Print reduced solution GRB.' end if call prgrb(grb,ncofrb) ! ! PRGSEN ! else if ( s_eqi ( command,'prgsen')) then call prgrb(gsen,nbcrb+nsenfl) ! ! PRINDX ! else if ( s_eqi ( command,'prindx')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr INDX' write ( *, * ) ' Print node/equation table,' write ( *, * ) ' for nodes ILO = ',ilo,' to IHI=',ihi end if call prindx(ihi,ilo,indx,np,xc,yc) ! ! PRPAR ! else if ( s_eqi ( command,'prpar')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr PAR: Print current parameters PAR.' end if call prpar(iopt,npar,nparb,nparf,par) ! ! PRPARTAR ! else if ( s_eqi ( command,'prpartar')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr PAR TAR:' write ( *, * ) ' Print target parameters PARTAR.' end if call prpar(iopt,npar,nparb,nparf,partar) ! ! PRRBASE ! else if ( s_eqi ( command,'prrbase')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr RBase' write ( *, * ) ' Print the "R" factor of the reduced basis.' end if ilo = 1 ihi = ncofrb jlo = 1 jhi = ncofrb mlo = 1 mhi = maxcofrb nlo = 1 nhi = maxcofrb call prdmat(rbase,ihi,ilo,jhi,jlo,mhi,mlo,nhi,nlo) ! ! PRRB ! else if ( s_eqi ( command,'prrb')) then if ( ncofrb <= 0) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' PRRB command cancelled, NCOFRB = ',ncofrb write ( *, * ) ' Use the GETRB command first!' cycle end if if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr RB' write ( *, * ) ' Print the reduced basis,' write ( *, * ) ' nodes ILO = ',ilo,' to IHI=',ihi write ( *, * ) ' columns JLO = ',jlo,' to JHI=',jhi write ( *, * ) ' ' write ( *, * ) ' Parameters at reduced basis, PARRB:' call prpar(iopt,npar,nparb,nparf,parrb) end if call prmatfl(rb,eqn,ihi,ilo,indx,jhi,jlo,maxnfl,ncofrb,neqnfl,np) ! ! PRSENFL: Print full sensitivities. ! else if ( s_eqi ( command,'prsenfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr Sen FL' write ( *, * ) ' Print full sensitivities.' write ( *, * ) ' ' write ( *, * ) ' Parameters at sensitivity, PARSEN:' call prpar(iopt,npar,nparb,nparf,parsen) end if call prmatfl(senfl,eqn,ihi,ilo,indx,jhi,jlo,maxnfl,nsenfl,neqnfl,np) ! ! PRSENNRM: Print full sensitivity norms. ! else if ( s_eqi ( command,'prsennrm')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr Sen Nrm' write ( *, * ) ' Print sensitivity norms.' end if call prsenn(maxcofrb,maxnfl,ncofrb,neqnfl,senfl) ! ! PRSENRB: Print reduced sensitivities. ! else if ( s_eqi ( command,'prsenrb')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr Sen RB' write ( *, * ) ' Print matrix of reduced sensitivities,' write ( *, * ) ' rows ILO = ',ilo,' to IHI=',ihi write ( *, * ) ' columns JLO = ',jlo,' to JHI=',jhi write ( *, * ) ' ' write ( *, * ) ' Parameters at sensitivity, PARSEN:' call prpar(iopt,npar,nparb,nparf,parsen) end if mlo = 1 mhi = maxcofrb nlo = 1 nhi = ncofrb call prdmat(senrb,ihi,ilo,jhi,jlo,mhi,mlo,nhi,nlo) ! ! PRUVPGFL ! else if ( s_eqi ( command,'pruvpgfl')) then call pruvpfl(gfl,indx,neqnfl,np,xc,xmax,xmin,yc,ymax,ymin) ! ! PRUVPRB ! else if ( s_eqi ( command,'pruvprb')) then do j = 1, ncofrb write ( *, * ) ' ' write ( *, * ) 'Reduced basis vector ',j write ( *, * ) ' ' call pruvpfl(rb(1,j),indx,neqnfl,np,xc,xmax,xmin,yc,ymax,ymin) end do ! ! PRUVPSENFL ! else if ( s_eqi ( command,'pruvpsenfl')) then do j = 1, nsenfl write ( *, * ) ' ' write ( *, * ) 'Sensitivity vector ',j write ( *, * ) ' ' call pruvpfl(senfl(1,j),indx,neqnfl,np,xc,xmax,xmin,yc,ymax,ymin) end do ! ! PRUVPGRB ! else if ( s_eqi ( command,'pruvpgrb')) then call pruvprb(grb,indx,maxnfl,ncofrb,nelem,node,nodelm,np, & rb,xc,xmax,xmin,yc,ymax,ymin) ! ! PRXY ! else if ( s_eqi ( command,'prxy')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Pr XY' write ( *, * ) ' Print out X and Y nodal coordinates.' end if call prxy(ihi,ilo,np,ny,xc,yc) ! ! QUIT ! else if ( s_eqi ( command, 'quit' ) ) then exit ! ! REDUCE GFL ! else if ( s_eqi ( command,'reduce gfl')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Reduce GFL:' write ( *, * ) ' Given a reduced basis RB computed at the' write ( *, * ) ' full solution GFLRB, and an arbitrary full' write ( *, * ) ' solution GFL, compute the reduced basis ' write ( *, * ) ' coefficients of GFL:' write ( *, * ) ' GRB = RB^T * GFL.' end if call gfl2rb(gfl,gflrb,grb,maxnfl,ncofrb,neqnfl,rb) ! ! REGION = ! else if ( s_eqi ( command(1:6),'region')) then if ( s_eqi ( command(1:7),'region=')) then region = command(8:) else write ( *, * ) 'Enter the region, CAVITY, CHANNEL or STEP:' read(*,'(a)')region write(17,'(a)')region end if if ( s_eqi ( region,'cavity')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Cavity:' write ( *, * ) ' Set user input values to cavity defaults.' end if call cavity(ibs,ibump,ifs,iopt,maxopt,maxpar,nbcrb,npar,nparb,nparf, & npe,nx,ny,par,region,reynld,tolnew,tolopt,tolsim,wateb,watep,wateu, & watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) else if ( s_eqi ( region,'cavity2')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Cavity2:' write ( *, * ) ' Set H C Lee cavity defaults.' end if call cavity2(ibs,ibump,ifs,iopt,maxopt,maxpar,nbcrb,npar,nparb,nparf, & npe,nx,ny,par,region,reynld,tolnew,tolopt,tolsim,wateb,watep,wateu, & watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) else if ( s_eqi ( region,'channel')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Channel:' write ( *, * ) ' Set user input values to channel defaults.' end if call channl(ibs,ibump,ifs,iopt,maxopt,maxpar,nbcrb,npar,nparb,nparf, & npe,nx,ny,par,region,reynld,tolnew,tolopt,tolsim,wateb,watep,wateu, & watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) else if ( s_eqi ( region,'step')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Step`:' write ( *, * ) ' Set user input values to step defaults.' end if call step(ibs,ibump,ifs,iopt,maxopt,maxpar,nbcrb,npar,nparb,nparf,npe, & nx,ny,par,region,reynld,tolnew,tolopt,tolsim,wateb,watep,wateu,watev, & xbl,xbr,xprof,xrange,ybl,ybr,yrange) end if ! ! REYNLD = ! else if ( s_eqi ( command(1:6),'reynld')) then if ( s_eqi ( command(1:7),'reynld=')) then read(command(8:),*)reynld else write ( *, * ) 'Enter value for REYNLD:' read(*,*)reynld write(17,*)reynld end if par(nparf+nparb+1) = reynld if ( 0 < iprint ) then write ( *, * ) 'REYNLD parameter set to ',reynld end if ! ! REYTAY = ! else if ( s_eqi ( command(1:6),'reytay')) then if ( s_eqi ( command(1:7),'reytay=')) then if ( s_eqi ( command,'reytay=reynld')) then reytay = reynld else read(command(8:),*)reytay end if else write ( *, * ) 'Enter value for REYTAY:' read(*,*)reytay write(17,*)reytay end if if ( 0 < iprint ) then write ( *, * ) 'REYTAY parameter set to ',reytay end if ! ! SETGEO ! else if ( s_eqi ( command,'setgeo')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - SetGeo: Set problem geometry.' end if call setgeo(area,etaq,gridx,gridy,ibs,isotri,nelem,node,nodelm,np,npar, & nparb,nparf,nx,ny,par,phifl,region,splbmp,taubmp,wquad,xbl,xbr,xc, & xquad,xrange,xsiq,ybl,ybr,yc,yquad,yrange) ! ! SETLOG ! else if ( s_eqi ( command,'setlog')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - SetLog: Set problem logical data.' end if call setlog(eqn,hx,hy,ibump,indx,isotri,ldafl,maxelm,maxnfl,maxnp,nelem, & neqnfl,nlband,node,np,nprof,nx,ny,region,xbl,xbr,xprof,xrange,ybr,yrange) ! ! STOP ! else if ( s_eqi ( command,'stop') ) then exit ! ! TARGET ! else if ( s_eqi ( command,'target')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Target:' write ( *, * ) ' Save current GFL as GTAR.' end if call target(cost0,gfl,gfltar,indx,maxnfl,maxny,maxparb,neqnfl,np,npar, & nparb,nprof,ny,par,partar,splbmp,taubmp,wateb,watep,wateu,watev,xbl, & xbr,ybl,ybr,yc) ! ! TEST2 ! else if ( s_eqi ( command,'test2')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Test2:' write ( *, * ) ' Compare full and reduced state variables' write ( *, * ) ' in elements ILO through IHI.' end if call test2(gfl,grb,ihi,ilo,indx,maxcofrb,maxelm,ncofrb, & nelem,neqnfl,node,np,phifl,phirb) ! ! TEST3 ! else if ( s_eqi ( command,'test3')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Test3:' write ( *, * ) ' Compare RB*Rfact and SenFL.' end if call test3(maxcofrb,maxnfl,ncofrb,neqnfl,rb,senfl,senrb) ! ! TEST4 ! else if ( s_eqi ( command,'test4')) then if ( ipar <= 0 .or. npar < ipar ) then write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' Cancelling the TEST4 command.' write ( *, * ) ' IPAR = ',ipar write ( *, * ) ' but IPAR must be at least 0' write ( *, * ) ' and no more than NPAR = ',npar cycle end if if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Test4' write ( *, * ) ' Compare full sensitivities computed directly' write ( *, * ) ' and via finite differences.' end if call test4(afl,area,difcof,dpar,drey,eqn,gfl,gflafl, & ifs,ijac,indx,ipar,ipivfl,iwrite,ldafl,maxcofrb,maxelm, & maxnew,maxnfl,ncofrb,nelem,neqnfl,nlband,node,np,npar, & nparf,nsenfl,par,parafl,phifl,region,resfl, & senfl,splflo,tauflo,tolnew,xrange,yc,yrange) ! ! TEST5 ! else if ( s_eqi ( command,'test5')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Test5:' write ( *, * ) ' Compare RB*Rfact and basis vectors.' end if call test5(maxcofrb,maxnfl,ncofrb,neqnfl,rb,rbase) ! ! TIME ! else if ( s_eqi ( command,'time')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - Time:' write ( *, * ) ' Report current time,' write ( *, * ) ' time elapsed since last TIME call,' write ( *, * ) ' time elapsed since the program began.' end if write ( *, * ) ' The (real) start time was '// trim ( tstart ) call date_and_time ( date, time ) write ( *, * ) ' The current (real) time is ' // trim ( time ) ! ! TOLNEW = ! else if ( s_eqi ( command(1:6),'tolnew')) then if ( s_eqi ( command(1:7),'tolnew=')) then read(command(8:),*)tolnew else write ( *, * ) 'Enter value for TOLNEW:' read(*,*)tolnew write(17,*)tolnew end if if ( 0 < iprint ) then write ( *, * ) 'TOLNEW set to ',tolnew end if ! ! TOLOPT = ! else if ( s_eqi ( command(1:6),'tolopt')) then if ( s_eqi ( command(1:7),'tolopt=')) then read(command(8:),*)tolopt else write ( *, * ) 'Enter value for TOLOPT:' read(*,*)tolopt write(17,*)tolopt end if if ( 0 < iprint ) then write ( *, * ) 'TOLOPT set to ',tolopt end if ! ! TOLSIM = ! else if ( s_eqi ( command(1:6),'tolsim')) then if ( s_eqi ( command(1:7),'tolsim=')) then read(command(8:),*)tolsim else write ( *, * ) 'Enter value for TOLSIM:' read(*,*)tolsim write(17,*)tolsim end if if ( 0 < iprint ) then write ( *, * ) 'TOLSIM set to ',tolsim end if ! ! TecPlot ! else if ( s_eqi ( command,'tecplot')) then if ( 0 < iprint ) then write ( *, * ) 'ARBY4 - TecPlot:' write ( *, * ) ' Write data to TECPLOT plot file.' end if call intprs(gfl,indx,nelem,neqnfl,node,np,p) u(1:np) = gfl(indx(1,1:np)) v(1:np) = gfl(indx(2,1:np)) call wrtec(nelem,node,np,p,tecfil,u,v,xc,yc) ! ! WATEB = ! else if ( s_eqi ( command(1:5),'wateb')) then if ( s_eqi ( command(1:6),'wateb=')) then read(command(7:),*)wateb else write ( *, * ) 'Enter value for WATEB:' read(*,*)wateb write(17,*)wateb end if if ( 0 < iprint ) then write ( *, * ) 'WATEB set to ',wateb end if ! ! WATEP = ! else if ( s_eqi ( command(1:5),'watep')) then if ( s_eqi ( command(1:6),'watep=')) then read(command(7:),*)watep else write ( *, * ) 'Enter value for WATEP:' read(*,*)watep write(17,*)watep end if if ( 0 < iprint ) then write ( *, * ) 'WATEP set to ',watep end if ! ! WATEU = ! else if ( s_eqi ( command(1:5),'wateu')) then if ( s_eqi ( command(1:6),'wateu=')) then read(command(7:),*)wateu else write ( *, * ) 'Enter value for WATEU:' read(*,*)wateu write(17,*)wateu end if if ( 0 < iprint ) then write ( *, * ) 'WATEU set to ',wateu end if ! ! WATEV = ! else if ( s_eqi ( command(1:5),'watev')) then if ( s_eqi ( command(1:6),'watev=')) then read(command(7:),*)watev else write ( *, * ) 'Enter value for WATEV:' read(*,*)watev write(17,*)watev end if if ( 0 < iprint ) then write ( *, * ) 'WATEV set to ',watev end if ! ! XBL = ! else if ( s_eqi ( command(1:3),'xbl')) then if ( s_eqi ( command(1:4),'xbl=')) then read(command(5:),*)xbl else write ( *, * ) 'Enter value for XBL:' read(*,*)xbl write(17,*)xbl end if if ( 0 < iprint ) then write ( *, * ) 'XBL set to ',xbl end if ! ! XBR = ! else if ( s_eqi ( command(1:3),'xbr')) then if ( s_eqi ( command(1:4),'xbr=')) then read(command(5:),*)xbr else write ( *, * ) 'Enter value for XBR:' read(*,*)xbr write(17,*)xbr end if if ( 0 < iprint ) then write ( *, * ) 'XBR set to ',xbr end if ! ! XMAX = ! else if ( s_eqi ( command(1:4),'xmax')) then if ( s_eqi ( command(1:5),'xmax=')) then read(command(6:),*)xmax else write ( *, * ) 'Enter value for XMAX:' read(*,*)xmax write(17,*)xmax end if if ( 0 < iprint ) then write ( *, * ) 'XMAX set to ',xmax end if ! ! XMIN = ! else if ( s_eqi ( command(1:4),'xmin')) then if ( s_eqi ( command(1:5),'xmin=')) then read(command(6:),*)xmin else write ( *, * ) 'Enter value for XMIN:' read(*,*)xmin write(17,*)xmin end if if ( 0 < iprint ) then write ( *, * ) 'XMIN set to ',xmin end if ! ! XPROF = ! else if ( s_eqi ( command(1:5),'xprof')) then if ( s_eqi ( command(1:6),'xprof=')) then read(command(7:),*)xprof else write ( *, * ) 'Enter value for XPROF:' read(*,*)xprof write(17,*)xprof end if if ( 0 < iprint ) then write ( *, * ) 'XPROF set to ',xprof end if ! ! XRANGE = ! else if ( s_eqi ( command(1:6),'xrange')) then if ( s_eqi ( command(1:7),'xrange=')) then read(command(8:),*)xrange else write ( *, * ) 'Enter value for XRANGE:' read(*,*)xrange write(17,*)xrange end if if ( 0 < iprint ) then write ( *, * ) 'XRANGE set to ',xrange end if ! ! YBL = ! else if ( s_eqi ( command(1:3),'ybl')) then if ( s_eqi ( command(1:4),'ybl=')) then read(command(5:),*)ybl else write ( *, * ) 'Enter value for YBL:' read(*,*)ybl write(17,*)ybl end if if ( 0 < iprint ) then write ( *, * ) 'YBL set to ',ybl end if ! ! YBR = ! else if ( s_eqi ( command(1:3),'ybr')) then if ( s_eqi ( command(1:4),'ybr=')) then read(command(5:),*)ybr else write ( *, * ) 'Enter value for YBR:' read(*,*)ybr write(17,*)ybr end if if ( 0 < iprint ) then write ( *, * ) 'YBR set to ',ybr end if ! ! YMAX = ! else if ( s_eqi ( command(1:4),'ymax')) then if ( s_eqi ( command(1:5),'ymax=')) then read(command(6:),*)ymax else write ( *, * ) 'Enter value for YMAX:' read(*,*)ymax write(17,*)ymax end if if ( 0 < iprint ) then write ( *, * ) 'YMAX set to ',ymax end if ! ! YMIN = ! else if ( s_eqi ( command(1:4),'ymin')) then if ( s_eqi ( command(1:5),'ymin=')) then read(command(6:),*)ymin else write ( *, * ) 'Enter value for YMIN:' read(*,*)ymin write(17,*)ymin end if if ( 0 < iprint ) then write ( *, * ) 'YMIN set to ',ymin end if ! ! YRANGE = ! else if ( s_eqi ( command(1:6),'yrange')) then if ( s_eqi ( command(1:7),'yrange=')) then read(command(8:),*)yrange else write ( *, * ) 'Enter value for YRANGE:' read(*,*)yrange write(17,*)yrange end if if ( 0 < iprint ) then write ( *, * ) 'YRANGE set to ',yrange end if ! ! Unrecognized command ! else write ( *, * ) ' ' write ( *, * ) 'ARBY4 - Warning!' write ( *, * ) ' Unrecognized command: ' // trim ( command ) end if end do write ( *, * ) ' ' write ( *, * ) 'ARBY4 - STOP command:' write ( *, * ) ' Halt the program!' write ( *, * ) ' ' close(unit = 17) write ( *, * ) ' Closing the user input file ARBY.IN.' write ( *, * ) ' ' write ( *, * ) ' The (real) start time was '// trim ( tstart ) call date_and_time ( date, time ) tstop = time write ( *, * ) ' The (real) stopping time was '// trim ( tstop ) call delhms ( tstart, tstop, itemp ) write ( *, * ) ' The (real) elapsed time in seconds is ',itemp write ( *, * ) ' The real elapsed time in minutes is ', & real(itemp) / 60.0D+00 call etime ( tarray, estop ) write ( *, * ) ' ' write ( *, * ) ' CPU in seconds = ',estop-estart write ( *, * ) ' CPU in minutes = ',(estop-estart)/60.0D+00 write ( *, * ) ' ' write ( *, * ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine diffprb ( arb, area, epsdif, grb, indx, maxcofrb, maxelm, & maxnfl, nbcrb, ncofrb, nelem, nferb, node, np, npar, nparf, nx, & ny, par, phirb, rb, resrb, reynld, tauflo, xc, xrange, yc, yrange ) !*****************************************************************************80 ! !! DIFFPRB estimates the jacobian of the reduced function. ! ! Discussion: ! ! Finite differences are used. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision ARB(MAXCOFRB,MAXCOFRB). ! ARB contains the Jacobian or Picard matrix for the reduced ! Navier Stokes system, stored as an NCOFRB by NCOFRB array. ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! ! or, if the element is isoperimetric, ! ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! ! Here Ar(IELEM) represents the area of element IELEM. ! ! double precision EPSDIF. ! EPSDIF is a small quantity, which is used to compute the ! perturbations for the finite difference approximations. ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXELM. ! MAXELM is the maximum number of elements. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NFERB. ! NFERB is the number of reduced basis coefficients that will ! be determined via the finite element method. ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! Global nodes Elements NODE ! 1 2 3 4 5 6 ! 74 84 94 3-6-1 2 Left element = (94,72,74,83,73,84) ! | / /| ! 73 83 93 5 4 4 5 Right element = (72,94,92,83,93,82) ! |/ / | ! 72 82 92 2 1-6-3 ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! The number of elements along a line in the X direction is ! NX-1 (or 2*(NX-1) to make a full rectangular strip). ! ! integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! The number of elements along a line in the Y direction is ! NY-1 (or 2*(NY-1) to make a full vertical strip). ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! double precision PHIRB(3,MAXCOFRB,15,MAXELM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! RB is based on a particular solution of the full system, ! which is saved as GFLRB. ! We compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! ! double precision RESRB(NCOFRB). ! RESRB contains the residual in the reduced basis equations, ! for the parameter values PAR and reduced basis coefficients GRB. ! ! double precision REYNLD. ! REYNLD is the current value of the Reynolds number. ! Normally, REYNLD is stored as PARA(NPARF+NPARB+1). ! ! double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. ! ! A recent code change was made. For a channel flow, where ! NPARF = 1 meant a fit through 3 points, now NPARF=3 means ! a fit through 3 points. The endpoints must be explicitly ! counted. ! ! double precision XC(NP). ! XC contains the X coordinates of the nodes. ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none integer maxcofrb integer maxelm integer maxnfl integer nelem integer ncofrb integer np integer npar integer nparf double precision arb(maxcofrb,ncofrb) double precision area(3,nelem) double precision delta double precision epsdif double precision grb(ncofrb) double precision grbtmp(ncofrb) integer i integer indx(3,np) integer j integer nbcrb integer nferb integer node(6,maxelm) integer nx integer ny double precision par(npar) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision resrb(ncofrb) double precision reynld double precision tauflo(nparf) double precision xc(np) double precision xrange double precision yc(np) double precision yrange ! ! Get the function value at the base value. ! call fxrb(area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb, & resrb,reynld,tauflo,xc,xrange,yc,yrange) ! ! Start each column of the jacobian equal to F(GRB). ! do j = 1, ncofrb arb(1:ncofrb,j) = resrb(1:ncofrb) end do do j = 1, ncofrb ! ! Perturb G(J). ! grbtmp(1:ncofrb) = grb(1:ncofrb) delta = epsdif * ( 1.0D+00 + abs ( grb(j) ) ) grbtmp(j) = grb(j) + delta ! ! Evaluate F(I) at the perturbed value G(J). ! call fxrb(area,grbtmp,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb, & resrb,reynld,tauflo,xc,xrange,yc,yrange) ! ! Estimate the dependence ARB(I,J) = dF(I)/dG(J) ! arb(1:ncofrb,j) = ( resrb(1:ncofrb) - arb(1:ncofrb,j) ) / delta end do return end subroutine difsenfl ( afl, area, difcof, dpar, eqn, gfl, gflafl, ifs, & ijac, indx, ipar, ipivfl, iwrite, ldafl, maxcofrb, maxelm, maxnew, & maxnfl, ncofrb, nelem, neqnfl, nlband, node, np, npar, nparf, par, & parafl, phifl, region, resfl, senfl, splflo, tauflo, tolnew, & xrange, yc, yrange ) !*****************************************************************************80 ! !! DIFSENFL estimates full solution derivatives with respect to parameters. ! ! Discussion: ! ! The routine computes a central difference estimate for the first ! NCOFRB derivatives of the full solution GFL with respect to the IPAR-th ! parameter. ! ! DIFSENFL is rather inefficient. ALTHOUGH SOME SOLUTIONS ! ARE USED SEVERAL TIMES, DIFSENFL RECOMPUTES THEM EACH TIME. ! A CORRECTION OF THIS PROBLEM WOULD BE TO COMPUTE THE ENTIRE ! TRIANGLE OF COEFFICIENTS FIRST, AND THEN COMPUTE JUST THE ! SOLUTIONS NEEDED ONCE. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision AFL(LDAFL,MAXNFL). ! If Newton iteration is being carried out, AFL contains the ! Jacobian matrix for the full system. ! If Picard iteration is being carried out, AFL contains the ! Picard matrix for the full system. ! AFL is stored in LINPACK general band storage mode, with ! logical dimensions (3*NLBAND+1, NEQNFL). ! Where is the (I,J) entry of AFL actually stored? ! AFL has actual storage for such an entry only if ! -NLBAND <= I-J <= NLBAND. ! In such a case, the (I,J) entry is actually stored in ! AFL(I-J+2*NLBAND+1,J) ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! double precision DIFCOF(NDIF). ! DIFCOF contains the coefficients needed to approximate ! the 0-th through (NDIF-1)-th derivatives of a function F. ! ! double precision DREY. ! DREY is the suggested increment in the REYNLD value, ! to be used during the finite difference estimations. ! ! double precision DOPT(NPAR). ! DOPT contains a set of scale factors for the parameters, used ! by the optimization code. The suggestion is that DOPT(I) be ! chosen so that DOPT(I)*PAR(I) is roughly the same order of ! magnitude for I from 1 to NPAR. ! ! double precision DPAR. ! DPAR is the suggested increment in the parameter value, ! to be used during the finite difference estimations. ! ! character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. ! ! 'U' A horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! ! 'V' A vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! ! 'P' A continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! double precision GFLAFL(NEQNFL). ! GFLAFL stores the value of GFL at which the Jacobian ! was generated. ! ! integer IFS. ! IFS is the inflow shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer IJAC. ! IJAC determines the frequency for evaluating and factoring ! the Jacobian matrix during any particular Newton process. ! 1, evaluate the Jacobian on every step of the Newton ! iteration. ! n, evaluate the Jacobian only at steps 0, n, 2*n, and so on. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! integer IPAR. ! IPAR is the index of the parameter to be varied. ! ! integer IPIVFL(NEQNFL). ! IPIVFL is a pivot vector for the solution of the full ! linear system. ! ! integer IWRITE. ! IWRITE controls the amount of output printed. ! 0, print out the least amount. ! 1, print out some. ! 2, print out a lot. ! ! integer LDAFL. ! LDAFL is the first dimension of the matrix AFL as declared in ! the main program. LDAFL must be at least 3*NLBAND+1. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXELM. ! MAXELM is the maximum number of elements. ! ! integer MAXNEW. ! MAXNEW is the maximum number of steps to take in one Newton ! iteration. A typical value is 20. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NLBAND. ! NLBAND is the lower bandwidth of the matrix AFL. ! The zero structure of AFL is assumed to be symmetric, and so ! NLBAND is also the upper bandwidth of AFL. ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! Global nodes Elements NODE ! 1 2 3 4 5 6 ! 74 84 94 3-6-1 2 Left element = (94,72,74,83,73,84) ! | / /| ! 73 83 93 5 4 4 5 Right element = (72,94,92,83,93,82) ! |/ / | ! 72 82 92 2 1-6-3 ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! double precision PARAFL(NPAR). ! PARAFL contains the parameters where the Picard matrix or ! Jacobian of the full system was generated. ! ! double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points (which are the element midside nodes). ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! character ( len = 20 ) REGION. ! REGION specifies the flow region. ! ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottome, with tangential velocity specifications ! there. ! ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! double precision RESFL(NEQNFL). ! RESFL contains the residual in the full basis equations. ! ! double precision SENFL(MAXNFL,MAXCOFRB). ! Columns 1 through NSENFL of SENFL contain the sensitivities ! of the full solution with respect to the REYNLD parameter, for ! orders 0 through NSENFL-1. ! ! SENFL(I,J) contains the (J-1)-th sensitivity of the I-th full unknown ! with respect to REYNLD. ! ! double precision SPLFLO(NPARF). ! SPLFLO contains the spline coefficients for the inflow. ! ! double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. ! ! A recent code change was made. For a channel flow, where ! NPARF = 1 meant a fit through 3 points, now NPARF=3 means ! a fit through 3 points. The endpoints must be explicitly ! counted. ! ! double precision TOLNEW. ! TOLNEW is the convergence tolerance for the Newton iteration. ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer ldafl integer maxcofrb integer maxelm integer maxnfl integer ncofrb integer nelem integer neqnfl integer np integer npar integer nparf ! double precision afl(ldafl,neqnfl) double precision area(3,nelem) double precision difcof(ncofrb) double precision dpar character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) double precision gflafl(neqnfl) double precision gfltmp(neqnfl) integer i integer ierror integer ifs integer ijac integer indx(3,np) integer ipar integer ipivfl(neqnfl) integer iwrite integer j integer maxnew integer ndif integer nlband integer node(6,nelem) integer numnew double precision par(npar) double precision parafl(npar) double precision partmp(npar) double precision phifl(3,6,10,nelem) character ( len = 20 ) region double precision resfl(neqnfl) double precision rmax double precision senfl(maxnfl,maxcofrb) double precision splflo(nparf) double precision tauflo(nparf) double precision tolnew double precision xrange double precision yc(np) double precision yrange ! ! Zero out the SENFL array. ! senfl(1:neqnfl,1:ncofrb) = 0.0D+00 write ( *, * ) ' ' write ( *, * ) ' DIFSENFL: DPAR = ',dpar ! ! Compute difference NDIF, for NDIF = 0 to NCOFRB. ! do ndif = 1, ncofrb if ( ndif == 0 ) then senfl(1:neqnfl,ndif) = gfl(1:neqnfl) else if ( 2 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, * ) 'DIFSENFL - Computing difference NDIF = ',ndif end if ! ! Get the NDIF-1 order difference coefficients. ! call difset(difcof,dpar,iwrite,ndif) ! ! Evaluate the solution at several values of the parameter. ! do i = 0, ndif ! ! Copy the parameters, but reset the IPAR-th parameter value. ! partmp(1:npar) = par(1:npar) partmp(ipar) = par(ipar)+(2*i-ndif)*dpar write ( *, * ) 'J = ',j,' PAR(IPAR)=',partmp(ipar) ! ! Estimate the solution GTMP at parameters PARTMP. ! gfltmp(1:neqnfl) = gfl(1:neqnfl) ! ! Call NEWTFL to get the solution more closely. ! call newtfl(afl,area,eqn,gfltmp,gflafl,ierror,ifs,ijac,indx,ipivfl, & iwrite,ldafl,maxelm,maxnew,nelem,neqnfl,nlband,node,np,npar,nparf, & numnew,partmp,parafl,phifl,region,resfl,rmax,splflo,tauflo,tolnew, & xrange,yc,yrange) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'DIFSENFL - Fatal error!' write ( *, * ) ' NEWTFL failed, with IERROR = ',ierror stop end if ! ! Add the term associated with this solution to the estimate ! of the NDIF-th derivative. ! senfl(1:neqnfl,ndif) = senfl(1:neqnfl,ndif) & + difcof(i+1) * gfltmp(1:neqnfl) end do end if end do return end subroutine difsenrb(arb,area,difcof,dpar,grb,grbarb,indx,ipar,ipivrb,iwrite, & maxcofrb,maxelm,maxnew,maxnfl,nbcrb,ncofrb,nelem,nferb,node,np,npar,nparf, & nx,ny,par,pararb,phirb,rb,resrb,senrb,tauflo,tolnew,xc,xrange,yc,yrange) !*****************************************************************************80 ! !! DIFSENRB estimates the reduced sensitivities using finite differences. ! ! Discussion: ! ! The denominators used in the difference calculations ! get very small if the original increment is smaller than 1. ! It is strongly suggested that the parameter increment not be ! made too small! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Workspace, double precision ARB(MAXNRB,MAXNRB). ! ARB contains the Jacobian or Picard matrix for the reduced ! Navier Stokes system, stored as a dense NCOFRB by NCOFRB ! array. ! ! Input, double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! Workspace, double precision DCOF(0:NDIF). ! DCOF contains the coefficients needed to approximate ! the NDIF-th derivative of a function F. ! ! Input, double precision DPAR. ! DPAR is the suggested increment in the parameter value, ! to be used during the finite difference estimations. ! ! Input, double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! Output, double precision GRBARB(NCOFRB). ! GRBARB contains the reduced basis coefficients at which ! the matrix ARB was last evaluated. ! ! Workspace, double precision GRBTMP(NCOFRB). ! ! Input, integer IPAR. ! The index of the parameter to be varied. ! ! Workspace, integer IPIVRB(NCOFRB). ! IPIVRB is a pivot vector for the solution of the reduced ! linear system. ! ! Input, integer IWRITE. ! IWRITE controls the amount of output printed. ! 0, print out the least amount. ! 1, print out some. ! 2, print out a lot. ! ! Input, integer MAXNEW. ! MAXNEW is the maximum number of steps to take in one Newton ! iteration. A typical value is 20. ! ! Input, integer MAXNRB. ! MAXNRB is the maximum number of equations allowed for the ! reduced basis system. ! ! Input, integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! Input, integer NCOFRB. ! NCOFRB is the number of basis functions used for the ! reduced basis method. (The first basis vector is labeled ! "0"). In this program, that amounts to the number of columns ! in the matrix RB. NCOFRB is also the number of reduced basis ! state equations, and reduced basis coefficients GRB. ! ! Input, integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! Input, double precision PAR(NPAR). ! PAR is the current estimate for the parameters. ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! Output, double precision PARARB(NPAR). ! PARARB contains the parameters where the Picard matrix or ! Jacobian of the reduced system was generated. ! ! Workspace, double precision PARTMP(NPAR). ! ! double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! Workspace, double precision RESRB(NCOFRB). ! RESRB contains the residual in the reduced basis equations, ! for the parameter values PAR and reduced basis coefficients GRB. ! ! Output, double precision SENRB(MAXNRB,NCOFRB). ! SENRB contains the first several order sensitivities of the ! reduced solution with respect to the REYNLD parameter. ! SENRB(I,J) contains the J-th sensitivity of the I-th reduced unknown ! with respect to REYNLD. ! ! Input, double precision TOLNEW. ! TOLNEW is the convergence tolerance for the Newton iteration. ! implicit none ! integer maxcofrb integer maxelm integer maxnfl integer ncofrb integer nelem integer np integer npar integer nparf ! double precision arb(maxcofrb,maxcofrb) double precision area(3,nelem) double precision difcof(maxcofrb) double precision dpar double precision grb(maxcofrb) double precision grbarb(maxcofrb) double precision grbtmp(maxcofrb) integer i integer icof integer ierror integer indx(3,np) integer ipar integer ipivrb(maxcofrb) integer iwrite integer j integer jcof integer jdif integer maxnew integer nbcrb integer nferb integer node(6,nelem) integer nx integer ny double precision par(npar) double precision pararb(npar) double precision partmp(npar) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision rmax double precision resrb(maxcofrb) double precision senrb(maxcofrb,maxcofrb) double precision tauflo(nparf) double precision tolnew double precision xc(np) double precision xrange double precision yc(np) double precision yrange ! ! Zero out the SENRB array. ! senrb(1:maxcofrb,1:maxcofrb) = 0.0D+00 ! ! JCOF counts the number of coefficients we will compute on ! each pass. We're done on the last pass. ! do jcof = 1, ncofrb jdif = jcof-1 if ( jdif == 0) then senrb(1:ncofrb,jcof) = grb(1:ncofrb) else write ( *, * ) ' ' write ( *, * ) 'Computing difference order JDIF = ',jdif ! ! Get the JCOF difference coefficients DIFCOF. ! call difset(difcof,dpar,iwrite,jcof) ! ! Evaluate the solution at JCOF values of the parameter. ! do icof = 1, jcof ! ! Copy the parameters, but reset the IPAR-th parameter value. ! partmp(1:npar) = par(1:npar) partmp(ipar) = par(ipar)+(2*icof-jcof-1)*dpar write ( *, * ) 'ICOF = ',ICOF,' PAR(IPAR)=',partmp(ipar) ! ! Estimate the solution GRBTMP at parameters PARTMP. ! grbtmp(1:ncofrb) = grb(1:ncofrb) ! ! Call NEWTRB to get the solution more closely. ! write ( *, * ) 'About to call NEWTRB' call newtrb(arb,area,grbtmp,grbarb,ierror,indx,ipivrb,iwrite, & maxcofrb,maxelm,maxnew,maxnfl,nbcrb,ncofrb,nelem,nferb,node,np, & npar,nparf,nx,ny,partmp,pararb,phirb,rb,resrb,rmax,tauflo,tolnew, & xc,xrange,yc,yrange) if ( ierror /= 0) then write ( *, * ) ' ' write ( *, * ) 'DIFSENRB - Fatal error!' write ( *, * ) ' NEWTRB failed, with IERROR = ',ierror stop end if ! ! Add the term associated with this solution to the estimate ! of the JDIF-th derivative. ! write ( *, * ) 'ABOUT TO ADD BLEEDING TERM' do j = 1, ncofrb senrb(j,jcof) = senrb(j,jcof)+difcof(icof)*grbtmp(j) end do end do end if end do return end subroutine flowbc(ifs,npar,nparf,par,region,splflo,tauflo,ubc,vbc, & xrange,xval,yrange,yval) !*****************************************************************************80 ! !! FLOWBC computes the specified boundary values at a given position. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IFS. ! IFS is the inflow shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! Input, integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, the ! shape of the bump, and the value of the Reynolds number. ! ! Input, integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! Input, double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! Input, character ( len = 20 ) REGION. ! REGION specifies the flow region. ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottom, with tangential velocity specifications ! there. ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! Workspace, double precision SPLFLO(NPARF). ! SPLFLO contains the spline coefficients for the inflow. ! ! Workspace, double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. There are NPARF of them, because the end ! values of the spline are constrained to have particular ! values. ! ! Output, double precision UBC. ! UBC is the value of the horizontal velocity specified ! at (XVAL,YVAL). ! ! Output, double precision VBC. ! VBC is the value of the vertical velocity specified at (XVAL,YVAL). ! ! Input, double precision XRANGE. ! XRANGE is the total width of the region. ! ! Input, double precision XVAL. ! XVAL is the X coordinate of the point on the inflow boundary at ! which the specified velocity is desired. ! ! Input, double precision YRANGE. ! YRANGE is the total width of the region. ! ! Input, double precision YVAL. ! YVAL is the Y coordinate of the point on the inflow boundary at ! which the specified velocity is desired. ! implicit none ! integer npar integer nparf ! integer i integer ifs logical s_eqi double precision par(npar) character ( len = 20 ) region double precision splflo(nparf) double precision tauflo(nparf) double precision ubc double precision vbc double precision xrange double precision xval double precision yrange double precision yval ! ! Inflow points for the cavity have the form (X,YRANGE). ! NPARF must be at least 1. ! if ( s_eqi ( region,'cavity')) then if ( nparf == 1) then tauflo(1) = xrange/2.0D+00 else do i = 1, nparf tauflo(i) = xrange*dble((i-1))/dble(nparf-1) end do end if splflo(1:nparf) = par(1:nparf) if ( ifs == 0) then call pcval(nparf,xval,tauflo,ubc,splflo) else if ( ifs == 1) then call plval(nparf,xval,tauflo,ubc,splflo) else if ( ifs == 2) then call pqval(nparf,xval,tauflo,ubc,splflo) else write ( *, * ) ' ' write ( *, * ) 'FlowBC - Fatal error!' write ( *, * ) ' Illegal value of IFS = ',ifs stop end if vbc = 0.0D+00 ! ! Inflow points for cavity2 have the form (X,0) or (X,YRANGE). ! NPARF must be at least 2. ! else if ( s_eqi ( region,'cavity2')) then if ( nparf == 2) then tauflo(1) = xrange/2.0D+00 else do i = 1, nparf/2 tauflo(i) = xrange*dble((i-1))/dble(nparf/2-1) end do end if if ( yval == 0.0D+00 ) then do i = 1, nparf/2 splflo(i) = par(i) end do else if ( yval == yrange ) then do i = 1, nparf/2 splflo(i) = par(i+nparf/2) end do end if if ( ifs == 0) then call pcval(nparf/2,xval,tauflo,ubc,splflo) else if ( ifs == 1) then call plval(nparf/2,xval,tauflo,ubc,splflo) else if ( ifs == 2) then call pqval(nparf/2,xval,tauflo,ubc,splflo) else write ( *, * ) ' ' write ( *, * ) 'FlowBC - Fatal error!' write ( *, * ) ' Illegal value of IFS = ',ifs stop end if vbc = 0.0D+00 ! ! Inflow points for the channel have the form (0,Y). ! ! NPARF must be at least 2, which specifies values at ! (0,0) and (0,YRANGE). ! else if ( s_eqi ( region,'channel')) then do i = 1, nparf tauflo(i) = yrange*dble((i-1))/dble(nparf-1) end do splflo(1:nparf) = par(1:nparf) if ( ifs == 0) then call pcval(nparf,yval,tauflo,ubc,splflo) else if ( ifs == 1) then call plval(nparf,yval,tauflo,ubc,splflo) else if ( ifs == 2) then call pqval(nparf,yval,tauflo,ubc,splflo) else write ( *, * ) ' ' write ( *, * ) 'FlowBC - Fatal error!' write ( *, * ) ' Illegal value of IFS = ',ifs stop end if vbc = 0.0D+00 ! ! Inflow points for the step have the coordinates (0,Y). ! ! NPARF must be at least 2, which specifies values at ! (0,0) and (0,YRANGE). ! else if ( s_eqi ( region,'step')) then do i = 1, nparf tauflo(i) = yrange*dble((i-1))/dble(nparf-1) end do splflo(1:nparf) = par(1:nparf) if ( ifs == 0) then call pcval(nparf,yval,tauflo,ubc,splflo) else if ( ifs == 1) then call plval(nparf,yval,tauflo,ubc,splflo) else if ( ifs == 2) then call pqval(nparf,yval,tauflo,ubc,splflo) else write ( *, * ) ' ' write ( *, * ) 'FlowBC - Fatal error!' write ( *, * ) ' Illegal value of IFS = ',ifs stop end if vbc = 0.0D+00 end if return end subroutine fpbcrb ( arb, indx, maxcofrb, maxnfl, nbcrb, ncofrb, & nelem, node, np, nx, ny, rb, xc, xrange, yc, yrange ) !*****************************************************************************80 ! !! FPBCRB evaluates the jacobian of the reduced boundary conditions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision ARB(MAXCOFRB,MAXCOFRB). ! ARB contains the Jacobian or Picard matrix for the reduced ! Navier Stokes system, stored as an NCOFRB by NCOFRB array. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! Integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! The local ordering of the nodes is suggested by this diagram: ! ! Global nodes Elements NODE ! 1 2 3 4 5 6 ! 74 84 94 3-6-1 2 Left element = (94,72,74,83,73,84) ! | / /| ! 73 83 93 5 4 4 5 Right element = (72,94,92,83,93,82) ! |/ / | ! 72 82 92 2 1-6-3 ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! The number of elements along a line in the X direction is ! NX-1 (or 2*(NX-1) to make a full rectangular strip). ! ! integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! The number of elements along a line in the Y direction is ! NY-1 (or 2*(NY-1) to make a full vertical strip). ! ! double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! RB is generated by computing a finite element solution GFL, ! which is saved for later reference as "GFLRB". ! GFLRB is copied into the first column of RB. ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! Now we compute the QR factorization of this matrix. ! We intend that NEQNFL >> NCOFRB, and RB is a matrix with orthogonal ! columns, so that: ! Transpose(RB) * RB = Identity(1+NCOFRB) ! If GFL is any set of finite element coefficients, the corresponding ! set of reduced basis coefficients can be computed as: ! GRB = Transpose(RB) * GFL ! If GRB is a set of reduced basis coefficients, a corresponding ! set of finite element coefficients can be computed as: ! GFL = RB * GRB. ! While it is the case that you can expand and then reduce, ! and always get the same result, it is not the case that ! when you reduce and then expand you get the same result! ! It is true, for ANY GRB, that ! GRB = Transpose(RB) * RB * GRB ! which follows from Transpose(RB) * RB = Identity(1+NCOFRB). ! However, for a general GFL, it is the case that ! GFL = /= RB * Transpose(RB) * GFL. ! Only if GFL was generated from a reduced basis coefficient ! vector will equality apply. In other words, if GFL was generated ! from a reduced basis coefficient: ! GFL = RB * GRB ! then ! RB * Transpose(RB) * GFL = RB * Transpose(RB) * (RB * GRB) ! = RB * GRB = GFL ! so in this strictly limited case, ! RB * Transpose(RB) = Identity(NEQNFL). ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer maxcofrb integer maxnfl integer ncofrb integer nelem integer np ! double precision arb(maxcofrb,maxcofrb) double precision dwdx double precision dwdy integer ibcrb integer icoffl integer icofrb integer icol integer ielem integer indx(3,np) integer inode integer iq integer nbcrb integer node(6,nelem) integer nx integer ny double precision rb(maxnfl,maxcofrb) double precision w double precision wurb double precision xbc double precision xc(np) double precision xrange double precision ybc double precision yc(np) double precision yrange ! ! Zero out the BC rows of the matrix. ! arb(1:nbcrb,1:ncofrb) = 0.0D+00 do ibcrb = 1, nbcrb ! ! For the driven cavity, the boundary collocation points are evenly ! spaced between the ends of the upper boundary. ! xbc = xrange * dble(ibcrb)/dble(nbcrb+1) ybc = yrange icol = 1 + int ( xbc * dble ( nx - 1 ) / xrange ) if ( nx - 1 < icol ) then icol = nx-1 end if ielem = icol*(2*ny-2)-1 ! ! Evaluate the reduced solution UBCRB at (XBC,YBC). ! do icofrb = 1, ncofrb wurb = 0.0D+00 do iq = 1, 6 call qbf(ielem,iq,w,dwdx,dwdy,nelem,node,np,xc,xbc,yc,ybc) inode = node(iq,ielem) icoffl = indx(1,inode) wurb = wurb+rb(icoffl,icofrb)*w end do arb(ibcrb,icofrb) = wurb end do end do return end subroutine fpferb ( arb, area, grb, maxcofrb, maxelm, nbcrb, ncofrb, & nelem, nferb, phirb, reynld ) !*****************************************************************************80 ! !! FPFERB evaluates the reduced basis jacobian directly. ! ! Discussion: ! ! FPFERB computes the reduced basis jacobian without computing the ! full basis jacobian first. ! ! FPFERB is given ! ! GRB, the reduced basis coefficients of an approximate solution, ! PHIRB, the reduced basis functions, evaluated at the quadrature ! points, ! REYNLD, the current Reynolds number, ! ! and computes ! ! ARB, the reduced basis jacobian of the Navier Stokes equations. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision ARB(MAXCOFRB,MAXCOFRB). ! ARB contains the Jacobian or Picard matrix for the reduced ! Navier Stokes system, stored as an NCOFRB by NCOFRB array. ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXELM. ! MAXELM is the maximum number of elements. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NFERB. ! NFERB is the number of reduced basis coefficients that will ! be determined via the finite element method. ! ! double precision PHIRB(3,MAXCOFRB,15,MAXELM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! double precision REYNLD. ! REYNLD is the current value of the Reynolds number. ! Normally, REYNLD is stored as PARA(NPARF+NPARB+1). ! implicit none ! integer maxcofrb integer maxelm integer ncofrb integer nelem ! double precision ar double precision arb(maxcofrb,maxcofrb) double precision area(3,maxelm) double precision dqjdx double precision dqjdy double precision dprbdx double precision dprbdy double precision durbdx double precision durbdy double precision dvrbdx double precision dvrbdy double precision dwu0dx double precision dwujdx double precision dwu0dy double precision dwujdy double precision dwv0dx double precision dwvjdx double precision dwv0dy double precision dwvjdy double precision grb(ncofrb) integer icofrb integer ielem integer iquad integer jcofrb logical s_eqi integer nbcrb integer nferb double precision prb double precision phirb(3,maxcofrb,15,maxelm) double precision reynld double precision urb double precision vrb double precision wu0 double precision wuj double precision wv0 double precision wvj ! ! Zero out the FE rows of the matrix. ! do icofrb = nbcrb+1, nbcrb+nferb arb(icofrb,1:ncofrb) = 0.0D+00 end do ! ! Consider an element IELEM... ! do ielem = 1, nelem ! ! ...and a quadrature point IQUAD... ! do iquad = 1, 3 ar = area(iquad,ielem) ! ! For the given reduced coefficients GRB, and basis functions ! PHIRB, evaluate U, V, and P, and their spatial derivatives. ! call uvpqrb(dprbdx,dprbdy,durbdx,durbdy,dvrbdx,dvrbdy,grb, & ielem,iquad,maxcofrb,maxelm,ncofrb,phirb,prb,urb,vrb) ! ! Consider FE reduced basis function ICOFRB. ! do icofrb = nbcrb+1, nbcrb+nferb wu0 = phirb(iquad,icofrb,10,ielem) dwu0dx = phirb(iquad,icofrb,11,ielem) dwu0dy = phirb(iquad,icofrb,12,ielem) wv0 = phirb(iquad,icofrb,13,ielem) dwv0dx = phirb(iquad,icofrb,14,ielem) dwv0dy = phirb(iquad,icofrb,15,ielem) ! ! Take the derivative with respect to basis function JCOFRB. ! do jcofrb = 1, ncofrb wuj = phirb(iquad,jcofrb,1,ielem) dwujdx = phirb(iquad,jcofrb,2,ielem) dwujdy = phirb(iquad,jcofrb,3,ielem) wvj = phirb(iquad,jcofrb,4,ielem) dwvjdx = phirb(iquad,jcofrb,5,ielem) dwvjdy = phirb(iquad,jcofrb,6,ielem) dqjdx = phirb(iquad,jcofrb,8,ielem) dqjdy = phirb(iquad,jcofrb,9,ielem) ! ! The horizontal momentum equations. ! arb(icofrb,jcofrb) = arb(icofrb,jcofrb)+ar* & (dwujdx*dwu0dx + dwujdy*dwu0dy+reynld & *(wuj*durbdx+urb*dwujdx+wvj*durbdy+vrb*dwujdy+dqjdx)*wu0) ! ! The vertical momentum equations. ! arb(icofrb,jcofrb) = arb(icofrb,jcofrb)+ar* & (dwvjdx*dwv0dx + dwvjdy*dwv0dy +reynld & *(wuj*dvrbdx+urb*dwvjdx+wvj*dvrbdy+vrb*dwvjdy+dqjdy)*wv0) end do end do end do end do return end subroutine fpfl ( afl, area, eqn, gfl, indx, ldafl, maxelm, nelem, neqnfl, & nlband, node, np, npar, par, phifl ) !*****************************************************************************80 ! !! FPFL computes the jacobian of the residual function of the full solution. ! ! Discussion: ! ! The differentiated Navier Stokes functions have the form: ! ! ! d U-Eqn/d U-Coef: ! ! Integral ! ! dWj/dx * dWi/dx + dWj/dy * dWi/dy ! + reynld * (Wj*dUold/dx + Uold*dWj/dx+ Vold*dWj/dy) * Wi dx dy ! ! d U-Eqn/d V-Coef: ! ! Integral ! ! reynld * Wj*dUold/dy * Wi dx dy ! ! d U-Eqn/d P-Coef: ! ! Integral ! ! reynld * dQj/dx * Wi dx dy ! ! d V-Eqn/d U-Coef: ! ! Integral ! ! reynld * Wj*dVold/dx * Wi dx dy ! ! d V-Eqn/d V-Coef: ! ! Integral ! ! dWj/dx * dWi/dx + dWj/dy * dWi/dy ! + reynld * (Uold*dWj/dx + Wj*dVold/dy + Vold*dWj/dy) * Wi dx dy ! ! d V-Eqn/d P-Coef: ! ! Integral ! ! reynld * dQj/dy * Wi dx dy ! ! d P-Eqn/d U-Coef: ! ! Integral ! ! dWj/dx * Qi dx dy ! ! d P-Eqn/d V-Coef: ! ! Integral ! ! dWj/dy * Qi dx dy ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision AFL(LDAFL,MAXNFL). ! If Newton iteration is being carried out, AFL contains the ! Jacobian matrix for the full system. ! If Picard iteration is being carried out, AFL contains the ! Picard matrix for the full system. ! ! AFL is stored in LINPACK general band storage mode, with ! logical dimensions (3*NLBAND+1, NEQNFL). ! ! Where is the (I,J) entry of AFL actually stored? ! AFL has actual storage for such an entry only if ! -NLBAND <= I-J <= NLBAND. ! In such a case, the (I,J) entry is actually stored in ! AFL(I-J+2*NLBAND+1,J) ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. ! ! 'U' A horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! ! 'V' A vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! ! 'P' A continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! integer LDAFL. ! LDAFL is the first dimension of the matrix AFL as declared in ! the main program. LDAFL must be at least 3*NLBAND+1. ! ! integer MAXELM. ! MAXELM is the maximum number of elements allowed. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NLBAND. ! NLBAND is the lower bandwidth of the matrix AFL. ! The zero structure of AFL is assumed to be symmetric, and so ! NLBAND is also the upper bandwidth of AFL. ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points (which are the element midside nodes). ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! implicit none ! integer ldafl integer maxelm integer nelem integer neqnfl integer np integer npar ! double precision afl(ldafl,neqnfl) double precision ar double precision area(3,maxelm) double precision dpdx double precision dpdy double precision dqjdx double precision dqjdy double precision dudx double precision dudy double precision dvdx double precision dvdy double precision dwidx double precision dwidy double precision dwjdx double precision dwjdy character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) integer i integer ielem integer ihor integer indx(3,np) integer ip integer iprs integer iq integer iquad integer iuse integer iver integer j integer jhor integer jp integer jprs integer jq integer jver logical s_eqi integer nlband integer node(6,nelem) double precision p double precision par(npar) double precision phifl(3,6,10,nelem) double precision qi double precision reynld double precision term double precision u double precision v double precision wi double precision wj ! reynld = par(npar) do i = 1, 3*nlband+1 afl(i,1:neqnfl) = 0.0D+00 end do ! ! Approximate the integral by summing over all elements. ! do ielem = 1, nelem ! ! Evaluate the integrand at the quadrature points. ! do iquad = 1, 3 ar = area(iquad,ielem) ! ! Evaluate U, V and P at the IQUAD-th quadrature point. ! call uvpqfl(dpdx,dpdy,dudx,dudy,dvdx,dvdy,gfl,ielem,indx, & iquad,nelem,neqnfl,node,np,p,phifl,u,v) ! ! Consider each node in the element. ! do iq = 1, 6 ip = node(iq,ielem) wi = phifl(iquad,iq,1,ielem) dwidx = phifl(iquad,iq,2,ielem) dwidy = phifl(iquad,iq,3,ielem) qi = phifl(iquad,iq,4,ielem) ihor = indx(1,ip) iver = indx(2,ip) iprs = indx(3,ip) ! ! Now compute the derivatives of the functions associated ! with U, V and P, with respect to the coefficients associated ! with basis vectors at each node of the element. ! do jq = 1, 6 jp = node(jq,ielem) wj = phifl(iquad,jq,1,ielem) dwjdx = phifl(iquad,jq,2,ielem) dwjdy = phifl(iquad,jq,3,ielem) dqjdx = phifl(iquad,jq,5,ielem) dqjdy = phifl(iquad,jq,6,ielem) jhor = indx(1,jp) jver = indx(2,jp) jprs = indx(3,jp) ! ! Contributions of the JHOR horizontal velocity to the U, V, and ! P equations. ! if ( s_eqi ( eqn(ihor),'U')) then term = ar*(dwjdx*dwidx+dwjdy*dwidy+ & reynld*(wj*dudx+u*dwjdx+v*dwjdy)*wi) iuse = ihor-jhor+2*nlband+1 afl(iuse,jhor) = afl(iuse,jhor)+term end if if ( s_eqi ( eqn(iver),'V')) then term = ar*(reynld*wj*dvdx*wi) iuse = iver-jhor+2*nlband+1 afl(iuse,jhor) = afl(iuse,jhor)+term end if if ( 0 < iprs ) then if ( s_eqi ( eqn(iprs),'P')) then term = ar*dwjdx*qi iuse = iprs-jhor+2*nlband+1 afl(iuse,jhor) = afl(iuse,jhor)+term end if end if ! ! Contributions of the JVER vertical velocity variable to the ! U, V and P equations. ! if ( s_eqi ( eqn(ihor),'U')) then term = ar*reynld*wj*dudy*wi iuse = ihor-jver+2*nlband+1 afl(iuse,jver) = afl(iuse,jver)+term end if if ( s_eqi ( eqn(iver),'V')) then term = ar*(dwjdx*dwidx+dwjdy*dwidy & +reynld*(u*dwjdx+wj*dvdy+v*dwjdy)*wi) iuse = iver-jver+2*nlband+1 afl(iuse,jver) = afl(iuse,jver)+term end if if ( 0 < iprs ) then if ( s_eqi ( eqn(iprs),'P')) then term = ar*dwjdy*qi iuse = iprs-jver+2*nlband+1 afl(iuse,jver) = afl(iuse,jver)+term end if end if ! ! Contributions of the JPRS pressure to the U and V equations. ! if ( 0 < jprs ) then if ( s_eqi ( eqn(ihor),'U')) then term = ar*reynld*dqjdx*wi iuse = ihor-jprs+2*nlband+1 afl(iuse,jprs) = afl(iuse,jprs)+term end if if ( s_eqi ( eqn(iver),'V')) then term = ar*reynld*dqjdy*wi iuse = iver-jprs+2*nlband+1 afl(iuse,jprs) = afl(iuse,jprs)+term end if end if end do end do end do end do ! ! Set up the equations that enforce boundary conditions. ! do ip = 1, np ihor = indx(1,ip) iver = indx(2,ip) iprs = indx(3,ip) if ( s_eqi ( eqn(ihor),'UB').or. s_eqi ( eqn(ihor),'UI').or. & s_eqi ( eqn(ihor),'UW').or. s_eqi ( eqn(ihor),'U0')) then afl(2*nlband+1,ihor) = 1.0D+00 end if if ( s_eqi ( eqn(iver),'VB').or.s_eqi ( eqn(iver),'VI').or. & s_eqi ( eqn(iver),'VW').or.s_eqi ( eqn(iver),'V0')) then afl(2*nlband+1,iver) = 1.0D+00 end if if ( 0 < iprs ) then if ( s_eqi ( eqn(iprs),'PB')) then afl(2*nlband+1,iprs) = 1.0D+00 else if ( s_eqi ( eqn(iprs),'P0')) then afl(2*nlband+1,iprs) = 1.0D+00 end if end if end do return end subroutine fpirb ( afl, arb, area, eqn, gflrb, grb, indx, ldafl, & maxcofrb, maxelm, maxnfl, nbcrb, ncofrb, nelem, neqnfl, nferb, & nlband, node, np, npar, nx, ny, par, phifl, rb, xc, xrange, yc, & yrange ) !*****************************************************************************80 ! !! FPIRB computes the reduced basis jacobian using the indirect method. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 05 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none integer ldafl integer maxcofrb integer maxelm integer maxnfl integer ncofrb integer nelem integer neqnfl integer np integer npar ! ! For some reason, I couldn't set AFL as a local array. ! double precision afl(ldafl,maxnfl) double precision arb(maxcofrb,maxcofrb) double precision area(3,nelem) character ( len = 2 ) eqn(neqnfl) double precision gflrb(neqnfl) ! ! FORTRAN 90 temporary array. ! double precision gfltmp(neqnfl) double precision grb(ncofrb) integer i integer ieqn integer indx(3,np) integer j integer jhi integer jlo integer k integer l logical s_eqi integer nbcrb integer nferb integer nlband integer node(6,nelem) integer nx integer ny double precision par(npar) double precision phifl(3,6,10,nelem) double precision rb(maxnfl,ncofrb) double precision xc(np) double precision xrange double precision yc(np) double precision yrange ! ! Zero out ARB. ! arb(1:ncofrb,1:ncofrb) = 0.0D+00 ! ! Get the partial derivative of the boundary conditions. ! call fpbcrb(arb,indx,maxcofrb,maxnfl,nbcrb,ncofrb, & nelem,node,np,nx,ny,rb,xc,xrange,yc,yrange) ! ! Recover the equivalent full basis coefficients GFLTMP from ! the reduced basis coefficients GRB. ! call grb2fl(gfltmp,gflrb,grb,maxnfl,ncofrb,neqnfl,rb) ! ! Get the jacobian FPFL for the full coefficient set. ! call fpfl(afl,area,eqn,gfltmp,indx,ldafl,maxelm,nelem,neqnfl, & nlband,node,np,npar,par,phifl) ! ! Zero out all rows except for U and V momentum equations. ! do i = 1, np ieqn = indx(1,i) if ( .not. s_eqi ( eqn(ieqn),'U')) then jlo = max(1,ieqn-nlband) jhi = min(neqnfl,ieqn+nlband) do j = jlo, jhi afl(ieqn-j+2*nlband+1,j) = 0.0D+00 end do end if ieqn = indx(2,i) if ( .not. s_eqi ( eqn(ieqn),'V')) then jlo = max(1,ieqn-nlband) jhi = min(neqnfl,ieqn+nlband) do j = jlo, jhi afl(ieqn-j+2*nlband+1,j) = 0.0D+00 end do end if ieqn = indx(3,i) if ( 0 < ieqn ) then jlo = max(1,ieqn-nlband) jhi = min(neqnfl,ieqn+nlband) do j = jlo, jhi afl(ieqn-j+2*nlband+1,j) = 0.0D+00 end do end if end do ! ! Compute the FE portion of the jacobian, ! FPRB = QT * FPFL * Q. ! do i = nbcrb+1,nbcrb+nferb do j = 1, neqnfl do k = 1, neqnfl do l = 1, ncofrb if ( -nlband <= j-k.and.j-k <= nlband) then arb(i,l) = arb(i,l)+rb(j,i)*afl(j-k+2*nlband+1,k)*rb(k,l) end if end do end do end do end do return end subroutine fprb(arb,area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,nx,ny,phirb,rb,reynld,xc,xrange,yc,yrange) !*****************************************************************************80 ! !! FPRB evaluates the reduced basis jacobian directly. ! ! Discussion: ! ! Direct evaluation means that the full basis jacobian is NOT computed. ! ! FPRB is given ! ! PAR, the current parameter values, ! GRB, the reduced basis coefficients of an approximate solution, ! PHIRB, the reduced basis functions, evaluated at the quadrature points, ! ! and computes ! ! ARB, the reduced basis jacobian of the Navier Stokes equations. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 11 July 1996. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision ARB(MAXNRB,MAXNRB). ! ARB contains the Jacobian matrix for the reduced basis system, ! stored as an NCOFRB by NCOFRB array. ! ! Input, double precision AREA(3,NELEM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! GRB Input, double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NCOFRB Input, integer NCOFRB. ! NCOFRB is the number of basis functions, reduced state equations and ! coefficients in the reduced basis system. ! ! PHIRB Input, double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! Input, double precision REYNLD. ! The current value of the Reynolds number parameter. ! implicit none ! integer maxcofrb integer maxelm integer maxnfl integer nelem integer ncofrb integer np ! double precision arb(maxcofrb,maxcofrb) double precision area(3,nelem) double precision grb(ncofrb) integer indx(3,np) integer nbcrb integer nferb integer node(6,nelem) integer nx integer ny double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision reynld double precision xc(np) double precision xrange double precision yc(np) double precision yrange call fpbcrb(arb,indx,maxcofrb,maxnfl,nbcrb,ncofrb, & nelem,node,np,nx,ny,rb,xc,xrange,yc,yrange) call fpferb(arb,area,grb,maxcofrb,maxelm,nbcrb,ncofrb, & nelem,nferb,phirb,reynld) return end subroutine fxbcrb(grb,indx,maxcofrb,maxnfl,nbcrb,ncofrb,nelem,node,np,npar, & nparf,nx,ny,par,rb,resrb,tauflo,xc,xrange,yc,yrange) !*****************************************************************************80 ! !! FXBCRB evaluates the reduced boundary conditions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 12 August 1996. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! ! The number of elements along a line in the X direction is ! NX-1 (or 2*(NX-1) to make a full rectangular strip). ! ! integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! ! The number of elements along a line in the Y direction is ! NY-1 (or 2*(NY-1) to make a full vertical strip). ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! RB is generated by computing a finite element solution GFL, ! which is saved for later reference as "GFLRB". ! GFLRB is copied into the first column of RB. ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! ! double precision RESRB(NCOFRB). ! RESRB contains the residual in the reduced basis equations, ! for the parameter values PAR and reduced basis coefficients GRB. ! ! double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. There are NPARF of them, because the end ! values of the spline are constrained to have particular ! values. ! ! double precision XC(NP). ! XC contains the X coordinates of the nodes. ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! implicit none ! integer maxcofrb integer maxnfl integer ncofrb integer nelem integer np integer npar integer nparf ! double precision dwdx double precision dwdy double precision grb(ncofrb) integer ibcrb integer icoffl integer icofrb integer icol integer ielem integer indx(3,np) integer inode integer iq integer nbcrb integer node(6,nelem) integer nx integer ny double precision par(npar) double precision rb(maxnfl,maxcofrb) double precision resrb(ncofrb) double precision tauflo(nparf) double precision ubcrb double precision w double precision wurb double precision xbc double precision xc(np) double precision xrange double precision ybc double precision yc(np) double precision yrange ! do ibcrb = 1, nbcrb ! ! These (X,Y) values are only valid for the driven cavity. ! You should pass REGION in here to sort it out. ! xbc = tauflo(ibcrb) ybc = yrange icol = 1+xbc*dble(nx-1)/xrange if ( nx - 1 < icol ) then icol = nx-1 end if ielem = icol*(2*ny-2)-1 ! ! Evaluate the reduced solution UBCRB at (XBC,YBC). ! ubcrb = 0.0D+00 do icofrb = 1, ncofrb wurb = 0.0D+00 do iq = 1, 6 call qbf(ielem,iq,w,dwdx,dwdy,nelem,node,np,xc,xbc,yc,ybc) inode = node(iq,ielem) icoffl = indx(1,inode) wurb = wurb+rb(icoffl,icofrb)*w end do ubcrb = ubcrb+grb(icofrb)*wurb end do ! ! Set the function value. ! resrb(ibcrb) = ubcrb-par(ibcrb) end do return end subroutine fxferb(area,grb,maxcofrb,maxelm,nbcrb,ncofrb,nelem, & nferb,phirb,resrb,reynld) !*****************************************************************************80 ! !! FXFERB evaluates the finite element portion of the reduced function. ! ! FXFERB is given ! GRB, the reduced basis coefficients of an approximate solution, ! PHIRB, the reduced basis functions, evaluated at the quadrature ! points, ! and computes ! RESRB, the reduced basis residual of the Navier Stokes ! equations. ! ! The reduced discretized Navier Stokes equations have the form: ! ! Integral ! ! dUrb/dx * dWu0/dx + dUrb/dy * dWu0dy ! + reynld * (Urb*dUrb/dx + Vrb*dUrb/dy + dPrb/dx) * Wu0 dx dy = 0 ! ! Integral ! ! dVrb/dx * dWv0/dx + dVrb/dy * dWv0/dy ! + reynld * (Urb*dVrb/dx + Vrb*dVrb/dy + dPrb/dy) * Wv0 dx dy = 0 ! ! Here, WU0 and WV0 are the reduced basis functions for U and V ! assuming homogeneous boundary conditions. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision AREA(3,NELEM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! GRB Input, double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NCOFRB Input, integer NCOFRB. ! NCOFRB is the number of basis functions, reduced state equations and ! coefficients in the reduced basis system. ! ! PHIRB double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! RESRB Output, double precision RESRB(NCOFRB). ! RESRB contains the residual in the reduced basis equations, ! for the given parameter values and reduced basis coefficients GRB. ! ! Input, double precision REYNLD. ! The current value of the Reynolds number parameter. ! implicit none ! integer maxcofrb integer maxelm integer nelem integer ncofrb ! double precision ar double precision area(3,nelem) double precision dpdx double precision dpdy double precision dudx double precision dudy double precision dvdx double precision dvdy double precision dwu0dx double precision dwu0dy double precision dwv0dx double precision dwv0dy double precision grb(ncofrb) integer icofrb integer ielem integer iquad logical s_eqi integer nbcrb integer nferb double precision p double precision phirb(3,maxcofrb,15,maxelm) double precision resrb(ncofrb) double precision reynld double precision u double precision v double precision wu0 double precision wv0 ! do icofrb = nbcrb+1, nbcrb+nferb resrb(icofrb) = 0.0D+00 end do ! ! Consider an element IELEM... ! do ielem = 1, nelem ! ! ...and a quadrature point IQUAD... ! do iquad = 1, 3 ar = area(iquad,ielem) ! ! For the given reduced coefficients GRB, and basis functions ! PHIRB, evaluate U, V, and P, and their spatial derivatives. ! call uvpqrb(dpdx,dpdy,dudx,dudy,dvdx,dvdy,grb, & ielem,iquad,maxcofrb,maxelm,ncofrb,phirb,p,u,v) ! ! Now consider the residual associated with each finite element ! reduced basis function. ! do icofrb = nbcrb+1, nbcrb+nferb wu0 = phirb(iquad,icofrb,10,ielem) dwu0dx = phirb(iquad,icofrb,11,ielem) dwu0dy = phirb(iquad,icofrb,12,ielem) wv0 = phirb(iquad,icofrb,13,ielem) dwv0dx = phirb(iquad,icofrb,14,ielem) dwv0dy = phirb(iquad,icofrb,15,ielem) resrb(icofrb) = resrb(icofrb)+ar* & (dudx*dwu0dx+dudy*dwu0dy & +reynld*(u*dudx+v*dudy+dpdx)*wu0 & +dvdx*dwv0dx+dvdy*dwv0dy & +reynld*(u*dvdx+v*dvdy+dpdy)*wv0) end do end do end do return end subroutine fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar,nparf,par, & phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) !*****************************************************************************80 ! !! FXFL computes the residual of the full Navier Stokes equations. ! ! The discretized Navier Stokes equations have the form: ! ! Integral ! ! dU/dx * dW/dx + dU/dy * dW/dy ! + reynld * (U*dU/dx + V*dU/dy + dP/dx) * W dx dy = 0 ! ! Integral ! ! dV/dx * dW/dx + dV/dy * dW/dy ! + reynld * (U*dV/dx + V*dV/dy + dP/dy) * W dx dy = 0 ! ! Integral ! ! (dU/dx + dV/dy) * Q dx dy = 0 ! ! Here W is a basis function for U and V, and Q is a basis ! function for P. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 August 1996. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. ! ! 'U' A horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! ! 'V' A vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! ! 'P' A continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! integer IFS. ! IFS is the inflow shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! Global nodes Elements NODE ! 1 2 3 4 5 6 ! 74 84 94 3-6-1 2 Left element = (94,72,74,83,73,84) ! | / /| ! 73 83 93 5 4 4 5 Right element = (72,94,92,83,93,82) ! |/ / | ! 72 82 92 2 1-6-3 ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points (which are the element midside nodes). ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! character ( len = 20 ) REGION. ! REGION specifies the flow region. ! ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottome, with tangential velocity specifications ! there. ! ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! double precision RESFL(NEQNFL). ! RESFL contains the residual in the full basis equations. ! ! double precision SPLFLO(NPARF). ! SPLFLO contains the spline coefficients for the inflow. ! ! double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. There are NPARF of them, because the end ! values of the spline are constrained to have particular ! values. ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer nelem integer neqnfl integer np integer npar integer nparf ! double precision ar double precision area(3,nelem) double precision dpdx double precision dpdy double precision dudx double precision dudy double precision dvdx double precision dvdy double precision dwidx double precision dwidy character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) integer i integer ifs integer ielem integer ihor integer indx(3,np) integer ip integer iprs integer iq integer iquad integer iver integer node(6,nelem) double precision p double precision par(npar) double precision phifl(3,6,10,nelem) double precision qi character ( len = 20 ) region double precision resfl(neqnfl) double precision reynld logical s_eqi double precision splflo(nparf) double precision tauflo(nparf) double precision u double precision ubc double precision v double precision vbc double precision wi double precision xrange double precision xval double precision yc(np) double precision yrange double precision yval ! reynld = par(npar) resfl(1:neqnfl) = 0.0D+00 ! ! Consider an element. ! do ielem = 1, nelem ! ! Evaluate the integrand at the quadrature points. ! do iquad = 1, 3 ar = area(iquad,ielem) ! ! Evaluate U, V and P at the IQUAD-th quadrature point. ! call uvpqfl(dpdx,dpdy,dudx,dudy,dvdx,dvdy,gfl,ielem,indx, & iquad,nelem,neqnfl,node,np,p,phifl,u,v) ! ! Look at nearby basis functions. ! do iq = 1, 6 ip = node(iq,ielem) wi = phifl(iquad,iq,1,ielem) dwidx = phifl(iquad,iq,2,ielem) dwidy = phifl(iquad,iq,3,ielem) qi = phifl(iquad,iq,4,ielem) ! ! The horizontal velocity equations. ! ihor = indx(1,ip) if ( s_eqi ( eqn(ihor),'U')) then resfl(ihor) = resfl(ihor)+ar*(dudx*dwidx + dudy*dwidy & +reynld*(u*dudx+v*dudy+dpdx)*wi ) else if ( s_eqi ( eqn(ihor),'UB')) then resfl(ihor) = gfl(ihor) else if ( s_eqi ( eqn(ihor),'UI')) then yval = yc(ip) call flowbc(ifs,npar,nparf,par,region,splflo,tauflo, & ubc,vbc,xrange,xval,yrange,yval) resfl(ihor) = gfl(ihor)-ubc else if ( s_eqi ( eqn(ihor),'UW')) then resfl(ihor) = gfl(ihor) else if ( s_eqi ( eqn(ihor),'U0')) then resfl(ihor) = gfl(ihor) end if ! ! The vertical velocity equations. ! iver = indx(2,ip) if ( s_eqi ( eqn(iver),'V')) then resfl(iver) = resfl(iver)+ar*(dvdx*dwidx + dvdy*dwidy & +reynld*(u*dvdx+v*dvdy+dpdy)*wi ) else if ( s_eqi ( eqn(iver),'VB')) then resfl(iver) = gfl(iver) else if ( s_eqi ( eqn(iver),'VI')) then yval = yc(ip) call flowbc(ifs,npar,nparf,par,region,splflo,tauflo, & ubc,vbc,xrange,xval,yrange,yval) resfl(iver) = gfl(iver)-vbc else if ( s_eqi ( eqn(iver),'VW')) then resfl(iver) = gfl(iver) else if ( s_eqi ( eqn(iver),'V0')) then resfl(iver) = gfl(iver) end if ! ! The pressure equations. ! iprs = indx(3,ip) if ( 0 < iprs ) then if ( s_eqi ( eqn(iprs),'P')) then resfl(iprs) = resfl(iprs)+ar*(dudx+dvdy)*qi else if ( s_eqi ( eqn(iprs),'PB')) then resfl(iprs) = gfl(iprs) else if ( s_eqi ( eqn(iprs),'P0')) then resfl(iprs) = gfl(iprs) end if end if end do end do end do return end subroutine fxfl2rb(grb,indx,maxcofrb,maxnfl,nbcrb,ncofrb,nelem, & neqnfl,nferb,node,np,npar,nparf,nx,ny,par,rb,resfl,resrb, & tauflo,xc,xrange,yc,yrange) !*****************************************************************************80 ! !! FXFL2RB projects a full residual into a reduced residual. ! ! Discussion: ! ! The relationship used is ! ! RESRB = Q^T * RESFL. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 12 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision RESFL(NEQNFL), the function value ! in the full system. ! ! Output, double precision RESRB(NCOFRB), the function value ! in the reduced system. ! ! Input, integer MAXNFL, the maximum value of NEQNFL, used as ! the leading dimension of RB. ! ! Input, integer NCOFRB, the number of coefficients for the ! reduced system. ! ! Input, integer NEQNFL, the number of coefficients for the ! full system. ! ! Input, double precision rb(maxnfl,ncofrb). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! implicit none ! integer maxcofrb integer maxnfl integer ncofrb integer nelem integer neqnfl integer np integer npar integer nparf ! double precision grb(ncofrb) integer i integer indx(3,np) integer j integer nbcrb integer nferb integer node(6,nelem) integer nx integer ny double precision par(npar) double precision rb(maxnfl,ncofrb) double precision resfl(neqnfl) double precision resrb(ncofrb) double precision tauflo(nparf) double precision xc(np) double precision xrange double precision yc(np) double precision yrange ! ! Compute the boundary conditions directly from GFLBC. ! call fxbcrb(grb,indx,maxcofrb,maxnfl,nbcrb,ncofrb,nelem, & node,np,npar,nparf,nx,ny,par,rb,resrb,tauflo,xc,xrange,yc,yrange) ! ! Multiply the second half of the vector RESFL by the second half of ! RB transpose. ! do i = nbcrb+1, nbcrb+nferb resrb(i) = 0.0D+00 do j = 1, neqnfl resrb(i) = resrb(i) + rb(j,i) * resfl(j) end do end do return end subroutine fxirb ( area, eqn, gflrb, grb, ifs, indx, maxcofrb, maxnfl, & nbcrb, ncofrb, nelem, neqnfl, nferb, node, np, npar, nparf, nx, ny, & par, phifl, rb, region, resrb, splflo, tauflo, xc, xrange, yc, & yrange ) !*********************************************************************** ! !! FXIRB indirectly computes the reduced basis residual. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 04 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision AREA(3,NELEM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! EQN Input, character ( len = 2 ) EQN(NEQNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. Note that most boundary ! conditions do not result in an equation. The current values are: ! ! 'U' The horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! ! 'V' The vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! ! 'P' The continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! ! GFL Input/output, double precision GFL(NEQNFL). ! ! GFL must contain on input the coefficients ! for the full basis system that are equivalent to GRB. ! ! GFLRB Input, double precision GFLRB(NEQNFL), the full basis coefficients ! of the solution at which the reduced basis was generated. ! ! GRB Input, double precision GRB(NCOFRB). ! The coefficients for the reduced basis system. ! ! IFS Input, integer IFS. ! 1, the inflow is modeled by C0 linear splines. ! 2, the inflow is modeled by C0 quadratic splines. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! MAXNFL Input, integer MAXNFL, the maximum number of equations in the ! full system. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NEQNFL Input, integer NEQNFL, the number of equations in the full system. ! ! NCOFRB Input, integer NCOFRB, the number of equations in the reduced ! system. ! ! NODE Input, integer NODE(6,MAXELM). ! ! NODE(I,J) contains, for an element J, the global node index of ! the element node whose local number is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! 2 ! /| ! 4 5 ! / | ! 1-6-3 ! ! NP Input, integer NP, the number of nodes used to define the finite ! element mesh. NP = (2*NX-1)*(2*NY-1). ! ! NPAR Input, integer NPAR. ! ! The number of parameters. NPAR = NPARF + NPARB + 1. ! ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! NPARB Input, integer NPARB. ! ! The number of parameters associated with the position and ! shape of the bump. ! ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPARF Input, integer NPARF. ! ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! PAR Input, double precision PAR(NPAR). ! ! PAR is the current estimate for the parameters. ! ! PHIFL Input, double precision PHIFL(3,6,10,NELEM). ! ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points. ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! Input, double precision RB(MAXNFL,NCOFRB), the columns of RB ! contain the orthonormal reduced basis vectors. ! ! Input, character ( len = 20 ) REGION. ! REGION specifies the flow region. ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottome, with tangential velocity specifications ! there. ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! Output, double precision RESFL(NEQNFL), the residual in the ! full basis equations. ! ! Output, double precision RESRB(NCOFRB), the residual in the ! reduced basis equations, evaluated at the coefficient ! vector GRB. ! ! Input, double precision SPLFLO(NPARF). ! SPLFLO contains the spline coefficients for the inflow. ! ! Input, double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. There are NPARF of them, because the end ! values of the spline are constrained to have particular ! values. ! ! Input, double precision XC(NP). ! The X coordinates of the nodes. ! ! Input, double precision YC(NP). ! The Y coordinates of the nodes. ! implicit none ! integer maxcofrb integer maxnfl integer ncofrb integer nelem integer neqnfl integer np integer npar integer nparf ! double precision area(3,nelem) character ( len = 2 ) eqn(neqnfl) double precision gflrb(neqnfl) double precision gfltmp(neqnfl) double precision grb(ncofrb) integer i integer ieqn integer ifs integer indx(3,np) logical s_eqi integer nbcrb integer nferb integer node(6,nelem) integer nx integer ny double precision par(npar) double precision phifl(3,6,10,nelem) double precision rb(maxnfl,ncofrb) character ( len = 20 ) region double precision resfltmp(neqnfl) double precision resrb(ncofrb) double precision splflo(nparf) double precision tauflo(nparf) double precision xc(np) double precision xrange double precision yc(np) double precision yrange ! ! Recover the equivalent full basis coefficients GFLTMP from ! the reduced basis coefficients GRB. ! call grb2fl ( gfltmp, gflrb, grb, maxnfl, ncofrb, neqnfl, rb ) ! ! Evaluate the residual RESFLTMP at GFLTMP. ! call fxfl(area,eqn,gfltmp,ifs,indx,nelem,neqnfl,node,np,npar, & nparf,par,phifl,region,resfltmp,splflo,tauflo,xrange,yc,yrange) ! ! Zero out all residuals except for U and V momentum equations. ! do i = 1, np ieqn = indx(1,i) if ( .not. s_eqi ( eqn(ieqn), 'U') ) then resfltmp(ieqn) = 0.0D+00 end if ieqn = indx(2,i) if ( .not. s_eqi ( eqn(ieqn), 'V' ) ) then resfltmp(ieqn) = 0.0D+00 end if ieqn = indx(3,i) if ( 0 < ieqn ) then resfltmp(ieqn) = 0.0D+00 end if end do ! ! Project the residual RESFLTMP back into the reduced space, ! arriving at RESRB. ! call fxfl2rb(grb,indx,maxcofrb,maxnfl,nbcrb,ncofrb,nelem, & neqnfl,nferb,node,np,npar,nparf,nx,ny,par,rb,resfltmp,resrb, & tauflo,xc,xrange,yc,yrange) return end subroutine fxrb(area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb,resrb,reynld, & tauflo,xc,xrange,yc,yrange) !*****************************************************************************80 ! !! FXRB evaluates the reduced boundary and finite element equations. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! AREA Input, double precision AREA(3,NELEM). ! ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! ! or, if the element is isoperimetric, ! ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! ! Here Ar(IELEM) represents the area of element IELEM. ! ! GFLBC double precision GFLBC(NEQNFL). ! GFLBC contains the current full solution, or, in fact, ! ANY full solution, which satisfies the boundary conditions. ! ! GRB double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! INDX integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! MAXCOFRB ! Integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! MAXNFL integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! NBCRB integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! NCOFRB integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! NELEM integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! NEQNFL integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! NODE integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! Global nodes Elements NODE ! 1 2 3 4 5 6 ! 74 84 94 3-6-1 2 Left element = (94,72,74,83,73,84) ! | / /| ! 73 83 93 5 4 4 5 Right element = (72,94,92,83,93,82) ! |/ / | ! 72 82 92 2 1-6-3 ! ! NP integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! NX integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! ! The number of elements along a line in the X direction is ! NX-1 (or 2*(NX-1) to make a full rectangular strip). ! ! NY integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! ! The number of elements along a line in the Y direction is ! NY-1 (or 2*(NY-1) to make a full vertical strip). ! ! PHIRB double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! RB double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! RB is generated by computing a finite element solution GFL, ! which is saved for later reference as "GFLRB". ! GFLRB is copied into the first column of RB. ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! Now we compute the QR factorization of this matrix. ! We intend that NEQNFL >> NCOFRB, and RB is a matrix with orthogonal ! columns, so that: ! Transpose(RB) * RB = Identity(1+NCOFRB) ! If GFL is any set of finite element coefficients, the corresponding ! set of reduced basis coefficients can be computed as: ! GRB = Transpose(RB) * GFL ! If GRB is a set of reduced basis coefficients, a corresponding ! set of finite element coefficients can be computed as: ! GFL = RB * GRB. ! While it is the case that you can expand and then reduce, ! and always get the same result, it is not the case that ! when you reduce and then expand you get the same result! ! It is true, for ANY GRB, that ! GRB = Transpose(RB) * RB * GRB ! which follows from Transpose(RB) * RB = Identity(1+NCOFRB). ! However, for a general GFL, it is the case that ! GFL = /= RB * Transpose(RB) * GFL. ! Only if GFL was generated from a reduced basis coefficient ! vector will equality apply. In other words, if GFL was generated ! from a reduced basis coefficient: ! GFL = RB * GRB ! ! then ! ! RB * Transpose(RB) * GFL = RB * Transpose(RB) * (RB * GRB) ! = RB * GRB = GFL ! ! so in this strictly limited case, ! ! RB * Transpose(RB) = Identity(NEQNFL). ! ! double precision RESRB(NCOFRB). ! RESRB contains the residual in the reduced basis equations, ! for the parameter values PAR and reduced basis coefficients GRB. ! ! Input, double precision REYNLD. ! The current value of the Reynolds number parameter. ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer maxcofrb integer maxelm integer maxnfl integer ncofrb integer nelem integer np integer npar integer nparf ! double precision area(3,nelem) double precision grb(ncofrb) integer indx(3,np) integer nbcrb integer nferb integer node(6,nelem) integer nx integer ny double precision par(npar) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision resrb(ncofrb) double precision reynld double precision tauflo(nparf) double precision xc(np) double precision xrange double precision yc(np) double precision yrange ! call fxbcrb(grb,indx,maxcofrb,maxnfl,nbcrb,ncofrb,nelem, & node,np,npar,nparf,nx,ny,par,rb,resrb,tauflo,xc,xrange,yc,yrange) call fxferb(area,grb,maxcofrb,maxelm,nbcrb,ncofrb,nelem, & nferb,phirb,resrb,reynld) return end subroutine getgsen ( grb, gsen, icolrb, maxcofrb, nbcrb, ncofrb, & nsenfl, rbase ) !*****************************************************************************80 ! !! GETGSEN computes the coefficients of the sensitivity matrix S. ! ! Discussion: ! ! The routine uses the fact that ! S = Q*R ! ! Given GRB, the routine also computes the coefficients of Q. ! ! The calculation is simply ! GSEN = R^(-1) * GRB ! where R is a square upper triangular matrix. ! ! The calculation is slightly more complicated than this, since ! we may have dropped some columns of Q (and hence rows and ! columns of R. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! double precision GSEN(NBCRB+NCOFRB). ! GSEN contains the "sensitivity coefficients". These are simply ! the reduced basis coefficients GRB after multiplication by ! the inverse of RBASE, and accounting for the fact that only ! some columns of the original set of candidate basis vectors ! were used. ! ! integer ICOLRB(MAXCOFRB). ! ICOLRB records which columns of the initial collection of ! candidate basis vectors were actually chosen to form the ! reduced basis. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NSENFL. ! NSENFL is the number of full solution sensitivities to compute, ! counting the 0-th order sensitivity as the first one. ! ! double precision RBASE(MAXCOFRB,MAXCOFRB). ! RBASE is the R factor in the QR factorization of the ! reduced basis matrix. ! In the special case where the reduced basis matrix is ! exactly equal to SENFL, then RBASE equals SENRB. ! implicit none ! integer maxcofrb integer nbcrb integer ncofrb integer nsenfl ! double precision grb(ncofrb) double precision gsen(nbcrb+nsenfl) integer i integer icol integer icolrb(ncofrb) integer j double precision rbase(maxcofrb,maxcofrb) ! gsen(1:nbcrb+nsenfl) = 0.0D+00 do i = ncofrb, 1, -1 icol = icolrb(i) gsen(icol) = grb(i) do j = i+1, ncofrb gsen(icol) = gsen(icol)-rbase(i,j)*gsen(j) end do gsen(icol) = gsen(icol)/rbase(i,i) end do return end subroutine getbcrb ( gflrb, maxcofrb, maxnfl, nbcrb, neqnfl, rb ) !*****************************************************************************80 ! !! GETBCRB computes the vectors that will be placed into the set ! of reduced basis vectors RB, in cases where the boundary conditions ! depend on the parameters. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 15 September 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer maxcofrb integer maxnfl integer neqnfl ! double precision gflrb(neqnfl) integer i integer j integer nbcrb double precision rb(maxnfl,maxcofrb) ! do j = 1, nbcrb ! ! Set the I-th boundary condition vector. ! RIGHT NOW THESE ARE FAKE EQUATIONS. ! rb(1:neqnfl,1) = gflrb(1:neqnfl) end do return end subroutine getferb(icolrb,maxcofrb,maxnfl,nbcrb,ncofrb,neqnfl, & nferb,nsenfl,rb,rbase,senfl,senrb) !*****************************************************************************80 ! !! GETFERB computes the finite element reduced basis vectors for RB. ! ! Discussion: ! ! These vectors finish up the matrix RB. ! The routine then orthogonalizes RB. ! ! The routine is given: ! NCOFRB, the number of reduced basis vectors; ! SENFL, the full solution sensitivities of orders 1 through NCOFRB, ! and computes ! RB, an NEQNFL by NCOFRB orthogonal matrix, whose columns ! were initially SENFL(0), SENFL(1), ..., SENFL(NCOFRB), and which ! is essentially the "Q" factor of this matrix, ! RBASE, the "R" factor in the QR factorization of the matrix. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 17 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! integer ICOLRB(MAXCOFRB). ! ICOLRB records which columns of the initial collection of ! candidate basis vectors were actually chosen to form the ! reduced basis. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NFERB. ! NFERB is the number of reduced basis coefficients that will ! be determined via the finite element method. ! ! integer NSENFL. ! NSENFL is the number of full solution sensitivities to compute, ! counting the 0-th order sensitivity as the first one. ! ! double precision RB(MAXNFL,MAXCOFRB). ! ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! ! RB is generated by computing a finite element solution GFL, ! which is saved for later reference as "GFLRB". ! GFLRB is copied into the first column of RB. ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! ! double precision RBASE(MAXCOFRB,MAXCOFRB). ! RBASE is the R factor in the QR factorization of the ! reduced basis matrix. ! ! In the special case where the reduced basis matrix is ! exactly equal to SENFL, then RBASE equals SENRB. ! ! double precision SENFL(MAXNFL,MAXCOFRB). ! Columns 1 through NSENFL of SENFL contain the sensitivities ! of the full solution with respect to the REYNLD parameter, for ! orders 0 through NSENFL-1. ! ! SENFL(I,J) contains the (J-1)-th sensitivity of the I-th full unknown ! with respect to REYNLD. ! ! double precision SENRB(MAXCOFRB,NSENFL). ! SENRB contains the first NSENFL order sensitivities of the ! reduced solution with respect to the REYNLD parameter. ! ! SENRB(I,J) contains the (J-1)-th sensitivity of the I-th reduced ! unknown with respect to REYNLD. ! ! SENRB is computed by premultiplying SENFL by Transpose(RB). ! SENRB = Transpose(RB) * SENFL. ! implicit none ! integer maxcofrb integer maxnfl integer neqnfl integer ncofrb ! double precision ddot double precision dnrm2 double precision dtemp double precision dtemp1 integer i integer icolrb(maxcofrb) integer isen integer j integer jhi integer k integer mbcrb integer nbcrb integer nferb integer nsenfl double precision rb(maxnfl,maxcofrb) double precision rbase(maxcofrb,maxcofrb) double precision senfl(maxnfl,maxcofrb) double precision senrb(maxcofrb,maxcofrb) ! ! Copy the sensitivities SENFL(:,:) into RB(:,NBCRB+1:). ! do i = 1, neqnfl do isen = 1, nsenfl rb(i,nbcrb+isen) = senfl(i,isen) end do end do ! ! Initialize the R factor. ! do i = 1, nbcrb+nsenfl do j = 1, nbcrb+nsenfl if ( i == j) then rbase(i,j) = 1.0D+00 else rbase(i,j) = 0.0D+00 end if end do end do ! ! Do a cheap sort of Gram Schmidt process to eliminate sensitivity ! columns that are dependent on the boundary conditions or earlier ! sensitivities. ! mbcrb = nbcrb jhi = nbcrb+nsenfl ncofrb = 0 nbcrb = 0 nferb = 0 do j = 1, jhi ! ! For each column of the initial RB matrix, ! ! ...get the Euclidean norm of the column... ! dtemp1 = dnrm2(neqnfl,rb(1,j),1) ! ! ...and then subtract off the projections onto the ! already accepted columns... ! do i = 1, ncofrb dtemp = ddot(neqnfl,rb(1,i),1,rb(1,j),1) rbase(i,ncofrb+1) = dtemp call daxpy(neqnfl,-dtemp,rb(1,i),1,rb(1,j),1) end do ! ! ...then get the Euclidean norm of what is left, ! save it in RBASE, and normalize the column. ! dtemp = dnrm2(neqnfl,rb(1,j),1) rbase(ncofrb+1,ncofrb+1) = dtemp do i = 1, neqnfl rb(i,ncofrb+1) = rb(i,j)/dtemp end do ! ! Now decide whether to accept this column. ! if ( dtemp /= 0.0D+00 .and. 0.00001D+00 * dtemp1 < dtemp ) then ncofrb = ncofrb+1 if ( j <= mbcrb) then nbcrb = nbcrb+1 else nferb = nferb+1 end if icolrb(ncofrb) = j end if end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETRB - Information:' write ( *, '(a,i6)' ) ' # of BC vectors, NBCRB = ',nbcrb write ( *, '(a,i6)' ) ' # of FE vectors, NFERB = ',nferb write ( *, '(a,i6)' ) ' # of RB coeffs, NCOFRB = ',ncofrb ! ! Compute SENRB as Transpose(Q) * SENFL. ! NSENFL may, or may not, equal NCOFRB. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETRB - Note:' write ( *, '(a)' ) ' Automatically computing SENRB.' do i = 1, ncofrb do j = 1, nsenfl senrb(i,j) = 0.0D+00 do k = 1, ncofrb senrb(i,j) = senrb(i,j)+rb(k,i)*senfl(k,j) end do end do end do return end subroutine getsenfl(afl,area,eqn,gfl,indx,ipivfl,ldafl,maxcofrb,maxnfl, & nelem,neqnfl,nlband,node,np,npar,nsenfl,par,phifl,resfl,senfl) !*****************************************************************************80 ! !! GETSENFL computes the matrix SENFL of sensitivity vectors. ! ! Discussion: ! ! The routine first saves a copy of GFL, the current solution. ! ! Then it constructs a matrix SENFL, whose first column is d GFL/d REYNLD, ! which must be computed by solving a linear system. ! ! Similarly, higher derivatives of GFL with respect to REYNLD are computed ! and stored in successive columns of SENFL. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 22 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision AFL(LDAFL,MAXNFL). ! If Newton iteration is being carried out, AFL contains the ! Jacobian matrix for the full system. ! If Picard iteration is being carried out, AFL contains the ! Picard matrix for the full system. ! ! AFL is stored in LINPACK general band storage mode, with ! logical dimensions (3*NLBAND+1, NEQNFL). ! ! Where is the (I,J) entry of AFL actually stored? ! AFL has actual storage for such an entry only if ! -NLBAND <= I-J <= NLBAND. ! In such a case, the (I,J) entry is actually stored in ! AFL(I-J+2*NLBAND+1,J) ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! ! or, if the element is isoperimetric, ! ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! ! Here Ar(IELEM) represents the area of element IELEM. ! ! character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. ! ! 'U' A horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! ! 'V' A vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! ! 'P' A continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! Workspace, integer IPIVFL(NEQNFL). ! IPIVFL is a pivot vector for the solution of the full ! linear system. ! ! integer LDAFL. ! LDAFL is the first dimension of the matrix AFL as declared in ! the main program. LDAFL must be at least 3*NLBAND+1. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NLBAND. ! NLBAND is the lower bandwidth of the matrix AFL. ! The zero structure of AFL is assumed to be symmetric, and so ! NLBAND is also the upper bandwidth of AFL. ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NSENFL. ! NSENFL is the number of full solution sensitivities to compute, ! counting the 0-th order sensitivity as the first one. ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points (which are the element midside nodes). ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! double precision RESFL(NEQNFL). ! RESFL contains the residual in the full basis equations. ! ! double precision SENFL(MAXNFL,MAXCOFRB). ! Columns 1 through NSENFL of SENFL contain the sensitivities ! of the full solution with respect to the REYNLD parameter, for ! orders 0 through NSENFL-1. ! ! SENFL(I,J) contains the (J-1)-th sensitivity of the I-th full unknown ! with respect to REYNLD. ! implicit none ! integer ldafl integer maxcofrb integer maxnfl integer nelem integer neqnfl integer np integer npar ! double precision afl(ldafl,maxnfl) double precision area(3,nelem) character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) integer i integer indx(3,np) integer ipivfl(maxnfl) integer isen integer nlband integer node(6,nelem) integer nsenfl double precision par(npar) double precision phifl(3,6,10,nelem) double precision resfl(neqnfl) double precision reynld double precision rpnrm double precision ruvnrm double precision senfl(maxnfl,maxcofrb) double precision spnrm double precision suvnrm ! reynld = par(npar) ! ! Compute, one at a time, the columns of the RB matrix. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GETSENFL - Information:' write ( *, * ) ' Number of sensitivities requested, NSENFL = ',nsenfl write ( *, '(a)' ) ' ' write ( *, '(a)' ) & 'Order MxNorm(UVRHS) MxNorm(PRHS) MxNorm(UVSen) MxNorm(PSen)' senfl(1:neqnfl,1) = gfl(1:neqnfl) isen = 0 call uvpnrm(senfl(1,1),indx,neqnfl,np,spnrm,suvnrm) write(*,'(1x,i6,28x,2g14.6)')isen,suvnrm,spnrm do isen = 1, nsenfl-1 ! ! Given the current solution and lower order sensitivities ! in SENFL, compute in RESFL the right hand side for sensitivity ! of order ISEN. ! call reysen(area,eqn,indx,isen,maxcofrb,maxnfl,nelem, & neqnfl,node,np,phifl,resfl,reynld,senfl) ! ! Compute the norm of this right hand side. ! call uvpnrm(resfl,indx,neqnfl,np,rpnrm,ruvnrm) ! ! Solve the linear system AFL * SENFL(ISEN) = RESFL ! call dsolfl(afl,ldafl,neqnfl,nlband,nlband,ipivfl,resfl) ! ! Get the norm of this new sensitivity. ! call uvpnrm(resfl,indx,neqnfl,np,spnrm,suvnrm) write(*,'(1x,i6,4g14.6)')isen,ruvnrm,rpnrm,suvnrm,spnrm ! ! Copy the new sensitivity into the SENFL array. ! senfl(1:neqnfl,isen+1) = resfl(1:neqnfl) end do return end subroutine getsenrb(maxcofrb,maxnfl,ncofrb,neqnfl,nsenfl,rb,senfl,senrb) !*****************************************************************************80 ! !! GETSENRB determines the reduced sensitivities from the full sensitivities. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis solution. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NCOFRB, the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NEQNFL, the number of equations (and coefficients) in the full ! finite element system. ! ! integer NSENFL, the number of full solution sensitivities to compute, ! counting the 0-th order sensitivity as the first one. ! ! RB double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! RB is generated by computing a finite element solution GFL, ! which is saved for later reference as "GFLRB". ! GFLRB is copied into the first column of RB. ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! Now we compute the QR factorization of this matrix. ! We intend that NEQNFL >> NCOFRB, and RB is a matrix with orthogonal ! columns, so that: ! Transpose(RB) * RB = Identity(NCOFRB) ! If GFL is any set of finite element coefficients, the corresponding ! set of reduced basis coefficients can be computed as: ! GRB = Transpose(RB) * GFL ! If GRB is a set of reduced basis coefficients, a corresponding ! set of finite element coefficients can be computed as: ! GFL = RB * GRB. ! While it is the case that you can expand and then reduce, ! and always get the same result, it is not the case that ! when you reduce and then expand you get the same result! ! It is true, for ANY GRB, that ! GRB = Transpose(RB) * RB * GRB ! which follows from Transpose(RB) * RB = Identity(NCOFRB). ! However, for a general GFL, it is the case that ! GFL = /= RB * Transpose(RB) * GFL. ! Only if GFL was generated from a reduced basis coefficient ! vector will equality apply. In other words, if GFL was generated ! from a reduced basis coefficient: ! GFL = RB * GRB ! then ! RB * Transpose(RB) * GFL = RB * Transpose(RB) * (RB * GRB) ! = RB * GRB = GFL ! so in this strictly limited case, ! RB * Transpose(RB) = Identity(NEQNFL). ! ! double precision SENFL(MAXNFL,MAXCOFRB). ! Columns 1 through NSENFL of SENFL contain the sensitivities ! of the full solution with respect to the REYNLD parameter, for ! orders 0 through NSENFL-1. ! SENFL(I,J) contains the (J-1)-th sensitivity of the I-th full unknown ! with respect to REYNLD. ! ! double precision SENRB(MAXCOFRB,NSENFL). ! SENRB contains the first NSENFL order sensitivities of the ! reduced solution with respect to the REYNLD parameter. ! SENRB(I,J) contains the (J-1)-th sensitivity of the I-th reduced ! unknown with respect to REYNLD. ! SENRB is computed by premultiplying SENFL by Transpose(RB). ! SENRB = Transpose(RB) * SENFL. ! implicit none ! integer maxcofrb integer maxnfl ! integer i integer j integer k integer ncofrb integer neqnfl integer nsenfl double precision rb(maxnfl,maxcofrb) double precision senfl(maxnfl,maxcofrb) double precision senrb(maxcofrb,maxcofrb) ! ! Multiply SENRB = QT * SENFL ! do i = 1, ncofrb do j = 1, nsenfl senrb(i,j) = 0.0D+00 do k = 1, neqnfl senrb(i,j) = senrb(i,j) + rb(k,i) * senfl(k,j) end do end do end do return end subroutine gfl2rb ( gfl, gflrb, grb, maxnfl, ncofrb, neqnfl, rb ) !*****************************************************************************80 ! !! GFL2RB projects a full solution GFL into the reduced solution GRB. ! ! Discussion: ! ! The relationship used is ! ! GRB = Q^T * (GFL-GFLRB). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 11 September 1996. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! Input, double precision GFLRB(NEQNFL). ! GFLRB is the solution value at which the reduced basis was computed. ! The corresponding parameters are PARRB. ! ! Output, double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! Input, integer MAXNFL, the maximum value of NEQNFL, used as ! the leading dimension of RB. ! ! Input, integer NCOFRB, the number of coefficients for the ! reduced system. ! ! Input, integer NEQNFL, the number of coefficients for the ! full system. ! ! Input, double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! implicit none ! integer maxnfl integer neqnfl integer ncofrb ! double precision gfl(neqnfl) double precision gflrb(neqnfl) double precision grb(ncofrb) integer i integer j double precision rb(maxnfl,ncofrb) ! ! Multiply (GFL-GFLRB) by RB transpose. ! do i = 1, ncofrb grb(i) = 0.0D+00 do j = 1, neqnfl grb(i) = grb(i) + rb(j,i) * ( gfl(j) - gflrb(j) ) end do end do return end subroutine grb2fl ( gfl, gflrb, grb, maxnfl, ncofrb, neqnfl, rb ) !*****************************************************************************80 ! !! GRB2FL determines the full solution represented by a reduced solution. ! ! Discussion: ! ! The relationship used is: ! ! GFL = GFLRB + Q*GRB. ! ! GRB2FL is given: ! ! NCOFRB, the number of reduced basis vectors and coefficients; ! NEQNFL, the number of full basis vectors and coefficients; ! GRB, the reduced basis coefficients; ! RB, the matrix of reduced basis vectors. ! ! and computes ! ! GFL, the corresponding full solution. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 12 September 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! Input, double precision GFLRB(NEQNFL). ! GFLRB is the solution value at which the reduced basis was computed. ! The corresponding parameters are PARRB. ! ! Input, double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! Input, integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! Input, integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! Input, integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! implicit none ! integer maxnfl integer ncofrb integer neqnfl ! double precision gfl(neqnfl) double precision gflrb(neqnfl) double precision grb(ncofrb) double precision rb(maxnfl,ncofrb) ! gfl(1:neqnfl) = gflrb(1:neqnfl) & + matmul ( rb(1:neqnfl,1:ncofrb), grb(1:ncofrb) ) return end subroutine hello ( maxnx, maxny ) !*****************************************************************************80 ! !! HELLO prints an introductory message about the program. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MAXNX. ! MAXNX is the maximum size of NX that the program can handle. ! ! Input, integer MAXNY. ! MAXNY is the maximum size of NY that the program can handle. ! implicit none ! integer maxnx integer maxny ! ! Say hello. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ARBY4' write ( *, '(a)' ) ' A reduced basis flow analysis code.' write ( *, '(a)' ) ' Last modified on 04 December 2000.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The maximum problem size is' write ( *, '(a,i6)' ) ' MAXNX = ', maxnx write ( *, '(a,i6)' ) ' MAXNY = ', maxny return end subroutine help !*****************************************************************************80 ! !! HELP lists the interactive commands. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'HELP' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Compare Compare GFL to GFLSAV;' write ( *, '(a)' ) 'CostFL Evaluate cost of GFL;' write ( *, '(a)' ) 'CostRB Evaluate cost of GRB;' write ( *, '(a)' ) 'DetFpFL Determinant of full jacobian;' write ( *, '(a)' ) 'DetFpRB Determinant of reduced jacobian;' write ( *, '(a)' ) 'DifFPRB FD estimate of reduced jacobian;' write ( *, '(a)' ) 'DifSenFL FD estimate of full sensitivities;' write ( *, * ) 'DifSenRB FD estimate of reduced sensitivities;' write ( *, * ) 'DisFil = Name the DISPLAY output file;' write ( *, * ) 'DisPlot Make DISPLAY plot file of current data;' write ( *, * ) 'DREY = Set REYNLD Taylor increment;' write ( *, * ) 'Echo Echo user commands;' write ( *, * ) 'EPSDIF = Set finite difference increment;' write ( *, * ) 'Expand GRB Compute GFL = RB*GRB;' write ( *, * ) 'FPFL Evaluate full jacobian;' write ( *, * ) 'FPIRB Evaluate reduced jacobian indirectly;' write ( *, * ) 'FPRB Evaluate reduced jacobian;' write ( *, * ) 'FPRB = 0 Zero out reduced jacobian;' write ( *, * ) 'FxFl Evaluate full residual, FXFL(GFL);' write ( *, * ) 'FxIRB Evaluate FXRB = RB^T*FX(RB*GRB), indirectly;' write ( *, * ) 'FxRB Evaluate FXRB = FXrb(GRB) directly;' write ( *, * ) 'FxRB = 0 Set vector FXRB=0;' write ( *, * ) 'GetGSEN Compute sensitivity coefficients;' write ( *, * ) 'GetRB Compute reduced basis;' write ( *, * ) 'GetSenFL Compute full sensitivities;' write ( *, * ) 'GetSenRB Compute reduced sensitivities;' write ( *, * ) 'GFL = Set current full solution,' write ( *, * ) ' Legal values: 0, GFLSAV, GFLTAY, TAYLOR;' write ( *, * ) 'GFLSAV = GFL Save current GFL value;' write ( *, * ) 'GFLTAY = Set Taylor base solution,' write ( *, * ) ' Legal values: 0, GFL, GFLSAV;' write ( *, * ) 'GFLTMP = Set temporary base solution,' write ( *, * ) ' Legal values: 0, GFL, GFL-GFLSAV,' write ( *, * ) ' GFL-GFLTAR, GFLSAV, GFLSAV-GFLTAY;' write ( *, * ) 'GRB(*) = * Set an entry of GRB to a value;' write ( *, * ) 'GRB = Set current reduced solution GRB,' write ( *, * ) ' Legal values: 0, GRBSAV, GRBTAY, TAYLOR;' write ( *, * ) 'GRB = (*,*,...,*) Set individual entries of GRB;' write ( *, * ) 'GRBSAV = Save a GRB value,' write ( *, * ) ' Legal values: 0, GRB;' write ( *, * ) 'GRBTAY = Set Taylor base solution,' write ( *, * ) ' Legal values: 0, GRB, GRBSAV;' write ( *, * ) 'GridX = Uniform, Cos, or SqrtSin;' write ( *, * ) 'GridY = Uniform, Cos, or SqrtSin;' write ( *, * ) 'Hello Print program version and other info;' write ( *, * ) 'Help Print list of commands;' write ( *, * ) 'IBS = Set bump shape option;' write ( *, * ) 'IBUMP = Set bump option;' write ( *, * ) 'IFS = Set inflow shape option;' write ( *, * ) 'IHI = Maximum row for printout,' write ( *, * ) ' NCOFRB, NEQNFL, NP are legal;' write ( *, * ) 'IJAC = Set Jacobian option;' write ( *, * ) 'ILO = Minimum row for printout;' write ( *, * ) 'Init Initialize variables;' write ( *, * ) 'IOPT(*) = Specify free or fixed variables;' write ( *, * ) 'IWRITE = Set level of output;' write ( *, * ) 'JHI = Maximum column for printout,' write ( *, * ) ' NCOFRB, NEQNFL, NSENFL are legal;' write ( *, * ) 'JLO = Minimum column for printout,' write ( *, * ) 'L2NORM * Compute big L2 norm of *,' write ( *, * ) ' * = GFL, GFLSAV, GFLTAR, GFLTAY, GFLTMP;' write ( *, * ) 'MAXNEW = Set number of Newton steps;' write ( *, * ) 'MAXOPT = Set number of optimization steps;' write ( *, * ) 'MAXSIM = Set number of simple steps;' write ( *, * ) 'NBCRB = Set number of boundary conditions;' write ( *, * ) ' (0 or 1, right now);' write ( *, * ) 'NewtFL Newton''s method applied to GFL;' write ( *, * ) 'NewtRB Newton''s method applied to GRB;' write ( *, * ) 'NPARB = Set number of bump parameters;' write ( *, * ) 'NPARF = Set number of inflow parameters;' write ( *, * ) 'NSENFL = Set number of full sensitivities;' write ( *, * ) 'NTAY = Set number of Taylor vectors to use,' write ( *, * ) ' NTAY = NCOFRB is legal, too;' write ( *, * ) 'NX = Set number of X nodes;' write ( *, * ) 'NY = Set number of Y nodes;' write ( *, * ) 'OptDifFl Optimize the full system, using' write ( *, * ) ' FD estimates for gradients;' write ( *, * ) 'PAR(*) = Set a parameter;' write ( *, * ) 'PARTAR(*) = Set a target parameter;' write ( *, * ) 'PicFL Picard''s method applied to GFL;' write ( *, * ) 'PicRB Picard''s method applied to GRB;' write ( *, * ) 'PrDat Print the variable values;' write ( *, * ) 'PrElem Print element data, for elements' write ( *, * ) ' ILO to IHI;' write ( *, * ) 'PrFPFL Print full jacobian,' write ( *, * ) ' Equations ILO to IHI,' write ( *, * ) ' Variables JLO to JHI;' write ( *, * ) 'PrFPRB Print reduced jacobian,' write ( *, * ) ' Equations ILO to IHI,' write ( *, * ) ' Variables JLO to JHI;' write ( *, * ) 'PrFXFL Print FXFL(GFL),' write ( *, * ) ' nodes ILO to IHI;' write ( *, * ) 'PrFXFLNrm Print norm of FXFL(GFL);' write ( *, * ) 'PrFXRB Print FXRB(GRB),' write ( *, * ) ' equations ILO to IHI;' write ( *, * ) 'PrGFL Print full solution GFL,' write ( *, * ) ' nodes ILO to IHI;' write ( *, * ) 'PrGFLNrm Print GFL and FX(GFL) norms;' write ( *, * ) 'PrGRB Print reduced solution GRB;' write ( *, * ) 'PrGSEN Print sensitivity coefficients;' write ( *, * ) 'PrINDX Print node/equation table INDX,' write ( *, * ) ' nodes ILO to IHI.' write ( *, * ) 'PrPar Print current parameters;' write ( *, * ) 'PrParTar Print target parameters;' write ( *, * ) 'PrRBase Print the reduced basis R factor;' write ( *, * ) 'PrRB Print reduced basis matrix RB,' write ( *, * ) ' nodes ILO to IHI,' write ( *, * ) ' columns JLO to JHI;' write ( *, * ) 'PrSenFL Print full sensitivity matrix SENFL,' write ( *, * ) ' nodes ILO to IHI,' write ( *, * ) ' sensitivities JLO to JHI;' write ( *, * ) 'PrSenNrm Print full sensitivity norms;' write ( *, * ) 'PrSenRB Print reduced sensitivity matrix SENRB,' write ( *, * ) ' rows ILO to IHI,' write ( *, * ) ' columns JLO to JHI;' write ( *, * ) 'PrUVPGFL Print full solution at nodes in' write ( *, * ) ' XMIN, YMIN, XMAX, YMAX;' write ( *, * ) 'PrUVPRB Print reduced basis vectors at nodes in' write ( *, * ) ' XMIN, YMIN, XMAX, YMAX;' write ( *, * ) 'PrUVPSENFL Print sensitivity vectors at nodes in' write ( *, * ) ' XMIN, YMIN, XMAX, YMAX;' write ( *, * ) 'PrUVPGRB Print reduced solution at nodes in' write ( *, * ) ' XMIN, YMIN, XMAX, YMAX;' write ( *, * ) 'PrXY Print X, Y nodal coordinates,' write ( *, * ) ' nodes ILO to IHI;' write ( *, * ) 'Reduce GFL Compute GRB = RB^T * GFL;' write ( *, * ) 'REGION = Cavity, Cavity2, Channel, or Step;' write ( *, * ) 'REYNLD = Set REYNLD parameter;' write ( *, * ) 'REYTAY = Set REYNLD parameter for Taylor;' write ( *, * ) ' ("REYTAY = REYNLD" is legal.)' write ( *, * ) 'SetGeo Set problem geometric data;' write ( *, * ) 'SetLog Set problem logical data;' write ( *, * ) 'Stop Stop the program;' write ( *, * ) 'Target Save current GFL as GFLTAR;' write ( *, * ) 'Test2 Compare full and reduced U,V,P' write ( *, * ) ' in elements ILO through IHI;' write ( *, * ) 'Test3 Compare RB*RFACT and SENFL;' write ( *, * ) 'Test4 Compare regular and FD full sens;' write ( *, * ) 'Test5 Compare RB*RFACT and old RB;' write ( *, * ) 'Time Print elapsed time;' write ( *, * ) 'TOLNEW = Set Newton tolerance;' write ( *, * ) 'TOLOPT = Set optimization tolerance;' write ( *, * ) 'TOLSIM = Set Picard tolerance;' write ( *, * ) 'TecFil = Name the TECPLOT output file;' write ( *, * ) 'TecPlot Make TECPLOT plot file of current data;' write ( *, * ) 'WATEB = Set bump weight in cost;' write ( *, * ) 'WATEP = Set pressure weight in cost;' write ( *, * ) 'WATEU = Set H-velocity weight in cost;' write ( *, * ) 'WATEV = Set V-velocity weight in cost;' write ( *, * ) 'XBL = Set left bump X coordinate;' write ( *, * ) 'XBR = Set right bump X coordinate;' write ( *, * ) 'XMAX = Specify XMAX.' write ( *, * ) 'XMIN = Specify XMIN.' write ( *, * ) 'XPROF = Set profile X coordinate;' write ( *, * ) 'XRANGE = Set width of region;' write ( *, * ) 'YBL = Set left bump Y coordinate;' write ( *, * ) 'YBR = Set right bump Y coordinate;' write ( *, * ) 'YMAX = Specify YMAX.' write ( *, * ) 'YMIN = Specify YMIN.' write ( *, * ) 'YRANGE = Set height of region;' return end subroutine init(afl,arb,area,command,cost,costb,costp,costu,costv,difcof, & disfil,drey,epsdif,eqn,etaq,gfl,gflafl,gflrb,gflsav,gflsen,gfltar,gfltay, & grb,grbarb,grbsav,grbsen,grbtay,gridx,gridy,hx,hy,ibs,ibump,icolrb,ierror, & ifs,ihi,ijac,ilo,indx,iopt,ipar,ipivfl,ipivrb,isotri,iwrite,jhi,jlo,ldafl, & maxcofrb,maxelm,maxnew,maxnfl,maxnp,maxny,maxopt,maxpar,maxparb,maxparf, & maxsim,nbcrb,ncofrb,nelem,neqnfl,nferb,nlband,node,nodelm,np,npar,nparb, & nparf,npe,nprof,nsenfl,ntay,numnew,numopt,numsim,nx,ny,par,parafl,pararb, & pardif,parrb,parsav,parsen,partar,phifl,phirb,rb,rbase,region,resfl, & resflsav,resrb,reynld,reytay,senfl,senrb,splbmp,splflo,taubmp,tauflo, & tecfil,tolnew,tolopt,tolsim,value,wateb,watep,wateu,watev,wquad,xbl,xbr, & xc,xmax,xmin,xprof,xquad,xrange,xsiq,ybl,ybr,yc,ymax,ymin,yquad,yrange) !*****************************************************************************80 ! !! INIT sets problem data to default values. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer ldafl integer maxcofrb integer maxelm integer maxnfl integer maxnp integer maxny integer maxpar integer maxparb integer maxparf ! double precision afl(ldafl,maxnfl) double precision arb(maxcofrb,maxcofrb) double precision area(3,maxelm) character ( len = 80 ) command double precision cost double precision costb double precision costp double precision costu double precision costv double precision difcof(maxcofrb) character ( len = 30 ) disfil double precision drey double precision epsdif character ( len = 2 ) eqn(maxnfl) double precision etaq(3) double precision gfl(maxnfl) double precision gflafl(maxnfl) double precision gflrb(maxnfl) double precision gflsav(maxnfl) double precision gflsen(maxnfl) double precision gfltar(maxnfl) double precision gfltay(maxnfl) double precision grb(maxcofrb) double precision grbarb(maxcofrb) double precision grbsav(maxcofrb) double precision grbsen(maxcofrb) double precision grbtay(maxcofrb) character ( len = 20 ) gridx character ( len = 20 ) gridy double precision hx double precision hy integer i integer ibs integer ibump integer icolrb(maxcofrb) integer ierror integer ifs integer ihi integer ijac integer ilo integer indx(3,maxnp) integer iopt(maxpar) integer ipar integer ipivfl(maxnfl) integer ipivrb(maxcofrb) integer isotri(maxelm) integer iwrite integer j integer jhi integer jlo integer k integer l integer maxnew integer maxopt integer maxsim integer nbcrb integer ncofrb integer nelem integer neqnfl integer nferb integer nlband integer node(6,maxelm) integer nodelm(maxnp) integer np integer npar integer nparb integer nparf integer npe integer nprof(2*maxny-1) integer nsenfl integer ntay integer numnew integer numopt integer numsim integer nx integer ny double precision par(maxpar) double precision parafl(maxpar) double precision pararb(maxpar) double precision pardif ( maxpar) double precision parrb(maxpar) double precision parsav(maxpar) double precision parsen(maxpar) double precision partar(maxpar) double precision phifl(3,6,10,maxelm) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision rbase(maxcofrb,maxcofrb) character ( len = 20 ) region double precision resfl(maxnfl) double precision resflsav(maxnfl) double precision resrb(maxcofrb) double precision reynld double precision reytay double precision senfl(maxnfl,maxcofrb) double precision senrb(maxcofrb,maxcofrb) double precision splbmp(maxparb+2) double precision splflo(maxparf) double precision taubmp(maxparb+2) double precision tauflo(maxparf) character ( len = 30 ) tecfil double precision tolnew double precision tolopt double precision tolsim double precision value double precision wateb double precision watep double precision wateu double precision watev double precision wquad(3) double precision xbl double precision xbr double precision xc(maxnp) double precision xmax double precision xmin double precision xquad(3,maxelm) double precision xprof double precision xrange double precision xsiq(3) double precision ybl double precision ybr double precision yc(maxnp) double precision ymax double precision ymin double precision yquad(3,maxelm) double precision yrange ! ! Zero out the variables. ! afl(1:ldafl,1:maxnfl) = 0.0D+00 arb(1:maxcofrb,1:maxcofrb) = 0.0D+00 area(1:3,1:maxelm) = 0.0D+00 command = ' ' cost = 0.0D+00 costb = 0.0D+00 costp = 0.0D+00 costu = 0.0D+00 costv = 0.0D+00 difcof(1:maxcofrb) = 0.0D+00 disfil = 'display.dat' drey = 0.01D+00 epsdif = 0.000001D+00 eqn(1:maxnfl) = ' ' etaq(1:3) = 0.0D+00 gfl(1:maxnfl) = 0.0D+00 gflafl(1:maxnfl) = 0.0D+00 gflrb(1:maxnfl) = 0.0D+00 gflsav(1:maxnfl) = 0.0D+00 gflsen(1:maxnfl) = 0.0D+00 gfltar(1:maxnfl) = 0.0D+00 gfltay(1:maxnfl) = 0.0D+00 grb(1:maxcofrb) = 0.0D+00 grbarb(1:maxcofrb) = 0.0D+00 grbsav(1:maxcofrb) = 0.0D+00 grbsen(1:maxcofrb) = 0.0D+00 grbtay(1:maxcofrb) = 0.0D+00 gridx = 'uniform' gridy = 'uniform' hx = 0.0D+00 hy = 0.0D+00 ibs = 0 ibump = 0 icolrb(1:maxcofrb) = 0 ierror = 0 ifs = 0 ihi = 0 ijac = 1 ilo = 0 indx(1:3,1:maxnp) = 0 iopt(1:maxpar) = 0 ipar = 0 ipivfl(1:maxnfl) = 0 ipivrb(1:maxcofrb) = 0 isotri(1:maxelm) = 0 iwrite = 0 jhi = 0 jlo = 0 maxnew = 10 maxopt = 0 maxsim = 10 nbcrb = 0 ncofrb = 0 nelem = 0 neqnfl = 0 nferb = 0 nlband = 0 node(1:6,1:maxelm) = 0 nodelm(1:maxnp) = 0 np = 0 npar = 1 nparb = 0 nparf = 0 npe = 0 do i = 1, 2*maxny-1 nprof(i) = 0 end do nsenfl = 5 ntay = 0 numnew = 0 numopt = 0 numsim = 0 nx = 0 ny = 0 par(1:maxpar) = 0.0D+00 parafl(1:maxpar) = 0.0D+00 pararb(1:maxpar) = 0.0D+00 pardif (1:maxpar) = 0.0D+00 parrb(1:maxpar) = 0.0D+00 parsav(1:maxpar) = 0.0D+00 parsen(1:maxpar) = 0.0D+00 partar(1:maxpar) = 0.0D+00 do i = 1, 3 do j = 1, 6 do k = 1, 10 phifl(i,j,k,1:maxelm) = 0.0D+00 end do end do end do do i = 1,3 do j = 1,maxcofrb do k = 1,15 phirb(i,j,k,1:maxelm) = 0.0D+00 end do end do end do do i = 1,maxnfl do j = 1,maxcofrb if ( i == j) then rb(i,j) = 1.0D+00 else rb(i,j) = 0.0D+00 end if end do end do do i = 1,maxcofrb do j = 1,maxcofrb if ( i == j) then rbase(i,j) = 1.0D+00 else rbase(i,j) = 0.0D+00 end if end do end do region = ' ' resfl(1:maxnfl) = 0.0D+00 resflsav(1:maxnfl) = 0.0D+00 resrb(1:maxcofrb) = 0.0D+00 reynld = 1.0D+00 reytay = 1.0D+00 do i = 1,maxnfl do j = 1,maxcofrb if ( i == j) then senfl(i,j) = 1.0D+00 else senfl(i,j) = 0.0D+00 end if end do end do do i = 1,maxcofrb do j = 1,maxcofrb if ( i == j) then senrb(i,j) = 1.0D+00 else senrb(i,j) = 0.0D+00 end if end do end do do i = 1,maxparb+2 splbmp(i) = 0.0D+00 end do splflo(1:maxparf) = 0.0D+00 taubmp(1:maxparb+2) = 0.0D+00 tauflo(1:maxparf) = 0.0D+00 tecfil = 'tecplot.dat' tolnew = 0.0D+00 tolopt = 0.0D+00 tolsim = 0.0D+00 value = 0.0D+00 wateb = 0.0D+00 watep = 0.0D+00 wateu = 0.0D+00 watev = 0.0D+00 wquad(1:3) = 0.0D+00 xbl = 0.0D+00 xbr = 0.0D+00 xc(1:maxnp) = 0.0D+00 xmax = 0.0D+00 xmin = 0.0D+00 xprof = 0.0D+00 xquad(1:3,1:maxelm) = 0.0D+00 xrange = 0.0D+00 xsiq(1:3) = 0.0D+00 ybl = 0.0D+00 ybr = 0.0D+00 yc(1:maxnp) = 0.0D+00 ymax = 0.0D+00 ymin = 0.0D+00 yquad(1:3,1:maxelm) = 0.0D+00 yrange = 0.0D+00 return end subroutine newtfl ( afl, area, eqn, gfl, gflafl, ierror, ifs, ijac,& indx, ipivfl, iwrite, ldafl, maxelm, maxnew, nelem, neqnfl, nlband, & node, np, npar, nparf, numnew, par, parafl, phifl, & region, resfl, rmax, splflo, tauflo, tolnew, xrange, yc, yrange ) !*****************************************************************************80 ! !! NEWTFL applies Newton's method to solve the full system. ! ! Discussion: ! ! The exact solution would have a zero residual, as computed by ! the routine FXFL. NEWTFL uses Newton's method to seek a solution ! whose maximum residual is no more than TOLNEW. The routine FPFL ! is used to compute the Jacobian of the residual functions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Workspace, double precision AFL(LDAFL,NEQNFL), ! AFL contains the Jacobian matrix for the full system, ! stored in LINPACK general band storage mode. ! The two dimensional array is of logical dimensions LDAFL by ! NEQNFL. ! ! Input, double precision AREA(3,NELEM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! EQN Input, character ( len = 2 ) EQN(NEQNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. Note that most boundary ! conditions do not result in an equation. The current values are: ! ! 'U' The horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! ! 'V' The vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! ! 'P' The continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! ! GFL Input/output, double precision GFL(NEQNFL), the current solution ! estimate for the full problem. ! ! IERROR Output, integer IERROR, error flag. ! 0, no error occurred. ! 1, an error occurred, and the improved solution could not ! be computed. ! ! IFS Input, integer IFS. ! 1, the inflow is modeled by C0 linear splines. ! 2, the inflow is modeled by C0 quadratic splines. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! IPIVFL Workspace, integer IPIVFL(NEQNFL), pivot vector for the solution ! of the full linear system. ! ! LDAFL Input, integer LDAFL, the first dimension of the matrix AFL. ! ! MAXNEW Input, integer MAXNEW, the maximum number of Newton steps ! that may be taken. 10 should usually be enough. ! ! MAXNFL Input, integer MAXNFL. ! ! The maximum number of equations allowed for the full system. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NEQNFL Input, integer NEQNFL, the number of equations in the full system. ! ! NLBAND Input, integer NLBAND. ! ! The lower bandwidth of the matrix AFL. The zero structure of AFL ! is assumed to be symmetric, and so NLBAND is also the upper ! bandwidth of AFL. ! ! NODE Input, integer NODE(6,NELEM). ! ! NODE(I,J) contains, for an element J, the global node index of ! the element node whose local number is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! 2 ! /| ! 4 5 ! / | ! 1-6-3 ! ! NP Input, integer NP, the number of nodes used to define the finite ! element mesh. NP = (2*NX-1)*(2*NY-1). ! ! NPAR Input, integer NPAR. ! ! The number of parameters. NPAR = NPARF + NPARB + 1. ! ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! NPARB Input, integer NPARB. ! ! The number of parameters associated with the position and ! shape of the bump. ! ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPARF Input, integer NPARF. ! ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! PAR Input, double precision PAR(NPAR). ! ! PAR is the current estimate for the parameters. ! ! PHIFL Input, double precision PHIFL(3,6,10,NELEM). ! ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points. ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! REGION ! Input, character ( len = 20 ) REGION. ! REGION specifies the flow region. ! ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottome, with tangential velocity specifications ! there. ! ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! RESFL Workspace, double precision RESFL(NEQNFL), the residual in the ! full basis equations. ! ! SPLFLO Input, double precision SPLFLO(NPARF). ! SPLFLO contains the spline coefficients for the inflow. ! ! Input, double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. There are NPARF of them, because the end ! values of the spline are constrained to have particular ! values. ! ! Input, double precision TOLNEW, the Newton tolerance. ! NEWTFL is asked to find an approximate solution so that ! the maximum absolute value of all the residuals is no more ! than TOLNEW. A value such as 10E-7 is often reasonable, ! though this depends on the actual equations being solved. ! ! Input, double precision XC(NP). ! The X coordinates of the nodes. ! ! Input, double precision YC(NP). ! The Y coordinates of the nodes. ! implicit none ! integer ldafl integer maxelm integer nelem integer neqnfl integer np integer npar integer nparf ! double precision afl(ldafl,neqnfl) double precision area(3,nelem) double precision dmax character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) double precision gflafl(neqnfl) integer i integer idamax integer idmax integer ierror integer ifs integer ijac integer indx(3,np) integer info integer ipivfl(neqnfl) integer irmax integer iwrite integer ixmax logical lmat integer maxnew integer nlband integer node(6,nelem) integer numnew double precision par(npar) double precision parafl(npar) double precision phifl(3,6,10,nelem) character ( len = 20 ) region double precision resfl(neqnfl) double precision rmax double precision rmax0 double precision splflo(nparf) double precision tauflo(nparf) double precision tolnew double precision xmax double precision xmax0 double precision xrange double precision yc(np) double precision yrange ! ! Force the jacobian matrix to be evaluated on the first iteration. ! lmat = .false. ! ! If the first Newton iteration failed, you may want to try again ! by coming back here. ! 10 continue ierror = 0 numnew = 0 ! ! Compute the norm of the initial solution estimate. ! ixmax = idamax(neqnfl,gfl,1) xmax = abs(gfl(ixmax)) xmax0 = xmax ! ! Evaluate the residual of the initial solution. ! call fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar, & nparf,par,phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) irmax = idamax(neqnfl,resfl,1) rmax = abs(resfl(irmax)) rmax0 = rmax if ( 2 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Step MxNorm(X) IXmax MxNorm(FX) IRmax' write(*,'(i6,g14.6,i6,g14.6,i6)')numnew,xmax,ixmax,rmax,irmax end if ! ! Begin the Newton iteration. ! do numnew = 1,maxnew ! ! If we have a valid, factored jacobian already, then we may ! reuse it, if it's not too old, and if we're allowed. ! if ( 1 < ijac ) then if ( mod(numnew-1,ijac) == 0) then lmat = .false. else lmat = .true. end if else lmat = .false. end if ! ! If it's time, evaluate and factor the jacobian. ! if ( .not. lmat ) then parafl(1:npar) = par(1:npar) gflafl(1:neqnfl) = gfl(1:neqnfl) call fpfl(afl,area,eqn,gfl,indx,ldafl,maxelm,nelem,neqnfl, & nlband,node,np,npar,par,phifl) call dfacfl(afl,ldafl,neqnfl,nlband,nlband,ipivfl,info) if ( info /= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEWTFL - Fatal error!' write ( *, '(a)' ) ' The jacobian is singular.' write ( *, '(a,i6)' ) ' DFACFL returns INFO = ',info ierror = 1 return else lmat = .true. end if end if ! ! Solve the linear system A*DX = RES ! call dsolfl(afl,ldafl,neqnfl,nlband,nlband,ipivfl,resfl) idmax = idamax(neqnfl,resfl,1) dmax = abs(resfl(idmax)) ! ! Update the estimated solution G. ! gfl(1:neqnfl) = gfl(1:neqnfl) - resfl(1:neqnfl) ! ! Compute the norm of the current solution. ! ixmax = idamax(neqnfl,gfl,1) xmax = abs(gfl(ixmax)) ! ! Evaluate the residual of the current estimated solution. ! call fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar, & nparf,par,phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) irmax = idamax(neqnfl,resfl,1) rmax = abs(resfl(irmax)) if ( 2 <= iwrite ) then write(*,'(i6,g14.6,i6,g14.6,i6)')numnew,xmax,ixmax,rmax,irmax end if ! ! Accept the iterate if the residual is small enough. ! if ( rmax <= tolnew) then return end if ! ! Reject the iterate if the residual has grown too large. ! if ( 10.0D+00 *(rmax0+tolnew) < rmax .and. 1 < numnew ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEWTFL - Warning!' write ( *, * ) ' Residual too big on step ',numnew write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, * ) ' MxNorm of this FX = ',rmax go to 20 end if end do ! ! The iteration has failed to converge, or may actually ! have been terminated early. ! 20 continue ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEWTFL - Warning!' write ( *, * ) ' No Newton convergence after ',maxnew,' steps.' write ( *, * ) ' MxNorm of last step = ',dmax write ( *, * ) ' MxNorm of first X = ',xmax0 write ( *, * ) ' MxNorm of last X = ',xmax write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, * ) ' MxNorm of last FX = ',rmax write ( *, * ) ' Tolerance for FX = ',tolnew return end subroutine newtrb(arb,area,grb,grbarb,ierror,indx,ipivrb, & iwrite,maxcofrb,maxelm,maxnew,maxnfl,nbcrb,ncofrb,nelem, & nferb,node,np,npar,nparf,nx,ny,par,pararb,phirb, & rb,resrb,rmax,tauflo,tolnew,xc,xrange,yc,yrange) !*****************************************************************************80 ! !! NEWTRB applies the Newton method to the reduced nonlinear state equations. ! ! Discussion: ! ! The routine is given an initial estimate of the solution of the reduced ! nonlinear state equations, and seeks a better solution. ! ! The exact solution would have a zero residual, as computed by ! the routine FXRB. NEWTRB uses Newton's method to seek a solution ! whose maximum residual is no more than TOLNEW. The routine FPRB ! is used to compute the Jacobian of the residual functions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 August 1996. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Workspace, double precision ARB(MAXNRB,MAXNRB). ! ARB contains the Jacobian matrix for the reduced basis system. ! ! Input/output, double precision GRB(NCOFRB), the current solution ! estimate for the reduced basis problem. ! ! Output, integer IERROR, error flag. ! 0, no error occurred. ! 1, an error occurred, and the improved solution could not be computed. ! ! Workspace, integer IPIVRB(NCOFRB), pivot vector for the solution ! of the reduced linear system. ! ! Input, integer IWRITE. ! IWRITE controls the amount of output printed. ! 0 = little, 1=some, 2=a lot. ! ! Input, integer MAXNEW, the maximum number of Newton steps ! that may be taken. 10 should usually be enough. ! ! Input, integer NELEM, the number of elements. ! ! Input, integer NCOFRB, the number of equations in the reduced system. ! ! Input, integer NPAR. ! The number of parameters. NPAR = NPARF + NPARB + 1. ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the flow. ! ! Input, double precision PAR(NPAR). ! PAR is the current estimate for the parameters. ! ! Output, double precision PARMAT(NPAR). ! PARMAT contains the parameters where the Jacobian was generated. ! ! Input, double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! Workspace, double precision RESRB(NCOFRB), the residual in the ! reduced basis equations, evaluated at the coefficient ! vector GRB. ! ! Input, double precision TOLNEW, the Newton tolerance. ! NEWTRB is asked to find an approximate solution so that ! the maximum absolute value of all the residuals is no more ! than TOLNEW. A value such as 10E-7 is often reasonable, ! though this depends on the actual equations being solved. ! implicit none ! integer maxcofrb integer maxelm integer maxnfl integer ncofrb integer nelem integer np integer npar integer nparf ! double precision arb(maxcofrb,maxcofrb) double precision area(3,nelem) double precision dmax double precision grb(ncofrb) double precision grbarb(ncofrb) integer i integer idamax integer idmax integer ierror integer indx(3,np) integer info integer ipivrb(ncofrb) integer irmax integer iwrite integer ixmax integer maxnew integer nbcrb integer nferb integer node(6,nelem) integer numnew integer nx integer ny double precision par(npar) double precision pararb(npar) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision resrb(ncofrb) double precision reynld double precision rmax double precision rmax0 double precision tauflo(nparf) double precision tolnew double precision xc(np) double precision xmax double precision xmax0 double precision xrange double precision yc(np) double precision yrange ! ! If the first Newton iteration failed, you may want to try again ! by coming back here. ! 10 continue ierror = 0 numnew = 0 ! ! Compute the norm of the initial solution estimate. ! ixmax = idamax(ncofrb,grb,1) xmax = abs(grb(ixmax)) xmax0 = xmax ! ! Evaluate the residual of the initial solution. ! reynld = par(npar) call fxrb(area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb, & resrb,reynld,tauflo,xc,xrange,yc,yrange) irmax = idamax(ncofrb,resrb,1) rmax = abs(resrb(irmax)) rmax0 = rmax if ( 2 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Step MxNorm(X) IXmax MxNorm(FX) IRmax' write(*,'(i6,g14.6,i6,g14.6,i6)')numnew,xmax,ixmax,rmax,irmax end if ! ! Begin the Newton iteration. ! do numnew = 1,maxnew ! ! Evaluate the Jacobian. ! pararb(1:npar) = par(1:npar) grbarb(1:ncofrb) = grb(1:ncofrb) call fprb(arb,area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb, & ncofrb,nelem,nferb,node,np,nx,ny,phirb,rb,reynld,xc,xrange,yc,yrange) ! ! Factor the Jacobian. ! call dfacrb(arb,maxcofrb,ncofrb,ipivrb,info) if ( info /= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEWTRB - Fatal error!' write ( *, '(a)' ) ' The reduced Jacobian is singular.' write ( *, * ) ' DFACRB returns INFO = ',info ierror = 1 return end if ! ! Solve the linear system A*DX = RES ! call dsolrb(arb,maxcofrb,ncofrb,ipivrb,resrb) idmax = idamax(ncofrb,resrb,1) dmax = abs(resrb(idmax)) ! ! Update the estimated solution G. ! grb(1:ncofrb) = grb(1:ncofrb) - resrb(1:ncofrb) ! ! Compute the norm of the current solution. ! ixmax = idamax(ncofrb,grb,1) xmax = abs(grb(ixmax)) ! ! Evaluate the residual of the current estimated solution. ! call fxrb(area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb, & resrb,reynld,tauflo,xc,xrange,yc,yrange) irmax = idamax(ncofrb,resrb,1) rmax = abs(resrb(irmax)) if ( 2 <= iwrite ) then write(*,'(i6,g14.6,i6,g14.6,i6)')numnew,xmax,ixmax,rmax,irmax end if ! ! Accept the iterate if the residual is small enough. ! if ( rmax <= tolnew) then return end if ! ! Reject the iterate if the residual has grown too large. ! if ( 10.0D+00 *(rmax0+tolnew) < rmax .and. 1 < numnew ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEWTRB - Warning!' write ( *, * ) ' Residual too big on step ',numnew write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, * ) ' MxNorm of this FX = ',rmax go to 20 end if end do ! ! The iteration has failed to converge, or may actually ! have been terminated early. ! 20 continue ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'NEWTRB - Warning!' write ( *, * ) ' No Newton convergence after ',numnew,' steps.' write ( *, '(a)' ) ' ' write ( *, * ) ' MxNorm of first X = ',xmax0 write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, '(a)' ) ' ' write ( *, * ) ' MxNorm of last step = ',dmax write ( *, * ) ' MxNorm of last X = ',xmax write ( *, * ) ' MxNorm of last FX = ',rmax return end subroutine optdiffl(afl,area,cost,dopt,eqn,etaq,gfl,gflafl, & gflopt,gfltar,gridx,gridy,ibs,ierror,ifs,ijac,indx,iopt, & ipivfl,isotri,ivopt,iwrite,ldafl,liv,lv,maxelm,maxnew,maxnfl, & maxnp,maxny,maxopt,maxpar,maxparb,maxparf,maxsim,nelem, & neqnfl,nlband,node,nodelm,np,npar,nparb,nparf,nprof,numdif, & numopt,nx,ny,par,parafl,paropt,phifl,region,resfl,splbmp, & splflo,taubmp,tauflo,tolnew,tolopt,tolsim,vopt,wateb,watep, & wateu,watev,wquad,xbl,xbr,xc,xopt,xquad,xrange,xsiq,ybl, & ybr,yc,yquad,yrange) !*****************************************************************************80 ! !! OPTDIFFL optimizes the full problem, without gradient information. ! ! Discussion: ! ! OPTDIFFL searches for a set of parameters PAROPT, ! and the corresponding flow solution GFLOPT, which minimize ! the cost function COST. ! ! The ACM TOMS 611 routine SNOIT is used, which does not require ! direct information about the gradient of COST with respect to ! the parameters PAROPT. Instead, it estimates this information ! indirectly, via finite differences. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision AFL(LDAFL,MAXNFL). ! If Newton iteration is being carried out, AFL contains the ! Jacobian matrix for the full system. ! If Picard iteration is being carried out, AFL contains the ! Picard matrix for the full system. ! AFL is stored in LINPACK general band storage mode, with ! logical dimensions (3*NBANDL+1, NEQNFL). ! ! Input, double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! Output, double precision COST. ! COST contains the current value of the cost function. This ! is the function which the optimizer is to minimize. ! COST = WATEP*COSTP + WATEB*COSTB + WATEU*COSTU + WATEV*COSTV ! ! Workspace, double precision DOPT(MAXPAR). ! DOPT contains scaling factors used during an optimization. ! These scaling factors are intended to adjust problems ! in which some variables are typically very much smaller ! or larger than others. ! ! EQN Input, character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. Note that most boundary ! conditions do not result in an equation. The current values are: ! ! 'U' The horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! ! 'V' The vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! ! 'P' The continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! ETAQ Input, double precision ETAQ(3). ! ETAQ contains the "Eta" coordinates of the quadrature points. ! ! GFL Input, double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! GFLAFL Output, double precision GFLAFL(NEQNFL). ! GFLAFL stores the value of GFL at which the Jacobian ! was generated. ! ! GFLOPT Output, double precision GFLOPT(NEQNFL). ! GFLOPT stores the value of a full solution which is being ! optimized. ! ! GFLTAR Input, double precision GFLTAR(NEQNFL). ! GFLTAR is a target solution, used to generate data that defines ! the cost functional. The corresponding parameters are PARTAR. ! ! IBS Input, integer IBS. ! IBS is the bump shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! IERROR Output, integer IERROR. ! 0, the optimization was successful. ! 1, the optimization failed. ! ! INDX Input, integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! IOPT Workspace, integer IOPT(MAXPAR). ! IOPT is used during an optimization. For each parameter I, ! the meaning of IOPT(I) is: ! 0, the parameter value must remain fixed; ! 1, the parameter value may be varied. ! ! IPIVFL Workspace, integer IPIVFL(NEQNFL). ! IPIVFL is a pivot vector for the solution of the full ! linear system. ! ! ISOTRI Input, integer ISOTRI(NELEM). ! 0, the element is NOT isoparametric, and the nodes never move. ! That means that the quadrature points are only computed once. ! ! 1, the element is NOT isoparametric, but the nodes may move. ! Quadrature point locations must be updated on each step. ! This could occur for elements above, but not touching, the bump. ! ! 2, the element is isoparametric. ! ! IVOPT Workspace, integer IVOPT(LIV). ! IVOPT provides integer workspace for several of the ! optimization routines. ! ! IWRITE Input, integer IWRITE. ! IWRITE controls the amount of output printed. ! 0, print out the least amount. ! 1, print out some. ! 2, print out a lot. ! ! LDAFL Input, integer LDAFL. ! LDAFL is the first dimension of the matrix AFL as declared in ! the main program. LDAFL must be at least 3*NLBAND+1. ! ! LIV Input, integer LIV. ! LIV is the dimension of the work vector IVOPT, used by ! the ACM TOMS 611 optimization package. LIV is always 60. ! ! LV Input, integer LV. ! LV is the dimension of the work vector VOPT, used by ! the ACM TOMS 611 optimization package. ! ! MAXELM Input, integer MAXELM. ! MAXELM is the maximum number of elements. ! ! MAXNEW Input, integer MAXNEW. ! MAXNEW is the maximum number of steps to take in one Newton ! iteration. A typical value is 20. ! ! MAXNFL Input, integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! MAXNP Input, integer MAXNP. ! MAXNP is the maximum number of nodes allowed in the program. ! ! MAXNY Input, integer MAXNY. ! MAXNY is the maximum size of NY that the program can handle. ! ! MAXOPT Input, integer MAXOPT. ! MAXOPT is the maximum number of optimization steps. ! ! MAXPAR Input, integer MAXPAR. ! MAXPAR is the maximum number of parameters allowed. ! MAXPAR = MAXPARF + MAXPARB + 1. ! ! MAXPARB ! Input, integer MAXPARB. ! MAXPARB is the maximum number of bump parameters allowed. ! ! MAXPARF ! Input, integer MAXPARF. ! MAXPARF is the maximum number of inflow parameters allowed. ! ! MAXSIM Input, integer MAXSIM. ! MAXSIM is the maximum number of steps to take in one Picard ! iteration. A typical value is 20. ! ! NELEM Input, integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! NEQNFL Input, integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! NLBAND Input, integer NLBAND. ! NLBAND is the lower bandwidth of the matrix AFL. ! The zero structure of AFL is assumed to be symmetric, and so ! NLBAND is also the upper bandwidth of AFL. ! ! NODE Input, integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! Global nodes Elements NODE ! 1 2 3 4 5 6 ! 74 84 94 3-6-1 2 Left element = (94,72,74,83,73,84) ! | / /| ! 73 83 93 5 4 4 5 Right element = (72,94,92,83,93,82) ! |/ / | ! 72 82 92 2 1-6-3 ! ! NP Input, integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! NPAR Input, integer NPAR. ! NPAR is the number of parameters. ! ! NPAR = NPARF + NPARB + 1. ! ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! NPARB Input, integer NPARB. ! NPARB is the number of parameters associated with the position and ! shape of the bump. ! ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPARF Input, integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! NPROF Input, integer NPROF(2*MAXNY-1). ! NPROF contains the numbers of the nodes along the profile ! line. ! ! NX Input, integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! ! Roughly speaking, NX (or 2*NX) is the number of elements along ! a line in the X direction. ! ! NY Input, integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! ! Roughly speaking, NY (or 2*NY) is the number of elements along ! a line in the Y direction. ! ! PAR Input, double precision PAR(NPAR). ! PAR is the current estimate for the parameters. ! ! PAR(1:NPARF) = inflow controls. ! ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! PARAFL Output, double precision PARAFL(NPAR). ! PARAFL contains the parameters where the Picard matrix or ! Jacobian of the full system was generated. ! ! PAROPT Output, double precision PAROPT(NPAR). ! PAROPT contains the estimate for the optimizing parameter ! values which minimize the cost. ! ! PHIFL Input, double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points. ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! Input, character ( len = 20 ) REGION. ! REGION specifies the flow region. ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottome, with tangential velocity specifications ! there. ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! Workspace, double precision RESFL(NEQNFL). ! RESFL contains the residual in the full basis equations. ! ! Input, double precision SPLBMP(NPARB+2). ! SPLBMP contains the spline coefficients for the bump. ! ! Input, double precision SPLFLO(NPARF). ! SPLFLO contains the spline coefficients for the inflow. ! ! TAUBMP Input, double precision TAUBMP(NPARB+2). ! TAUBMP contains the location of the spline abscissas for ! the bump. There are NPARB+2 of them, because the end values ! of the spline are constrained to have particular values. ! ! TAUFLO Input, double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. There are NPARF of them, because the end ! values of the spline are constrained to have particular ! values. ! ! TOLNEW Input, double precision TOLNEW. ! TOLNEW is the convergence tolerance for the Newton ! iteration. ! ! TOLOPT Input, double precision TOLOPT. ! TOLOPT is the convergence tolerance for the optimization. ! If TOLOPT is zero, then default values are used. ! ! Input, double precision TOLSIM. ! TOLSIM is the convergence tolerance for the Picard ! iteration. ! ! Workspace, double precision VOPT(LV). ! VOPT provides real workspace for the optimization routines. ! ! Input, double precision WATEB. ! WATEB is the multiplier of the bump control cost used ! when computing the total cost. ! ! Input, double precision WATEP, WATEU, WATEV. ! WATEP, WATEU and WATEV are weights used in computing the ! cost function based on the costs of the flow discrepancy. ! ! Input, double precision WQUAD(3). ! WQUAD contains the weights for Gaussian quadrature. ! ! Input, double precision XBL. ! XBL is the X coordinate of the left corner of the bump. ! ! Input, double precision XBR. ! XBR is the X coordinate of the right corner of the bump. ! ! Input, double precision XC(NP). ! XC contains the X coordinates of the nodes. ! ! Workspace, double precision XOPT(MAXPAR). ! XOPT is used by the optimization routines to hold only ! the values of parameters which are allowed to vary. ! ! Input, double precision XQUAD(3,NELEM). ! The X coordinates of the quadrature points for ! each element. ! ! Input, double precision XRANGE. ! The total width of the region. ! ! Input, double precision XSIQ(3). ! The "Xsi" coordinates of the quadrature points. ! ! Input, double precision YBL. ! The Y coordinate of the left corner of the bump. ! ! Input, double precision YBR. ! YBR is the Y coordinate of the right corner of the bump. ! ! Input, double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! ! Input, double precision YQUAD(3,NELEM). ! The Y coordinates of the quadrature points for ! each element. ! ! Input, double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! ! Set parameters that are independent. ! integer ldafl integer liv integer lv integer maxelm integer maxnfl integer maxnp integer maxny integer maxpar integer maxparb integer maxparf integer np ! double precision afl(ldafl,maxnfl) double precision area(3,maxelm) double precision cost double precision costb double precision costp double precision costu double precision costv double precision dopt(maxpar) character ( len = 2 ) eqn(maxnfl) double precision etaq(3) double precision gfl(maxnfl) double precision gflafl(maxnfl) double precision gflopt(maxnfl) double precision gfltar(maxnfl) character ( len = 20 ) gridx character ( len = 20 ) gridy integer i integer ibs integer ierror integer ifs integer ijac integer indx(3,maxnp) integer iopt(maxpar) integer ipivfl(maxnfl) integer isotri(maxelm) integer ival integer ivopt(liv) integer iwrite integer maxnew integer maxopt integer maxsim integer nelem integer neqnfl integer nlband integer node(6,maxelm) integer nodelm(np) integer nopt integer npar integer nparb integer nparf integer nprof(2*maxny-1) integer numdif integer numnew integer numopt integer numsim integer nx integer ny double precision par(maxpar) double precision parafl(maxpar) double precision paropt(maxpar) double precision phifl(3,6,10,maxelm) character ( len = 20 ) region double precision resfl(maxnfl) double precision rmax double precision splbmp(maxparb+2) double precision splflo(maxparf) double precision taubmp(maxparb+2) double precision tauflo(maxparf) double precision tolnew double precision tolopt double precision tolsim double precision vopt(lv) double precision wateb double precision watep double precision wateu double precision watev double precision wquad(3) double precision xbl double precision xbr double precision xc(maxnp) double precision xopt(maxpar) double precision xquad(3,maxelm) double precision xrange double precision xsiq(3) double precision ybl double precision ybr double precision yc(maxnp) double precision yquad(3,maxelm) double precision yrange ! ierror = 0 ! ! Copy the initial solution estimate. ! paropt(1:npar) = par(1:npar) gflopt(1:neqnfl) = gfl(1:neqnfl) ! ! Initialize the local optimization data. ! cost = 0.0D+00 dopt(1:npar) = 1.0D+00 ivopt(1:liv) = 0 nopt = 0 vopt(1:lv) = 0.0D+00 xopt(1:maxpar) = 0.0D+00 ! ! Set the TOMS 611 data to default values, ! and then modify some values. ! ival = 2 call deflt(ival,ivopt,liv,lv,vopt) vopt(31) = tolopt vopt(32) = tolopt vopt(33) = tolopt vopt(34) = tolopt vopt(37) = tolopt ivopt(1) = 12 ivopt(19) = 0 ! ! Set the step counters. ! numdif = 0 numopt = 0 ! ! Take the next optimization step. ! do if ( maxopt < numopt ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OPTDIFFL - Warning!' write ( *, '(a)' ) ' The number of optimization steps was exceeded.' return end if ! ! Make a "copy" of PAR that only contains the free variables. ! nopt = 0 do i = 1,npar if ( iopt(i) == 1) then nopt = nopt+1 xopt(nopt) = paropt(i) end if end do ! ! Call the optimizer to get a new parameter estimate. ! call snoit(dopt,cost,ivopt,liv,lv,nopt,vopt,xopt) ! ! Copy the new free variable values back into PAR. ! nopt = 0 do i = 1,npar if ( iopt(i) == 1) then nopt = nopt+1 paropt(i) = xopt(nopt) end if end do ! ! For the given values of PAROPT, set up the flow problem. ! We are only varying the REYNLD parameter, and no geometric ! quantities vary with REYNLD, so we only have to make this ! call once. ! if ( numopt == 0) then call setgeo(area,etaq,gridx,gridy,ibs,isotri,nelem,node, & nodelm,np,npar,nparb,nparf,nx,ny,paropt,phifl,region, & splbmp,taubmp,wquad,xbl,xbr,xc,xquad,xrange, & xsiq,ybl,ybr,yc,yquad,yrange) end if ! ! Apply Picard's method to the approximate solution GFLOPT. ! call picfl(afl,area,eqn,gflopt,ierror,ifs,indx,ipivfl,iwrite,& ldafl,maxsim,nelem,neqnfl,nlband,node,np,npar,nparf, & numsim,paropt,phifl,region,resfl,rmax,splflo,tauflo, & tolsim,xc,xrange,yc,yrange) ! ! Apply Newton's method to the approximate solution GFLOPT. ! if ( rmax <= tolnew) then write ( *, '(a)' ) 'OPTDIFFL - Picard iterate skips Newton.' else call newtfl(afl,area,eqn,gflopt,gflafl,ierror,ifs,ijac, & indx,ipivfl,iwrite,ldafl,maxelm,maxnew,nelem,neqnfl,nlband, & node,np,npar,nparf,numnew,paropt,parafl,phifl, & region,resfl,rmax,splflo,tauflo,tolnew,xrange,yc,yrange) if ( ierror /= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OPTDIFFL - Fatal error!' write ( *, '(a)' ) ' NEWTFL failed!' write ( *, '(a)' ) ' The parameters at which failure occurred:' write ( *, '(a)' ) ' ' call prpar(iopt,npar,nparb,nparf,paropt) ierror = 1 return end if end if ! ! Compute the cost function COST. ! call getcst(cost,costb,costp,costu,costv,gflopt,gfltar, & indx,neqnfl,np,nparb,nprof,ny,splbmp, & taubmp,wateb,watep,wateu,watev,xbl,xbr,ybl,ybr,yc) if ( ivopt(1) == 1 .and. 0 <= iwrite ) then call prpar(iopt,npar,nparb,nparf,paropt) write ( *, '(a,g14.6)' ) ' Cost = ',cost end if ! ! If IVOPT(1) is 1, then this was a call for a legitimate ! solution candidate. ! ! If IVOPT(1) is 2, then this was a call for a temporary ! solution used only for estimating the gradient. ! ! Other values of IVOPT call for acceptance or rejection. ! if ( ivopt(1) == 1) then numopt = numopt+1 else if ( ivopt(1) == 2) then numdif = numdif+1 else if ( 3 <= ivopt(1) .and. ivopt(1) <= 8 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Convergence to a minimizer was achieved!' return else if ( 8 < ivopt(1) ) then write ( *, '(a)' ) ' ' write ( *, * ) ' Bad value of IVOPT(1) = ',ivopt(1) return end if end do end subroutine optdifrb(arb,area,cost,dopt,gflrb,gfltar,gfltmp, & grb,grbarb,grbopt,ierror,indx,iopt,ipivrb, & ivopt,iwrite,liv,lv,maxcofrb,maxelm,maxnew,maxnfl,maxnp, & maxny,maxopt,maxpar,maxparb,maxsim,nbcrb,ncofrb,nelem,neqnfl, & nferb,node,np,npar,nparb,nparf,nprof,numdif,numopt,nx,ny,par, & pararb,paropt,phirb,rb,resrb,splbmp,tauflo,taubmp,tolnew, & tolopt,tolsim,vopt,wateb,watep,wateu,watev,xbl,xbr,xc,xopt, & xrange,ybl,ybr,yc,yrange) !*****************************************************************************80 ! !! OPTDIFRB optimizes the reduced problem, without gradient information. ! ! Discussion: ! ! OPTDIFRB searches for a set of parameters PAROPT, ! and the corresponding flow solution GRBOPT, which minimize ! the cost function COST. ! ! The ACM TOMS 611 routine SNOIT is used, which does not require ! direct information about the gradient of COST with respect to ! the parameters PAROPT. Instead, it estimates this information ! indirectly, via finite differences. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Workspace, double precision ARB(MAXNRB,MAXNRB). ! ARB contains the Jacobian or Picard matrix for the reduced ! Navier Stokes system, stored as a dense NCOFRB by NCOFRB array. ! ! Input, double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! double precision COST, the current value of the cost function. This ! is the function which the optimizer is to minimize. ! COST = WATEP*COSTP + WATEB*COSTB + WATEU*COSTU + WATEV*COSTV ! ! double precision DOPT(MAXPAR). ! DOPT contains scaling factors used during an optimization. ! These scaling factors are intended to adjust problems ! in which some variables are typically very much smaller ! or larger than others. ! ! double precision GFLRB(NEQNFL). ! GFLRB is the solution value at which the reduced basis was computed. ! The corresponding parameters are PARRB. ! ! double precision GFLTAR(NEQNFL). ! GFLTAR is a target solution, used to generate data that defines ! the cost functional. The corresponding parameters are PARTAR. ! ! Workspace, double precision GFLTMP(NEQNFL). ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! double precision GRBARB(NCOFRB). ! GRBARB contains the reduced basis coefficients at which ! the matrix ARB was last evaluated. ! ! double precision GRBOPT(NCOFRB). ! GRBOPT stores the value of a reduced solution which is being ! optimized. ! ! Workspace, double precision GRBTMP(NCOFRB). ! ! integer IERROR. ! IERROR is an error flag. ! 0, no error occurred in this routine. ! nonzero, an error occurred. ! ! INDX integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! IOPT integer IOPT(MAXPAR). ! IOPT is used during an optimization. For each parameter I, ! the meaning of IOPT(I) is: ! 0, the parameter value must remain fixed; ! 1, the parameter value may be varied. ! ! IPIVRB Workspace, integer IPIVRB(NCOFRB). ! IPIVRB is a pivot vector for the solution of the reduced ! linear system. ! ! IVOPT integer IVOPT(LIV). ! IVOPT provides integer workspace for several of the ! optimization routines. ! ! IWRITE integer IWRITE. ! IWRITE controls the amount of output printed. ! 0, print out the least amount. ! 1, print out some. ! 2, print out a lot. ! ! LIV integer LIV. ! LIV is the dimension of the work vector IVOPT, used by ! the ACM TOMS 611 optimization package. LIV is always 60. ! ! LV integer LV. ! LV is the dimension of the work vector VOPT, used by ! the ACM TOMS 611 optimization package. ! ! MAXELM integer MAXELM. ! MAXELM is the maximum number of elements. ! ! MAXNEW integer MAXNEW. ! MAXNEW is the maximum number of steps to take in one Newton ! iteration. A typical value is 20. ! ! MAXNFL integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! MAXNP integer MAXNP. ! MAXNP is the maximum number of nodes allowed in the program. ! ! MAXNRB integer MAXNRB. ! The maximum number of equations allowed for the reduced basis system. ! ! MAXNY integer MAXNY. ! MAXNY is the maximum size of NY that the program can handle. ! ! MAXOPT integer MAXOPT. ! MAXOPT is the maximum number of optimization steps. ! ! MAXPAR integer MAXPAR. ! MAXPAR is the maximum number of parameters allowed. ! MAXPAR = MAXPARF + MAXPARB + 1. ! ! MAXPARB ! integer MAXPARB. ! MAXPARB is the maximum number of bump parameters allowed. ! ! MAXSIM integer MAXSIM. ! MAXSIM is the maximum number of steps to take in one Picard ! iteration. A typical value is 20. ! ! NELEM integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! NEQNFL integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! NCOFRB integer NCOFRB. ! NCOFRB is the number of basis functions, reduced state equations and ! coefficients in the reduced basis system. ! ! NP integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! NPAR integer NPAR. ! NPAR is the number of parameters. ! ! NPAR = NPARF + NPARB + 1. ! ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! NPARB integer NPARB. ! NPARB is the number of parameters associated with the position and ! shape of the bump. ! ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPARF integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! NPROF integer NPROF(2*MAXNY-1). ! NPROF contains the numbers of the nodes along the profile ! line. ! ! NUMDIF integer NUMDIF. ! NUMDIF is the number of flow solutions generated strictly for ! finite difference calculations. ! ! NUMOPT integer NUMOPT. ! NUMOPT is the number of flow solutions calculated during ! an optimization which were actual candidate minimizers. ! ! NY integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! ! Roughly speaking, NY (or 2*NY) is the number of elements along ! a line in the Y direction. ! ! PAR double precision PAR(NPAR). ! PAR is the current estimate for the parameters. ! ! PAR(1:NPARF) = inflow controls. ! ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! PARARB double precision PARARB(NPAR). ! PARARB contains the parameters where the Picard matrix or ! Jacobian of the reduced system was generated. ! ! PAROPT double precision PAROPT(NPAR). ! PAROPT contains the estimate for the optimizing parameter ! values which minimize the cost. ! ! PHIRB Input, double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! RB double precision RB(MAXNFL,NCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! ! RB is generated by computing a finite element solution GFL. ! A copy of this solution will be saved and called "GFLRB". ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter (for us, REYNLD). The first derivative ! is stored in column 1 of RB, and so on. Then we orthogonalize ! the columns of RB. ! ! We intend that NEQNFL >> NCOFRB, and RB is a matrix with orthogonal ! columns, so that: ! ! Transpose(RB) * RB = Identity(NCOFRB) ! ! ! If GFL is any set of finite element coefficients, the corresponding ! set of reduced basis coefficients can be computed as: ! ! GRB = Transpose(RB) * (GFL-GFLRB) ! ! If GRB is a set of reduced basis coefficients, a corresponding ! set of finite element coefficients can be computed as: ! ! GFL = GFLRB + RB * GRB. ! ! While it is the case that you can expand and then reduce, ! and always get the same result, it is not the case that ! when you reduce and then expand you get the same result! ! ! It is true, for ANY GRB, that ! ! GRB = Transpose(RB) * RB * GRB ! ! which follows from Transpose(RB) * RB = Identity(NCOFRB). ! ! However, for a general GFL, it is the case that ! ! GFL = /= GFLRB + RB * Transpose(RB) * (GFL-GFLRB). ! ! Only if GFL was generated from a reduced basis coefficient ! vector will equality apply. In other words, if GFL was generated ! from a reduced basis coefficient: ! ! GFL = GFLRB + RB * GRB ! ! then ! ! GFLRB + RB * Transpose(RB) * (GFL-GFLRB) ! = GFLRB + RB * Transpose(RB) * (RB * GRB) ! = GFLRB + RB * GRB ! = GFL ! ! so in this strictly limited case, ! ! RB * Transpose(RB) = Identity(NEQNFL). ! ! double precision RESRB(NCOFRB). ! RESRB contains the residual in the reduced basis equations, ! for the parameter values PAR and reduced basis coefficients GRB. ! ! double precision SPLBMP(NPARB+2). ! SPLBMP contains the spline coefficients for the bump. ! ! double precision TAUBMP(NPARB+2). ! TAUBMP contains the location of the spline abscissas for ! the bump. There are NPARB+2 of them, because the end values ! of the spline are constrained to have particular values. ! ! double precision TOLNEW. ! TOLNEW is the convergence tolerance for the Newton ! iteration. ! ! double precision TOLOPT. ! TOLOPT is the convergence tolerance for the optimization. ! If TOLOPT is zero, then default values are used. ! ! double precision TOLSIM. ! TOLSIM is the convergence tolerance for the Picard iteration. ! ! double precision VOPT(LV). ! VOPT provides real workspace for the optimization routines. ! ! double precision WATEB. ! WATEB is the multiplier of the bump control cost used ! when computing the total cost. ! ! double precision WATEP, WATEU, WATEV. ! WATEP, WATEU and WATEV are weights used in computing the ! cost function based on the costs of the flow discrepancy. ! ! double precision XBL. ! XBL is the X coordinate of the left corner of the bump. ! ! double precision XBR. ! XBR is the X coordinate of the right corner of the bump. ! ! double precision XOPT(MAXPAR). ! XOPT is used by the optimization routines to hold only ! the values of parameters which are allowed to vary. ! ! double precision YBL. ! YBL is the Y coordinate of the left corner of the bump. ! ! double precision YBR. ! YBR is the Y coordinate of the right corner of the bump. ! ! double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! implicit none ! ! Set parameters that are independent. ! integer liv integer lv integer maxcofrb integer maxelm integer maxnfl integer maxnp integer maxny integer maxpar integer maxparb integer ncofrb ! double precision arb(maxcofrb,maxcofrb) double precision area(3,maxelm) double precision cost double precision costb double precision costp double precision costu double precision costv double precision dopt(maxpar) double precision gflrb(maxnfl) double precision gfltar(maxnfl) double precision gfltmp(maxnfl) double precision grb(ncofrb) double precision grbarb(ncofrb) double precision grbopt(ncofrb) integer i integer ierror integer indx(3,maxnp) integer iopt(maxpar) integer ipivrb(maxcofrb) integer ival integer ivopt(liv) integer iwrite integer maxnew integer maxopt integer maxsim integer nbcrb integer nelem integer neqnfl integer nferb integer node(6,nelem) integer nopt integer np integer npar integer nparb integer nparf integer nprof(2*maxny-1) integer numdif integer numopt integer nx integer ny double precision par(maxpar) double precision pararb(maxpar) double precision paropt(maxpar) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision resrb(maxcofrb) double precision rmax double precision splbmp(maxparb+2) double precision taubmp(maxparb+2) double precision tauflo(nparf) double precision tolnew double precision tolopt double precision tolsim double precision vopt(lv) double precision wateb double precision watep double precision wateu double precision watev double precision xbl double precision xbr double precision xc(np) double precision xopt(maxpar) double precision xrange double precision ybl double precision ybr double precision yc(maxnp) double precision yrange ! ierror = 0 ! ! Copy the initial solution estimate. ! paropt(1:npar) = par(1:npar) grbopt(1:ncofrb) = grb(1:ncofrb) ! ! Initialize the local optimization data. ! cost = 0.0D+00 dopt(1:npar) = 1.0D+00 ivopt(1:liv) = 0 nopt = 0 vopt(1:lv) = 0.0D+00 xopt(1:maxpar) = 0.0D+00 ! ! Set the 611 data to default values, ! and then modify some values. ! ival = 2 call deflt(ival,ivopt,liv,lv,vopt) vopt(31) = tolopt vopt(32) = tolopt vopt(33) = tolopt vopt(34) = tolopt vopt(37) = tolopt ivopt(1) = 12 ivopt(19) = 0 ! ! Set the step counters. ! numdif = 0 numopt = 0 ! ! Take the next optimization step. ! 10 continue if ( maxopt < numopt ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OPTDIFRB - Warning!' write ( *, '(a)' ) ' The number of optimization steps was exceeded.' return end if ! ! Make a "copy" of PAR that only contains the free variables. ! nopt = 0 do i = 1,npar if ( iopt(i) == 1) then nopt = nopt+1 xopt(nopt) = paropt(i) end if end do ! ! Call the optimizer to get a new parameter estimate. ! call snoit(dopt,cost,ivopt,liv,lv,nopt,vopt,xopt) ! ! Copy the new free variable values back into PAR. ! nopt = 0 do i = 1,npar if ( iopt(i) == 1) then nopt = nopt+1 paropt(i) = xopt(nopt) end if end do ! ! Apply Picard's method to the approximate solution GRBOPT. ! call picrb(arb,area,grbopt,ierror,indx,ipivrb,iwrite, & maxcofrb,maxelm,maxnfl,maxsim,nbcrb,ncofrb,nelem, & nferb,node,np,npar,nparf,nx,ny,paropt,phirb,rb,resrb,rmax, & tauflo,tolsim,xc,xrange,yc,yrange) ! ! Apply Newton's method to the approximate solution GRBOPT. ! if ( tolnew < rmax ) then call newtrb(arb,area,grbopt,grbarb,ierror,indx,ipivrb, & iwrite,maxcofrb,maxelm,maxnew,maxnfl,nbcrb,ncofrb,nelem, & nferb,node,np,npar,nparf,nx,ny,paropt,pararb,phirb, & rb,resrb,rmax,tauflo,tolnew,xc,xrange,yc,yrange) if ( ierror /= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'OPTDIFRB - Fatal error!' write ( *, '(a)' ) ' NEWTRB failed!' write ( *, '(a)' ) ' The parameters at which failure occurred:' write ( *, '(a)' ) ' ' call prpar(iopt,npar,nparb,nparf,paropt) ierror = 1 return end if end if ! ! Compute the equivalent full basis solution GFLTMP = RB*GRB. ! call grb2fl ( gfltmp, gflrb, grbopt, maxnfl, ncofrb, neqnfl, rb ) ! ! Compute the cost function COST. ! call getcst(cost,costb,costp,costu,costv,gfltmp,gfltar, & indx,neqnfl,np,nparb,nprof,ny,splbmp, & taubmp,wateb,watep,wateu,watev,xbl,xbr,ybl,ybr,yc) if ( ivopt(1) == 1 .and. 0 <= iwrite ) then call prpar(iopt,npar,nparb,nparf,paropt) write ( *, '(a,g14.6)' ) ' Cost = ',cost end if ! ! If IVOPT(1) is 1, then this was a call for a legitimate ! solution candidate. ! ! If IVOPT(1) is 2, then this was a call for a temporary ! solution used only for estimating the gradient. ! ! Other values of IVOPT indicate acceptance or rejection ! of the iteration. ! if ( ivopt(1) == 1) then numopt = numopt+1 else if ( ivopt(1) == 2) then numdif = numdif+1 else if ( 3 <= ivopt(1) .and. ivopt(1) <= 8 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Convergence to a minimizer was achieved!' return else if ( 8 < ivopt(1) ) then write ( *, '(a)' ) ' ' write ( *, * ) ' Bad value of IVOPT(1) = ',ivopt(1) return end if go to 10 end subroutine picfl(afl,area,eqn,gfl,ierror,ifs,indx,ipivfl,iwrite,ldafl, & maxsim,nelem,neqnfl,nlband,node,np,npar,nparf,numsim,par,phifl,region, & resfl,rmax,splflo,tauflo,tolsim,xc,xrange,yc,yrange) ! !*****************************************************************************80 ! !! PICFL carries out simple iteration on the full Navier Stokes equations. ! ! ! Discussion: ! ! The simple iteration equations have the form: ! ! Integral ! ! dU/dx * dW/dx ! + dU/dy * dW/dy ! + reynld * (UOLD*dU/dx + VOLD*dU/dy + dP/dx) * W dx dy = 0 ! ! Integral ! ! dV/dx * dW/dx ! + dV/dy * dW/dy ! + reynld * (UOLD*dV/dx + VOLD*dV/dy + dP/dy) * W dx dy = 0 ! ! Integral ! ! (dU/dx + dV/dy) * Q dx dy = 0 ! ! Here W is a basis function for U and V, and Q is a basis ! function for P. UOLD and VOLD are the values of U and V ! on the previous step of the iteration. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 06 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision AFL(LDAFL,MAXNFL). ! If Newton iteration is being carried out, AFL contains the ! Jacobian matrix for the full system. ! If Picard iteration is being carried out, AFL contains the ! Picard matrix for the full system. ! ! AFL is stored in LINPACK general band storage mode, with ! logical dimensions (3*NLBAND+1, NEQNFL). ! ! Where is the (I,J) entry of AFL actually stored? ! AFL has actual storage for such an entry only if ! -NLBAND <= I-J <= NLBAND. ! In such a case, the (I,J) entry is actually stored in ! AFL(I-J+2*NLBAND+1,J) ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! ! or, if the element is isoperimetric, ! ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! ! Here Ar(IELEM) represents the area of element IELEM. ! ! character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. ! ! 'U' A horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! ! 'V' A vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! ! 'P' A continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! integer IERROR. ! IERROR is an error flag. ! 0, no error occurred in this routine. ! nonzero, an error occurred. ! ! integer IFS. ! IFS is the inflow shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! Workspace, integer IPIVFL(NEQNFL). ! IPIVFL is a pivot vector for the solution of the full ! linear system. ! ! integer IWRITE. ! IWRITE controls the amount of output printed. ! 0, print out the least amount. ! 1, print out some. ! 2, print out a lot. ! ! integer LDAFL. ! LDAFL is the first dimension of the matrix AFL as declared in ! the main program. LDAFL must be at least 3*NLBAND+1. ! ! integer MAXSIM. ! MAXSIM is the maximum number of steps to take in one Picard ! iteration. A typical value is 20. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NLBAND. ! NLBAND is the lower bandwidth of the matrix AFL. ! The zero structure of AFL is assumed to be symmetric, and so ! NLBAND is also the upper bandwidth of AFL. ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! integer NUMSIM. ! NUMSIM is the number of simple iterations taken on a particular ! call to the simple iteration routine. ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points (which are the element midside nodes). ! ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! character ( len = 20 ) REGION. ! REGION specifies the flow region. ! ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottome, with tangential velocity specifications ! there. ! ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! double precision RESFL(NEQNFL). ! RESFL contains the residual in the full basis equations. ! ! Output, double precision RMAX. ! RMAX is the maximum absolute value of the entries of the residual ! vector evaluated at the returned solution estimate. ! ! double precision SPLFLO(NPARF). ! SPLFLO contains the spline coefficients for the inflow. ! ! double precision TAUFLO(NPARF). ! TAUFLO contains the location of the spline abscissas for ! the inflow. ! ! double precision TOLSIM. ! TOLSIM is the convergence tolerance for the Picard iteration. ! ! double precision XC(NP). ! XC contains the X coordinates of the nodes. ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer ldafl integer nelem integer neqnfl integer np integer npar integer nparf ! double precision afl(ldafl,neqnfl) double precision area(3,nelem) double precision dxmax character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) integer i integer idamax integer ierror integer ifs integer indx(3,np) integer info integer ipivfl(neqnfl) integer irmax integer iwrite integer ixmax integer maxsim integer nlband integer node(6,nelem) integer numsim double precision par(npar) double precision phifl(3,6,10,nelem) character ( len = 20 ) region double precision resfl(neqnfl) double precision rmax double precision rmax0 double precision splflo(nparf) double precision tauflo(nparf) double precision tolsim double precision xc(np) double precision xmax double precision xmax0 double precision xrange double precision yc(np) double precision yrange ! ierror = 0 ! ! Get XMAX0, the norm of the initial guess GFL. ! ixmax = idamax ( neqnfl, gfl, 1 ) xmax = abs(gfl(ixmax)) xmax0 = xmax ! ! Get RMAX0, the norm of the error RESFL of the initial guess, GFL. ! call fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar, & nparf,par,phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) irmax = idamax(neqnfl,resfl,1) rmax = abs(resfl(irmax)) rmax0 = rmax numsim = 0 if ( 2 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Step MxNorm(X) IXmax MxNorm(FX) IRmax' write(*,'(i6,g14.6,i6,g14.6,i6)')numsim,xmax,ixmax,rmax,irmax end if if ( rmax0 < tolsim) then return end if ! ! Do up to MAXSIM steps of simple iteration. ! do numsim = 1,maxsim ! ! Get the simple iteration system matrix AFL evaluated at GFL. ! call picmfl(afl,area,eqn,gfl,indx,ldafl,nelem,neqnfl,nlband, & node,np,npar,par,phifl) ! ! Factor the matrix. ! call dfacfl(afl,ldafl,neqnfl,nlband,nlband,ipivfl,info) if ( info /= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PicFL - Fatal error!' write ( *, '(a)' ) ' The Picard matrix AFL is singular!' write ( *, * ) ' DFACFL returns nonzero INFO = ',info ierror = 1 return end if ! ! Get the right hand side, RESFL. ! call picvfl(eqn,ifs,indx,neqnfl,np,npar,nparf,par, & region,resfl,splflo,tauflo,xc,xrange,yc,yrange) ixmax = idamax(neqnfl,resfl,1) dxmax = abs(resfl(ixmax)) ! ! Solve the linear system AFL*GFL = RESFL. ! call dsolfl(afl,ldafl,neqnfl,nlband,nlband,ipivfl,resfl) ! ! Compare RESFL and the previous estimate GFL. ! dxmax = 0.0D+00 ixmax = 0 do i = 1,neqnfl if ( dxmax <= abs ( resfl(i) - gfl(i) ) ) then ixmax = i dxmax = abs ( resfl(i) - gfl(i) ) end if end do ! ! Update GFL with the new estimate, and save its norm. ! do i = 1,neqnfl gfl(i) = resfl(i) end do ixmax = idamax(neqnfl,gfl,1) xmax = abs(gfl(ixmax)) ! ! Compute FX(GFL). ! call fxfl(area,eqn,gfl,ifs,indx,nelem,neqnfl,node,np,npar, & nparf,par,phifl,region,resfl,splflo,tauflo,xrange,yc,yrange) irmax = idamax(neqnfl,resfl,1) rmax = abs(resfl(irmax)) ! ! Print out ! if ( 2 <= iwrite ) then write(*,'(i6,g14.6,i6,g14.6,i6)')numsim,xmax,ixmax,rmax,irmax end if ! ! Converged, Failed, or Continue? ! if ( rmax < tolsim * (rmax0+1.0D+00 )) then if ( 2 <= iwrite ) then write ( *, '(a)' ) 'PicFL - Residual acceptance.' end if return end if if ( 1000.0D+00 *rmax0 < rmax ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PicFL - Fatal error!' write ( *, * ) ' Simple iteration diverging on step ',numsim write ( *, * ) ' MxNorm of first X = ',xmax0 write ( *, * ) ' MxNorm of last X = ',xmax write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, * ) ' MxNorm of last FX = ',rmax return end if end do if ( 3 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PicFL - Warning:' write ( *, '(a)' ) ' Simple iteration did not converge.' write ( *, * ) ' MxNorm of first X = ',xmax0 write ( *, * ) ' MxNorm of last X = ',xmax write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, * ) ' MxNorm of last FX = ',rmax end if return end subroutine picmferb(arb,area,grb,maxcofrb,maxelm,nbcrb,ncofrb, & nelem,nferb,phirb,reynld) ! !*****************************************************************************80 ! !! PICMFERB evaluates the simple iteration matrix for a reduced problem. ! ! ! Discussion: ! ! PICMFERB is given ! ! GRB, the reduced basis coefficients of an approximate solution, ! PHIRB, the reduced basis functions, evaluated at the quadrature ! points, ! REYNLD, the current Reynolds number, ! ! and computes ! ! ARB, the simple iteration matrix. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 11 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision ARB(MAXCOFRB,MAXCOFRB). ! ARB contains the Jacobian or Picard matrix for the reduced ! Navier Stokes system, stored as an NCOFRB by NCOFRB array. ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXELM. ! MAXELM is the maximum number of elements. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NFERB. ! NFERB is the number of reduced basis coefficients that will ! be determined via the finite element method. ! ! double precision PHIRB(3,MAXCOFRB,15,MAXELM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! double precision REYNLD. ! REYNLD is the current value of the Reynolds number. ! Normally, REYNLD is stored as PARA(NPARF+NPARB+1). ! implicit none ! integer maxcofrb integer maxelm integer ncofrb integer nelem ! double precision ar double precision arb(maxcofrb,maxcofrb) double precision area(3,maxelm) double precision dqjdx double precision dqjdy double precision dprbdx double precision dprbdy double precision durbdx double precision durbdy double precision dvrbdx double precision dvrbdy double precision dwu0dx double precision dwujdx double precision dwu0dy double precision dwujdy double precision dwv0dx double precision dwvjdx double precision dwv0dy double precision dwvjdy double precision grb(ncofrb) integer icofrb integer ielem integer iquad integer jcofrb logical s_eqi integer nbcrb integer nferb double precision prb double precision phirb(3,maxcofrb,15,maxelm) double precision reynld double precision urb double precision vrb double precision wu0 double precision wv0 ! ! Zero out the FE rows of the matrix. ! do icofrb = nbcrb+1,nbcrb+nferb arb(icofrb,1:ncofrb) = 0.0D+00 end do ! ! Consider an element IELEM... ! do ielem = 1,nelem ! ! ...and a quadrature point IQUAD... ! do iquad = 1,3 ar = area(iquad,ielem) ! ! For the given reduced coefficients GRB, and basis functions ! PHIRB, evaluate U, V, and P, and their spatial derivatives. ! call uvpqrb(dprbdx,dprbdy,durbdx,durbdy,dvrbdx,dvrbdy,grb, & ielem,iquad,maxcofrb,maxelm,ncofrb,phirb,prb,urb,vrb) ! ! Consider FE reduced basis function ICOFRB. ! do icofrb = nbcrb+1,nbcrb+nferb wu0 = phirb(iquad,icofrb,10,ielem) dwu0dx = phirb(iquad,icofrb,11,ielem) dwu0dy = phirb(iquad,icofrb,12,ielem) wv0 = phirb(iquad,icofrb,13,ielem) dwv0dx = phirb(iquad,icofrb,14,ielem) dwv0dy = phirb(iquad,icofrb,15,ielem) ! ! Take the derivative with respect to basis function JCOFRB. ! do jcofrb = 1,ncofrb dwujdx = phirb(iquad,jcofrb,2,ielem) dwujdy = phirb(iquad,jcofrb,3,ielem) dwvjdx = phirb(iquad,jcofrb,5,ielem) dwvjdy = phirb(iquad,jcofrb,6,ielem) dqjdx = phirb(iquad,jcofrb,8,ielem) dqjdy = phirb(iquad,jcofrb,9,ielem) ! ! The horizontal momentum equations. ! arb(icofrb,jcofrb) = arb(icofrb,jcofrb) & +ar*(dwujdx*dwu0dx + dwujdy*dwu0dy & +reynld*(urb*dwujdx+vrb*dwujdy+dqjdx)*wu0) ! ! The vertical momentum equations. ! arb(icofrb,jcofrb) = arb(icofrb,jcofrb) & +ar*(dwvjdx*dwv0dx + dwvjdy*dwv0dy & +reynld*(urb*dwvjdx+vrb*dwvjdy+dqjdy)*wv0) end do end do end do end do return end subroutine picmfl ( afl, area, eqn, gfl, indx, ldafl, nelem, neqnfl, & nlband, node, np, npar, par, phifl ) ! !*****************************************************************************80 ! !! PICMFL computes the Picard iteration matrix for the full Navier Stokes equations. ! ! ! The coefficients are: ! ! ! d U-Eqn/d U-Coef: ! ! Integral ! ! dWj/dx * dWi/dx + dWj/dy * dWi/dy ! + reynld * (Uold*dWj/dx+ Vold*dWj/dy) * Wi dx dy ! ! d U-Eqn/d P-Coef: ! ! Integral ! ! reynld * dQj/dx * Wi dx dy ! ! d V-Eqn/d V-Coef: ! ! Integral ! ! dWj/dx * dWi/dx + dWj/dy * dWi/dy ! + reynld * (Uold*dWj/dx + Vold*dWj/dy) * Wi dx dy ! ! d V-Eqn/d P-Coef: ! ! Integral ! ! reynld * dQj/dy * Wi dx dy ! ! d P-Eqn/d U-Coef: ! ! Integral ! ! dWj/dx * Qi dx dy ! ! d P-Eqn/d V-Coef: ! ! Integral ! ! dWj/dy * Qi dx dy ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision A(LDAFL,NEQNFL), contains the ! coefficients of the Picard iteration matrix. ! ! Input, double precision AREA(3,NELEM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! EQN Input, character ( len = 2 ) EQN(NEQNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. Note that most boundary ! conditions do not result in an equation. The current values are: ! ! 'U' The horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! ! 'V' The vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! ! 'P' The continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! ! GFL Input, double precision GFL(NEQNFL). ! G is the current solution vector, in which are stored ! the finite element coefficients that define the velocity ! and pressure functions, U, V and P. ! ! INDX Input, integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! Input, integer LDAFL, the first dimension of the matrix AFL. ! ! Input, integer NELEM, the number of elements. ! ! Input, integer NEQNFL, the number of finite element equations used ! to define the horizontal and vertical velocities and the ! pressure. ! ! Input, integer NLBAND. ! The lower bandwidth of the matrix A. The zero structure of A ! is assumed to be symmetric, and so NLBAND is also the upper ! bandwidth of A. ! ! NODE Input, integer NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global node index of ! the element node whose local number is I. ! The local ordering of the nodes is suggested by this diagram: ! ! 2 ! /| ! 4 5 ! / | ! 1-6-3 ! ! NP Input, integer NP, the number of nodes used to define the finite ! element mesh. NP = (2*NX-1)*(2*NY-1). ! ! NPAR Input, integer NPAR. ! The number of parameters. NPAR = NPARF + NPARB + 1. ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! NPARB Input, integer NPARB. ! The number of parameters associated with the position and ! shape of the bump. ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPARF Input, integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! PAR Input, double precision PAR(NPAR). ! PAR is the current set of parameter values, including the ! Reynolds parameter, the flow parameters, and the bump parameters. ! ! PHIFL Input, double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points. ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! implicit none ! integer ldafl integer nelem integer neqnfl integer np integer npar ! double precision afl(ldafl,neqnfl) double precision ar double precision area(3,nelem) double precision dpdx double precision dpdy double precision dqjdx double precision dqjdy double precision dudx double precision dudy double precision dvdx double precision dvdy double precision dwidx double precision dwidy double precision dwjdx double precision dwjdy character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) integer i integer ielem integer ihor integer indx(3,np) integer ip integer iprs integer iq integer iquad integer iuse integer iver integer j integer jhor integer jp integer jprs integer jq integer jver logical s_eqi integer nlband integer node(6,nelem) double precision p double precision par(npar) double precision phifl(3,6,10,nelem) double precision qi double precision reynld double precision term double precision u double precision v double precision wi ! reynld = par(npar) do i = 1,3*nlband+1 afl(i,1:neqnfl) = 0.0D+00 end do ! ! Approximate the integral by summing over all elements. ! do ielem = 1,nelem ! ! Evaluate the integrand at the quadrature points. ! do iquad = 1,3 ar = area(iquad,ielem) ! ! Evaluate U, V and P at the IQUAD-th quadrature point. ! call uvpqfl(dpdx,dpdy,dudx,dudy,dvdx,dvdy,gfl,ielem,indx, & iquad,nelem,neqnfl,node,np,p,phifl,u,v) ! ! Consider each node in the element. ! do iq = 1,6 ip = node(iq,ielem) wi = phifl(iquad,iq,1,ielem) dwidx = phifl(iquad,iq,2,ielem) dwidy = phifl(iquad,iq,3,ielem) qi = phifl(iquad,iq,4,ielem) ihor = indx(1,ip) iver = indx(2,ip) iprs = indx(3,ip) ! ! Now compute the derivatives of the functions associated ! with U, V and P, with respect to the coefficients associated ! with basis vectors at each node of the element. ! do jq = 1,6 jp = node(jq,ielem) dwjdx = phifl(iquad,jq,2,ielem) dwjdy = phifl(iquad,jq,3,ielem) dqjdx = phifl(iquad,jq,5,ielem) dqjdy = phifl(iquad,jq,6,ielem) jhor = indx(1,jp) jver = indx(2,jp) jprs = indx(3,jp) ! ! Contributions of the JHOR horizontal velocity to the U, V, and ! P equations. ! if ( eqn(ihor) == 'U') then term = ar*(dwjdx*dwidx+dwjdy*dwidy+ & reynld*(u*dwjdx+v*dwjdy)*wi) iuse = ihor-jhor+2*nlband+1 afl(iuse,jhor) = afl(iuse,jhor)+term end if if ( 0 < iprs ) then if ( eqn(iprs) == 'P') then term = ar*dwjdx*qi iuse = iprs-jhor+2*nlband+1 afl(iuse,jhor) = afl(iuse,jhor)+term end if end if ! ! Contributions of the JVER vertical velocity variable to the ! U, V and P equations. ! if ( eqn(iver) == 'V') then term = ar*(dwjdx*dwidx+dwjdy*dwidy & +reynld*(u*dwjdx+v*dwjdy)*wi) iuse = iver-jver+2*nlband+1 afl(iuse,jver) = afl(iuse,jver)+term end if if ( 0 < iprs ) then if ( eqn(iprs) == 'P') then term = ar*dwjdy*qi iuse = iprs-jver+2*nlband+1 afl(iuse,jver) = afl(iuse,jver)+term end if end if ! ! Contributions of the JPRS pressure to the U and V equations. ! if ( 0 < jprs ) then if ( eqn(ihor) == 'U') then term = ar*reynld*dqjdx*wi iuse = ihor-jprs+2*nlband+1 afl(iuse,jprs) = afl(iuse,jprs)+term end if if ( eqn(iver) == 'V') then term = ar*reynld*dqjdy*wi iuse = iver-jprs+2*nlband+1 afl(iuse,jprs) = afl(iuse,jprs)+term end if end if end do end do end do end do ! ! Set up the equations that enforce boundary conditions. ! do ip = 1,np ihor = indx(1,ip) iver = indx(2,ip) iprs = indx(3,ip) if ( eqn(ihor) == 'UB'.or.eqn(ihor) == 'UI'.or. & eqn(ihor) == 'UW'.or. eqn(ihor) == 'U0') then afl(2*nlband+1,ihor) = 1.0D+00 end if if ( eqn(iver) == 'VB'.or. eqn(iver) == 'VI'.or. & eqn(iver) == 'VW'.or. eqn(iver) == 'V0') then afl(2*nlband+1,iver) = 1.0D+00 end if if ( 0 < iprs ) then if ( eqn(iprs) == 'PB') then afl(2*nlband+1,iprs) = 1.0D+00 else if ( eqn(iprs) == 'P0') then afl(2*nlband+1,iprs) = 1.0D+00 end if end if end do return end subroutine picrb ( arb, area, grb, ierror, indx, ipivrb, iwrite, & maxcofrb, maxelm, maxnfl, maxsim, nbcrb, ncofrb, nelem, nferb, node, & np, npar, nparf, nx, ny, par, phirb, rb, resrb, rmax, tauflo, & tolsim, xc, xrange, yc, yrange ) ! !*****************************************************************************80 ! !! PICRB carries out simple iteration on the reduced Navier Stokes equations. ! ! ! Discussion: ! ! The simple iteration equations have the form: ! ! Integral ! ! dU/dx * dW/dx + dU/dy * dW/dy ! + reynld * (URB*dU/dx + VRB*dU/dy + dP/dx) * W dx dy = 0 ! ! Integral ! ! dV/dx * dW/dx + dV/dy * dW/dy ! + reynld * (URB*dV/dx + VRB*dV/dy + dP/dy) * W dx dy = 0 ! ! Here W is a basis function for U and V. ! UOLD and VOLD are the values of U and V ! on the previous step of the iteration. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Workspace, double precision ARB(MAXNRB,MAXNRB). ! ARB contains the Jacobian or Picard matrix for the reduced ! Navier Stokes system, stored as a dense NCOFRB by NCOFRB array. ! ! Input, double precision AREA(3,NELEM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! GRB Input, double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! GRBTMP Workspace, double precision GRBTMP(NCOFRB). ! ! IERROR Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred. The matrix was singular. ! ! IPIVRB Workspace, integer IPIVRB(NCOFRB). ! ! IWRITE Input, integer IWRITE. ! IWRITE controls the amount of output printed. ! ! MAXSIM Input, integer MAXSIM. ! MAXSIM is the maximum number of simple iteration steps ! that may be taken. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NCOFRB Input, integer NCOFRB. ! NCOFRB is the number of basis functions, reduced state equations and ! coefficients in the reduced basis system. ! ! NPAR Input, integer NPAR. ! The number of parameters. NPAR = NPARF + NPARB + 1. ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! NPARB Input, integer NPARB. ! The number of parameters associated with the position and ! shape of the bump. ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPARF Input, integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! PAR Input, double precision PAR(NPAR). ! PAR is the current set of parameter values, including the ! Reynolds parameter, the flow parameters, and the bump parameters. ! ! PHIRB Input, double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! Workspace, double precision RESRB(NCOFRB). ! ! Input, double precision TOLSIM. ! TOLSIM is the convergence tolerance for the iteration. ! implicit none ! integer maxcofrb integer maxelm integer maxnfl integer ncofrb integer nelem integer np integer npar integer nparf ! double precision arb(maxcofrb,ncofrb) double precision area(3,nelem) double precision dxmax double precision grb(ncofrb) double precision grbtmp(ncofrb) integer i integer idamax integer ierror integer indx(3,np) integer info integer ipivrb(ncofrb) integer irmax integer iwrite integer ixmax integer maxsim integer nbcrb integer nferb integer node(6,nelem) integer numsim integer nx integer ny double precision par(npar) double precision phirb(3,maxcofrb,15,maxelm) double precision rb(maxnfl,maxcofrb) double precision resrb(ncofrb) double precision reynld double precision rmax double precision rmax0 double precision tauflo(nparf) double precision tolsim double precision xc(np) double precision xmax double precision xmax0 double precision xrange double precision yc(np) double precision yrange ! if ( ncofrb <= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PICRB - Fatal error!' write ( *, '(a,i6)' ) ' NCOFRB <= 0, NCOFRB=',ncofrb stop end if reynld = par(npar) ierror = 0 ! ! Get XMAX0, the norm of the initial guess GRB. ! ixmax = idamax(ncofrb,grb,1) xmax = abs(grb(ixmax)) xmax0 = xmax ! ! Get RMAX0, the norm of the error RESRB of the initial guess, GRB. ! call fxrb(area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb, & resrb,reynld,tauflo,xc,xrange,yc,yrange) irmax = idamax(ncofrb,resrb,1) rmax = abs(resrb(irmax)) rmax0 = rmax numsim = 0 if ( 2 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Step MxNorm(X) IXmax MxNorm(FX) IRmax' write(*,'(i6,g14.6,i6,g14.6,i6)')numsim,xmax,ixmax,rmax,irmax end if if ( rmax0 < tolsim) then return end if ! ! Do up to MAXSIM steps of simple iteration. ! do numsim = 1,maxsim ! ! Get the simple iteration system matrix ARB evaluated at GRB. ! call fpbcrb(arb,indx,maxcofrb,maxnfl,nbcrb,ncofrb, & nelem,node,np,nx,ny,rb,xc,xrange,yc,yrange) call picmferb(arb,area,grb,maxcofrb,maxelm,nbcrb,ncofrb, & nelem,nferb,phirb,reynld) ! ! Factor the matrix. ! call dfacrb(arb,maxcofrb,ncofrb,ipivrb,info) if ( info /= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PicRB - Fatal error!' write ( *, '(a)' ) ' The Picard matrix ARB is singular!' write ( *, * ) ' DFACRB returns nonzero INFO = ',info ierror = 1 return end if ! ! Get the right hand side, RESRB. ! grbtmp(1:ncofrb) = 0.0D+00 call fxbcrb(grbtmp,indx,maxcofrb,maxnfl,nbcrb,ncofrb,nelem, & node,np,npar,nparf,nx,ny,par,rb,resrb,tauflo,xc,xrange,yc,yrange) do i = 1,nbcrb resrb(i) = -resrb(i) end do call picvferb(area,grb,maxcofrb,maxelm,nbcrb, & ncofrb,nelem,nferb,npar,par,phirb,resrb) ! ! Solve the linear system ARB*GRB = RESRB. ! call dsolrb(arb,maxcofrb,ncofrb,ipivrb,resrb) ! ! Compare RESRB and the previous estimate GRB. ! dxmax = 0.0D+00 ixmax = 0 do i = 1,ncofrb if ( dxmax <= abs ( resrb(i) - grb(i) ) ) then ixmax = i dxmax = abs ( resrb(i) - grb(i) ) end if end do ! ! Update GRB with the new estimate, and save its norm. ! grb(1:ncofrb) = resrb(1:ncofrb) ixmax = idamax(ncofrb,grb,1) xmax = abs(grb(ixmax)) ! ! Compute FX(GRB). ! call fxrb(area,grb,indx,maxcofrb,maxelm,maxnfl,nbcrb,ncofrb, & nelem,nferb,node,np,npar,nparf,nx,ny,par,phirb,rb, & resrb,reynld,tauflo,xc,xrange,yc,yrange) irmax = idamax(ncofrb,resrb,1) rmax = abs(resrb(irmax)) ! ! Print out ! if ( 2 <= iwrite ) then write(*,'(i6,g14.6,i6,g14.6,i6)')numsim,xmax,ixmax,rmax,irmax end if ! ! Converged, Failed, or Continue? ! if ( rmax < tolsim * (rmax0+1.0D+00 )) then if ( 2 <= iwrite ) then write ( *, '(a)' ) 'PicRB - Residual acceptance.' end if return end if if ( 1000.0D+00 *rmax0 < rmax ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PICRB - Fatal error!' write ( *, * ) ' Simple iteration diverging on step ',numsim write ( *, * ) ' MxNorm of first X = ',xmax0 write ( *, * ) ' MxNorm of last X = ',xmax write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, * ) ' MxNorm of last FX = ',rmax return end if end do if ( 3 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PICRB - Warning:' write ( *, '(a)' ) ' Simple iteration did not converge.' write ( *, * ) ' MxNorm of first X = ',xmax0 write ( *, * ) ' MxNorm of last X = ',xmax write ( *, * ) ' MxNorm of first FX = ',rmax0 write ( *, * ) ' MxNorm of last FX = ',rmax end if return end subroutine picvferb(area,grb,maxcofrb,maxelm,nbcrb,ncofrb,nelem,nferb, & npar,par,phirb,resrb) ! !*****************************************************************************80 ! !! PICVFERB computes the finite element portion of the right hand ! side of the Picard iteration for the reduced Navier Stokes ! equations. ! ! Discussion: ! ! The right hand side is simply the basis solution GFLRB ! multiplied by the iteration matrix and negated. ! The easiest way to access the solution in GFLRB is to set ! a temporary copy of GRB to zero, and call UVPQRB. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision AREA(3,NELEM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! Input, double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! Input, integer NELEM, the number of elements. ! ! Input, integer NCOFRB. ! NCOFRB is the number of basis functions, reduced state equations and ! coefficients in the reduced basis system. ! ! Input, integer NPAR. ! The number of parameters. NPAR = NPARF + NPARB + 1. ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! Input, integer NPARB. ! The number of parameters associated with the position and ! shape of the bump. ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! Input, integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! Input, double precision PAR(NPAR). ! PAR is the current set of parameter values, including the ! Reynolds parameter, the flow parameters, and the bump parameters. ! ! PHIRB Input, double precision PHIRB(3,NCOFRB,15,NELEM). ! PHIRB contains the values of a finite element basis function ! or its X or Y derivative, in a given element, at a given ! quadrature point, for a particular reduced basis function. ! ! For PHIRB(I,J,K,L), index J refers to the reduced basis ! basis functions, for J = 0 to NCOFRB. ! ! The meaning of the K index of PHIRB(I,J,K,L) is as follows: ! ! For the quadrature point I, and reduced basis function J, ! in element L, PHIRB(I,J,K,L) represents the value of: ! ! K = 1, WUrb, the finite element U velocity basis function; ! K = 2, dWUrbdX, the X derivative of WUrb; ! K = 3, dWUrbdY, the Y derivative of WUrb; ! K = 4, WVrb, the finite element V velocity basis function; ! K = 5, dWVrbdX, the X derivative of WVrb; ! K = 6, dWVrbdY, the Y derivative of WVrb; ! K = 7, Q, the finite element pressure basis function. ! K = 8, dQrbdX, the X derivative of Qrb; ! K = 9, dQrbdY, the Y derivative of Qrb. ! K = 10, WU0rb, same as WUrb, with zero BC. ! K = 11, dWU0rbdX, same as dWUrbdX, with zero BC. ! K = 12, dWU0rbdY, same as dWUrbdY, with zero BC. ! K = 13, WV0rb, same as WVrb, with zero BC. ! K = 14, dWV0rbdX, same as dWVrbdX, with zero BC. ! K = 15, dWV0rbdY, same as dWVrbdY, with zero BC. ! ! Output, double precision RESRB(NCOFRB). ! For this routine, RESRB returns the right hand side of ! the Picard iteration system. ! implicit none ! integer maxcofrb integer maxelm integer nelem integer ncofrb integer npar ! double precision ar double precision area(3,nelem) double precision dpdx double precision dpdy double precision dprbdx double precision dprbdy double precision dudx double precision dudy double precision durbdx double precision durbdy double precision dvdx double precision dvdy double precision dvrbdx double precision dvrbdy double precision dwuidx double precision dwuidy double precision dwvidx double precision dwvidy double precision grb(ncofrb) double precision grbtmp(ncofrb) integer ielem integer icofrb integer iquad logical s_eqi integer nbcrb integer nferb double precision p double precision prb double precision par(npar) double precision phirb(3,maxcofrb,15,maxelm) double precision resrb(ncofrb) double precision reynld double precision u double precision urb double precision v double precision vrb double precision wui double precision wvi ! reynld = par(npar) grbtmp(1:ncofrb) = 0.0D+00 do icofrb = nbcrb+1,nbcrb+nferb resrb(icofrb) = 0.0D+00 end do ! ! Approximate the integral by summing over all elements. ! do ielem = 1,nelem ! ! Evaluate the integrand at the quadrature points. ! do iquad = 1,3 ar = area(iquad,ielem) ! ! Evaluate the full solution GFLRB at which the reduced basis ! was generated. This is the implicit "1" coefficient in the ! set of reduced basis coefficients, which must be multiplied ! by the Picard coefficients and carried to the right hand side. ! ! We do this by using GRBTMP, set to 0. ! call uvpqrb(dpdx,dpdy,dudx,dudy,dvdx,dvdy,grbtmp, & ielem,iquad,maxcofrb,maxelm,ncofrb,phirb,p,u,v) ! ! Evaluate the reduced basis solution GRB from the previous iterate. ! call uvpqrb(dprbdx,dprbdy,durbdx,durbdy,dvrbdx,dvrbdy,grb, & ielem,iquad,maxcofrb,maxelm,ncofrb,phirb,prb,urb,vrb) ! ! Now consider each reduced basis function, and retrieve the ! corresponding values of the U and V basis functions. ! do icofrb = nbcrb+1,nbcrb+nferb wui = phirb(iquad,icofrb,1,ielem) dwuidx = phirb(iquad,icofrb,2,ielem) dwuidy = phirb(iquad,icofrb,3,ielem) wvi = phirb(iquad,icofrb,4,ielem) dwvidx = phirb(iquad,icofrb,5,ielem) dwvidy = phirb(iquad,icofrb,6,ielem) ! ! The horizontal velocity equations. ! resrb(icofrb) = resrb(icofrb) & -ar*(dudx*dwuidx + dudy*dwuidy & +reynld*(urb*dudx+vrb*dudy+dpdx)*wui) ! ! The vertical velocity equations. ! resrb(icofrb) = resrb(icofrb) & -ar*(dvdx*dwvidx + dvdy*dwvidy & +reynld*(urb*dvdx+vrb*dvdy+dpdy)*wvi ) end do end do end do return end subroutine picvfl(eqn,ifs,indx,neqnfl,np,npar,nparf,par, & region,resfl,splflo,tauflo,xc,xrange,yc,yrange) ! !*****************************************************************************80 ! !! PICVFL computes the Picard right hand side for the full equations. ! ! ! Discussion: ! ! The Picard iteration equations have the form: ! ! Integral ! ! dU/dx * dW/dx ! + dU/dy * dW/dy ! + reynld * (UOLD*dU/dx + VOLD*dU/dy + dP/dx) * W dx dy = 0 ! ! Integral ! ! dV/dx * dW/dx ! + dV/dy * dW/dy ! + reynld * (UOLD*dV/dx + VOLD*dV/dy + dP/dy) * W dx dy = 0 ! ! Integral ! ! (dU/dx + dV/dy) * Q dx dy = 0 ! ! Here W is a basis function for U and V, and Q is a basis ! function for P. UOLD and VOLD are the values of U and V ! on a previous step of the iteration. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 10 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer neqnfl integer np integer npar integer nparf ! character ( len = 2 ) eqn(neqnfl) integer i integer ifs integer ihor integer indx(3,np) integer ip integer iver double precision par(npar) character ( len = 20 ) region double precision resfl(neqnfl) double precision splflo(nparf) double precision tauflo(nparf) double precision ubc double precision vbc double precision xc(np) double precision xrange double precision xval double precision yc(np) double precision yrange double precision yval ! ! Initialize the right hand side to zero. ! do i = 1,neqnfl resfl(i) = 0.0D+00 end do ! do ip = 1,np xval = xc(ip) yval = yc(ip) ihor = indx(1,ip) iver = indx(2,ip) if ( eqn(ihor) == 'UI'.or.eqn(iver).eq.'VI') then call flowbc(ifs,npar,nparf,par,region,splflo,tauflo, & ubc,vbc,xrange,xval,yrange,yval) if ( eqn(ihor) == 'UI') then resfl(ihor) = ubc end if if ( eqn(iver) == 'VI') then resfl(iver) = vbc end if end if end do return end subroutine reysen(area,eqn,indx,isen,maxcofrb,maxnfl,nelem, & neqnfl,node,np,phifl,resfl,reynld,senfl) ! !*****************************************************************************80 ! !! REYSEN sets up a right hand side for a REYNLD sensitivity equation. ! ! ! Discussion: ! ! The routine sets up the right hand side vector associated with ! the ISEN-th order sensitivities with respect to the REYNLD parameter ! of a given state function (U,V,P). ! ! In order to compute the right hand side for the ISEN-th order, ! a state solution and the sensitivities for all orders less than ! ISEN must already have been computed. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 22 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision AREA(3,MAXELM). ! AREA contains a common factor multiplying the term associated ! with a quadrature point in a given element, namely, ! AREA(IQUAD,IELEM) = Ar(IELEM) * WQUAD(IQUAD) ! or, if the element is isoperimetric, ! AREA(IQUAD,IELEM) = DET * Ar(IELEM) * WQUAD(IQUAD) ! Here Ar(IELEM) represents the area of element IELEM. ! ! character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. ! ! 'U' A horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! 'V' A vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! 'P' A continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! Input, integer ISEN. ! ISEN is the order of the sensitivity to be calculated. ! ! integer MAXCOFRB. ! MAXCOFRB is the maximum legal value for NCOFRB, the number ! of coefficients used to specify a particular reduced basis ! solution. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! double precision PHIFL(3,6,10,NELEM). ! PHIFL contains the value of a finite element basis function, its ! derivative, or other information, evaluated at the quadrature ! points (which are the element midside nodes). ! The meaning of the entry PHIFL(I,J,K,L) is as follows. ! For the quadrature point I, and basis function J, in element L, ! PHIFL(I,J,K,L) represents the value of: ! ! K = 1, W, the finite element basis function for velocities; ! K = 2, dWdX, the X derivative of W; ! K = 3, dWdY, the Y derivative of W; ! K = 4, Q, the finite element basis function for pressures; ! K = 5, dQdX, the X derivative of Q; ! K = 6, dQdY, the Y derivative of Q; ! K = 7, dXsidX, the X derivative of the mapping (X,Y)->XSI; ! K = 8, dXsidY, the Y derivative of the mapping (X,Y)->XSI; ! K = 9, dEtadX, the X derivative of the mapping (X,Y)->ETA; ! K = 10, dEtadY, the Y derivative of the mapping (X,Y)->ETA; ! ! In particular, PHIFL(I,J,K,L) is the value of the quadratic ! basis function W associated with local node J in element L, ! evaluated at quadrature point I. ! Note that PHIFL(I,J,K,L) = 0 whenever J=4, 5, or 6 and K=4, 5, or 6, ! since there are only three linear basis functions. ! ! double precision RESFL(NEQNFL). ! RESFL contains the residual in the full basis equations. ! ! double precision REYNLD. ! REYNLD is the value of the Reynolds number. ! ! double precision SENFL(MAXNFL,MAXCOFRB). ! Columns 1 through NSENFL of SENFL contain the sensitivities ! of the full solution with respect to the REYNLD parameter, for ! orders 0 through NSENFL-1. ! SENFL(I,J) contains the (J-1)-th sensitivity of the I-th full unknown ! with respect to REYNLD. ! implicit none ! integer maxcofrb integer maxnfl integer nelem integer neqnfl integer np ! double precision ar double precision area(3,nelem) double precision dpdx(maxcofrb) double precision dpdy(maxcofrb) double precision dudx(maxcofrb) double precision dudy(maxcofrb) double precision dvdx(maxcofrb) double precision dvdy(maxcofrb) character ( len = 2 ) eqn(neqnfl) integer i integer ielem integer ihor integer indx(3,np) integer ip integer iq integer iquad integer isen integer iver integer jsen integer jsendx integer nbinom integer node(6,nelem) double precision p(maxcofrb) double precision phifl(3,6,10,nelem) double precision resfl(neqnfl) double precision reynld double precision senfl(maxnfl,maxcofrb) double precision term double precision u(maxcofrb) double precision v(maxcofrb) double precision wi ! ! Check the value of REYNLD. ! if ( reynld <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'REYSEN - Fatal error!' write ( *, * ) ' Nonpositive value of REYNLD = ',reynld stop end if ! ! Check the value of ISEN. ! if ( isen <= 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'REYSEN - Fatal error!' write ( *, * ) ' The input value of ISEN is ',isen write ( *, '(a)' ) ' but ISEN must be strictly positive.' stop end if if ( maxcofrb-1 < isen ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'REYSEN - Fatal error!' write ( *, * ) ' The input value of ISEN is ',isen write ( *, * ) ' but the limit is MAXCOFRB-1 = ',maxcofrb-1 stop end if ! ! Zero out the right hand side vector RESFL. ! do i = 1,neqnfl resfl(i) = 0.0D+00 end do ! ! Approximate the integrated ISEN-th order sensitivity equations by ! adding the contribution from element IELEM. ! do ielem = 1,nelem ! ! In element IELEM, approximate the integrals by moving to ! quadrature point IQUAD. ! do iquad = 1,3 ar = area(iquad,ielem) ! ! We are about to compute the sensitivity of order ISEN, which ! is stored in vector entry ISEN+1, or matrix column ISEN+1. ! Evaluate the fundamental solution (U,V,P), and the first ISEN-1 ! sensitivities, (U',V',P'), (U'',V'',P''), and so on, stored in SENFL. ! do jsen = 0,isen-1 jsendx = jsen+1 call uvpqfl(dpdx(jsendx),dpdy(jsendx),dudx(jsendx), & dudy(jsendx),dvdx(jsendx),dvdy(jsendx), & senfl(1,jsendx),ielem,indx,iquad,nelem,neqnfl,node, & np,p(jsendx),phifl,u(jsendx),v(jsendx)) end do ! ! Now consider a node with local index IQ, and global index IP, ! whose quadratic basis function evaluated at the quadrature point ! IQUAD has value WI. Evaluate the right hand sides of equations ! IHOR and IVER and add the contributions to the total. ! do iq = 1,6 ip = node(iq,ielem) wi = phifl(iquad,iq,1,ielem) ihor = indx(1,ip) iver = indx(2,ip) if ( eqn(ihor) == 'U') then term = 0.0D+00 do jsen = 1,isen-1 jsendx = jsen+1 term = term+reynld*nbinom(isen,jsen)*(u(isen-jsen+1)*dudx(jsendx) & +v(isen-jsen+1)*dudy(jsendx)) end do do jsen = 0,isen-1 jsendx = jsen+1 term = term+isen*nbinom(isen-1,jsen)*(u(isen-jsen)*dudx(jsendx) & +v(isen-jsen)*dudy(jsendx)) end do term = term+isen*dpdx(isen) resfl(ihor) = resfl(ihor)-ar*term*wi end if ! ! Note that the vertical right hand side should be obtainable ! from the horizontal right hand side by interchanging U and V, ! and X and Y. ! if ( eqn(iver) == 'V') then term = 0.0D+00 do jsen = 1,isen-1 jsendx = jsen+1 term = term+reynld*nbinom(isen,jsen)*(v(isen-jsen+1)*dvdy(jsendx) & +u(isen-jsen+1)*dvdx(jsendx)) end do do jsen = 0,isen-1 jsendx = jsen+1 term = term+isen*nbinom(isen-1,jsen)*(v(isen-jsen)*dvdy(jsendx) & +u(isen-jsen)*dvdx(jsendx)) end do term = term+isen*dpdy(isen) resfl(iver) = resfl(iver)-ar*term*wi end if end do end do end do return end subroutine test2(gfl,grb,ihi,ilo,indx,maxcofrb,maxelm,ncofrb, & nelem,neqnfl,node,np,phifl,phirb) ! !*****************************************************************************80 ! !! TEST2 compares full and reduced U, V, and P at the quadrature points. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 09 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer maxcofrb integer maxelm integer nelem integer neqnfl integer ncofrb integer np ! double precision dpdx double precision dpdy double precision dprbdx double precision dprbdy double precision dudx double precision dudy double precision durbdx double precision durbdy double precision dvdx double precision dvdy double precision dvrbdx double precision dvrbdy double precision gfl(neqnfl) double precision grb(ncofrb) integer ielem integer ihi integer ihi2 integer ilo integer ilo2 integer indx(3,np) integer iquad integer node(6,nelem) double precision p double precision prb double precision phifl(3,6,10,nelem) double precision phirb(3,maxcofrb,15,maxelm) double precision u double precision urb double precision v double precision vrb ! if ( ilo < 1) then ilo2 = 1 else ilo2 = ilo end if if ( nelem < ihi ) then ihi2 = nelem else ihi2 = ihi end if ! ! Consider an element IELEM... ! write ( *, '(a)' ) ' ' write ( *, * ) 'Elements from ILO2 = ',ilo2,' to IHI2=',ihi2 do ielem = ilo2,ihi2 ! ! ...and a quadrature point IQUAD... ! do iquad = 1,3 ! ! Evaluate U, V, and P for GFL and for GRB. ! call uvpqfl(dpdx,dpdy,dudx,dudy,dvdx,dvdy,gfl,ielem,indx, & iquad,nelem,neqnfl,node,np,p,phifl,u,v) call uvpqrb(dprbdx,dprbdy,durbdx,durbdy,dvrbdx,dvrbdy,grb, & ielem,iquad,maxcofrb,maxelm,ncofrb,phirb,prb,urb,vrb) write ( *, '(a)' ) ' ' write ( *, * ) ' Element ',ielem write ( *, * ) ' Quad point ',iquad write(*,'(a,3g14.6)')'Full U,V,P: ',u,v,p write(*,'(a,3g14.6)')'Reduced U,V,P:',urb,vrb,prb end do end do return end subroutine test3 ( maxcofrb, maxnfl, ncofrb, neqnfl, rb, senfl, senrb ) ! !*****************************************************************************80 ! !! TEST3 verifies that RB*RFACT = SENFL ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 22 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer maxcofrb integer maxnfl integer ncofrb integer neqnfl ! double precision dmax integer i integer imax integer j integer jmax integer k double precision rb(maxnfl,ncofrb) double precision senfl(maxnfl,maxcofrb) double precision senrb(maxcofrb,maxcofrb) double precision temp ! dmax = 0.0D+00 imax = 0 jmax = 0 do i = 1,neqnfl do j = 1,ncofrb temp = 0.0D+00 do k = 1,ncofrb temp = temp+rb(i,k)*senrb(k,j) end do temp = abs(temp-senfl(i,j)) if ( dmax <= temp ) then dmax = temp imax = i jmax = j end if end do end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST3 - Results:' write ( *, '(a)' ) ' The maximum difference between RB*SENRB and SENFL' write ( *, * ) ' is ',dmax write ( *, * ) ' for (I,J) = ',imax,jmax return end subroutine test4(afl,area,difcof,dpar,drey,eqn,gfl,gflafl, & ifs,ijac,indx,ipar,ipivfl,iwrite,ldafl,maxcofrb,maxelm, & maxnew,maxnfl,ncofrb,nelem,neqnfl,nlband,node,np,npar, & nparf,nsenfl,par,parafl,phifl,region,resfl, & senfl,splflo,tauflo,tolnew,xrange,yc,yrange) ! !*****************************************************************************80 ! !! TEST4 compares the sensitivities and their finite difference estimates. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 22 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer ldafl integer maxcofrb integer maxelm integer maxnfl integer nelem integer neqnfl integer np integer npar integer nparf ! double precision afl(ldafl,maxnfl) double precision area(3,nelem) double precision difcof(maxcofrb) double precision difmax double precision dpar double precision drey character ( len = 2 ) eqn(neqnfl) double precision gfl(neqnfl) double precision gflafl(neqnfl) integer i integer ifs integer ijac integer imax integer indx(3,np) integer ipar integer ipivfl(maxnfl) integer iwrite integer j integer jmax integer maxnew integer ncofrb integer nlband integer node(6,nelem) integer nsenfl double precision par(npar) double precision parafl(npar) double precision phifl(3,6,10,nelem) character ( len = 20 ) region double precision resfl(neqnfl) double precision senfl(maxnfl,maxcofrb) double precision senfltmp(maxnfl,maxcofrb) double precision splflo(nparf) double precision tauflo(nparf) double precision tolnew double precision xrange double precision yc(np) double precision yrange ! call getsenfl(afl,area,eqn,gfl,indx,ipivfl,ldafl,maxcofrb,maxnfl,nelem, & neqnfl,nlband,node,np,npar,nsenfl,par,phifl,resfl,senfl) senfltmp(1:neqnfl,1:ncofrb) = senfl(1:neqnfl,1:ncofrb) dpar = drey call difsenfl(afl,area,difcof,dpar,eqn,gfl,gflafl,ifs, & ijac,indx,ipar,ipivfl,iwrite,ldafl,maxcofrb,maxelm, & maxnew,maxnfl, & ncofrb,nelem,neqnfl,nlband,node,np,npar,nparf, & par,parafl,phifl,region,resfl,senfl,splflo,tauflo, & tolnew,xrange,yc,yrange) imax = 0 jmax = 0 difmax = 0.0D+00 do i = 1,neqnfl do j = 1,ncofrb if ( difmax <= abs(senfltmp(i,j)-senfl(i,j)) ) then imax = i jmax = j difmax = abs(senfltmp(i,j)-senfl(i,j)) end if end do end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST4 - Results:' write ( *, * ) ' MAXIMUM DIFFERENCE is ',difmax write ( *, * ) ' I = ', imax write ( *, * ) ' J = ', jmax return end subroutine test5(maxcofrb,maxnfl,ncofrb,neqnfl,rb,rbase) ! !*****************************************************************************80 ! !! TEST5 computes the product of the QR factors of the reduced basis matrix. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 30 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer maxcofrb integer maxnfl integer ncofrb ! integer i integer ihi integer ilo integer j integer jhi integer jlo integer k integer mhi integer mlo integer neqnfl integer nhi integer nlo double precision rb(maxnfl,ncofrb) double precision rbase(maxcofrb,maxcofrb) double precision test(10,5) ! ilo = 1 ihi = min(10,neqnfl) jlo = 1 jhi = min(5,ncofrb) do i = 1,ihi do j = 1,jhi test(i,j) = 0.0D+00 do k = 1,ncofrb test(i,j) = test(i,j)+rb(i,k)*rbase(k,j) end do end do end do mhi = ihi mlo = ilo nhi = jhi nlo = jlo call prdmat(test,ihi,ilo,jhi,jlo,mhi,mlo,nhi,nlo) return end subroutine timestamp ( ) ! !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none ! character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine pruvpfl(gfl,indx,neqnfl,np,xc,xmax,xmin,yc,ymax,ymin) ! !*****************************************************************************80 ! !! PRUVPFL prints the velocity and pressure. ! ! ! Discussion: ! ! The quantities are printed for all nodes within the user defined ! box (XMIN,YMIN) to (XMAX,YMAX). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 15 September 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision GFL(NEQNFL). ! GFL contains the current solution estimate for the full problem, ! containing the pressure and velocity coefficients. ! The vector INDX must be used to index this data. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! double precision XC(NP). ! XC contains the X coordinates of the nodes. ! ! double precision XMAX. ! The maximum X for which a node should be displayed. ! ! double precision XMIN. ! The mininum X for which a node should be displayed. ! ! double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! ! double precision YMAX. ! The maximum Y for which a node should be displayed. ! ! double precision YMIN. ! The minimum Y for which a node should be displayed. ! implicit none ! integer neqnfl integer np ! double precision gfl(neqnfl) integer i integer i1 integer i2 integer i3 integer indx(3,np) double precision xc(np) double precision xmax double precision xmin double precision yc(np) double precision ymax double precision ymin ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PRUVPFL - Print selected flow data' write ( *, * ) xmin,' = XMIN <= X <= XMAX = ',xmax write ( *, * ) ymin,' = YMIN <= Y <= YMAX = ',ymax write ( *, '(a)' ) ' ' write ( *, * ) ' Node X Y ' // & ' U V P' write ( *, '(a)' ) ' ' do i = 1, np if ( xmin <= xc(i).and.xc(i) <= xmax.and. & ymin <= yc(i).and.yc(i) <= ymax) then i1 = indx(1,i) i2 = indx(2,i) i3 = indx(3,i) if ( 0 < i3 ) then write(*,'(i5,2g12.4,3g14.6)')i,xc(i),yc(i),gfl(i1),gfl(i2),gfl(i3) else write(*,'(i5,2g12.4,2g14.6)')i,xc(i),yc(i),gfl(i1),gfl(i2) end if end if end do return end subroutine pruvprb(grb,indx,maxnfl,ncofrb,nelem,node,nodelm,np,rb,xc, & xmax,xmin,yc,ymax,ymin) ! !*****************************************************************************80 ! !! PRUVPRB prints the reduced velocity and pressure. ! ! ! Discussion: ! ! The values are printed for all nodes within the user defined box ! (XMIN,YMIN) to (XMAX,YMAX). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 11 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! double precision RB(MAXNFL,MAXCOFRB). ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! RB is generated by computing a finite element solution GFL, ! which is saved for later reference as "GFLRB". ! GFLRB is copied into the first column of RB. ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! ! double precision XC(NP). ! XC contains the X coordinates of the nodes. ! ! double precision XMAX. ! The maximum X for which a node should be displayed. ! ! double precision XMIN. ! The mininum X for which a node should be displayed. ! ! double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! ! double precision YMAX. ! The maximum Y for which a node should be displayed. ! ! double precision YMIN. ! The minimum Y for which a node should be displayed. ! implicit none ! integer maxnfl integer ncofrb integer nelem integer np ! double precision grb(ncofrb) integer ip integer ielem integer indx(3,np) integer node(6,nelem) integer nodelm(np) double precision prb double precision rb(maxnfl,ncofrb) double precision urb double precision vrb double precision xc(np) double precision xmax double precision xmin double precision xval double precision yc(np) double precision ymax double precision ymin double precision yval ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PRUVPRB - Print selected flow data' write ( *, * ) xmin,' = XMIN <= X <= XMAX = ',xmax write ( *, * ) ymin,' = YMIN <= Y <= YMAX = ',ymax write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' IP XC(IP) YC(IP) U(IP), V(IP), P(IP)' write ( *, '(a)' ) ' ' do ip = 1, np if ( xmin <= xc(ip).and.xc(ip) <= xmax.and. & ymin <= yc(ip).and.yc(ip) <= ymax) then ielem = nodelm(ip) xval = xc(ip) yval = yc(ip) call uvprb(grb,ielem,indx,maxnfl,ncofrb,nelem,node,np,prb, & rb,urb,vrb,xc,xval,yc,yval) write(*,'(i5,2g12.4,3g14.6)')ip,xc(ip),yc(ip),urb,vrb,prb end if end do return end subroutine uvprb(grb,ielem,indx,maxnfl,ncofrb,nelem,node,np,prb, & rb,urb,vrb,xc,xval,yc,yval) ! !*****************************************************************************80 ! !! UVPRB evaluates the reduced state variables at a point in an element. ! ! ! Discusion: ! ! The routine is given: ! ! GRB, a set of reduced coefficients, ! IELEM, an element, ! XVAL, YVAL, the coordinates of a point in element IELEM, ! and returns ! URB, VRB, PRB, the values of the velocity and pressure defined ! by GRB at that point. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 11 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! double precision GRB(NCOFRB). ! GRB contains the reduced basis coefficients of the current ! estimate of the state solution. ! ! integer IELEM. ! IELEM is the element in which the point (XVAL,YVAL) lies. ! ! integer INDX(3,NP). ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! integer MAXNFL. ! MAXNFL is the maximum number of equations or coefficients allowed ! for the full system. MAXNFL must be used instead of NEQNFL as ! the leading dimension of certain multi-dimensional arrays. ! ! integer NCOFRB. ! NCOFRB is the number of coefficients needed to determine ! a particular reduced basis function. ! NCOFRB is the sum of NBCRB and NFERB. ! ! integer NELEM. ! NELEM is the number of elements. ! NELEM can be determined as 2*(NX-1)*(NY-1). ! ! integer NODE(6,MAXELM) or NODE(6,NELEM). ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! integer NP. ! NP is the number of nodes used to define the finite element mesh. ! Typically, the mesh is generated as a rectangular array, with ! an odd number of nodes in the horizontal and vertical directions. ! The formula for NP is NP = (2*NX-1)*(2*NY-1). ! ! Output, double precision PRB. ! PRB is the value of the reduced pressure at (XVAL,YVAL). ! ! double precision RB(MAXNFL,MAXCOFRB). ! ! RB is the NEQNFL by NCOFRB array of reduced basis vectors. ! ! RB is generated by computing a finite element solution GFL, ! which is saved for later reference as "GFLRB". ! GFLRB is copied into the first column of RB. ! Then, we compute the first NCOFRB derivatives of GFLRB with ! respect to a parameter. The first derivative ! is stored in column 1 of RB, and so on. ! ! Output, double precision URB. ! URB is the value of the reduced horizontal velocity at (XVAL,YVAL). ! ! Output, double precision VRB. ! VRB is the value of the reduced vertical velocity at (XVAL,YVAL). ! ! double precision XC(NP). ! XC contains the X coordinates of the nodes. ! ! Input, double precision XVAL. ! XVAL is the X coordinate of the point at which the reduced ! solution values are desired. ! ! double precision YC(NP). ! YC contains the Y coordinates of the nodes. ! ! Input, double precision YVAL. ! YVAL is the Y coordinate of the point at which the reduced ! solution values are desired. ! implicit none ! integer maxnfl integer ncofrb integer nelem integer np ! double precision dqdx double precision dqdy double precision dwdx double precision dwdy double precision grb(ncofrb) integer i integer i1 integer i2 integer i3 integer ielem integer indx(3,np) integer ip integer j integer node(6,nelem) double precision pfl double precision prb double precision q double precision rb(maxnfl,ncofrb) double precision ufl double precision urb double precision vfl double precision vrb double precision w double precision xc(np) double precision xval double precision yc(np) double precision yval ! urb = 0.0D+00 vrb = 0.0D+00 prb = 0.0D+00 do i = 1,ncofrb ufl = 0.0D+00 vfl = 0.0D+00 pfl = 0.0D+00 do j = 1,6 ip = node(j,ielem) call qbf(ielem,j,w,dwdx,dwdy,nelem,node,np,xc,xval,yc,yval) i1 = indx(1,ip) ufl = ufl+rb(i1,i)*w i2 = indx(2,ip) vfl = vfl+rb(i2,i)*w i3 = indx(3,ip) if ( 0 < i3 ) then call bsp(q,dqdx,dqdy,ielem,j,nelem,node,np,xc,xval,yc,yval) pfl = pfl+rb(i3,i)*q end if end do urb = urb+grb(i)*ufl vrb = vrb+grb(i)*vfl prb = prb+grb(i)*pfl end do return end subroutine bmpcst ( costb, nparb, splbmp, taubmp, xbl, xbr, ybl, ybr ) ! !*****************************************************************************80 ! !! BMPCST evaluates the cost of the bump control. ! ! ! Discussion: ! ! The bump connects the points (XBL,YBL) and (XBR,YBR). ! ! Compute its "cost" by comparing its slope to the slope of the ! straight line that connects those two points. ! ! COSTB = Integral (XBL <= X <= XBR) (Bump'(X) - Line'(X))**2 dX ! ! Here, Bump(X) represents the function describing the shape ! of the bump, and Line(X) represents the straight line which ! simply joins the two endpoints, (XBL,YBL) and (XBR,YBR). ! ! This integral is approximated by numerical integration. ! ! The interval between XBL and XBR is divided into NPARB+1 ! intervals, over each of which the bump's height is described ! by a spline. ! ! For each such interval, pick NQUAD1 quadrature points, ! evaluate the derivative of the bump function there, and ! subtract the slope of the straight line. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision COSTB, the integral of the difference of the ! derivatives of the straight line joining the two straight line ! line segments of the bottom, and the bump that is ! actually drawn there. This measures the cost of bump control. ! ! Input, integer NPARB, the number of parameters associated with the ! position and shape of the bump. ! If NPARB = 0, the bump is replaced by a flat wall. ! ! Input, double precision SPLBMP(NPARB+2). ! SPLBMP contains the spline coefficients for the bump. ! ! Input, double precision TAUBMP(NPARB+2). ! TAUBMP contains the location of the spline abscissas for ! the bump. There are NPARB+2 of them, because the end values ! of the spline are constrained to have particular values. ! ! Input, double precision XBL, the X coordinate of the left corner ! of the bump. ! ! Input, double precision XBR, the X coordinate of the right corner ! of the bump. ! ! Input, double precision YBL, the Y coordinate of the left corner ! of the bump. ! ! Input, double precision YBR, the Y coordinate of the right corner ! of the bump. ! implicit none ! integer nparb ! integer nquad1 parameter (nquad1 = 5) ! double precision costb double precision cprime integer i integer j double precision slope double precision splbmp(nparb+2) double precision taubmp(nparb+2) double precision wquad1(nquad1) double precision xbl double precision xbr double precision xleft double precision xsiquad(nquad1) double precision xrite double precision xx double precision ybl double precision ybr ! costb = 0.0D+00 if ( nparb == 0 ) then return end if if ( xbr <= xbl ) then return end if ! ! Get the Gauss weights and abscissas for one dimensional quadrature. ! call gquad1(nquad1,wquad1,xsiquad) ! ! Get the slope of the line joining the endpoints of the bump. ! slope = (ybr-ybl) / (xbr-xbl) ! ! Estimate the integral of the square of the difference between ! the slope of the line and the slope of the bump over the ! bump interval. ! do i = 1,nparb+1 xleft = (dble(nparb+2-i)*xbl+dble(i-1)*xbr)/dble(nparb+1) xrite = (dble(nparb+1-i)*xbl+dble(i)*xbr)/dble(nparb+1) do j = 1,nquad1 xx = 0.5D+00 *((1.0D+00 + xsiquad(j))*xrite+(1.0D+00 - xsiquad(j))*xleft) call pqdx(nparb+2,xx,taubmp,cprime,splbmp) costb = costb+0.5D+00 *wquad1(j)*(xrite-xleft)*(cprime-slope)**2 end do end do return end subroutine bmpspl(npar,nparb,nparf,par,splbmp,taubmp,xbl,xbr,ybl,ybr) ! !*****************************************************************************80 ! !! BMPSPL sets up or updates the spline data that describes the bump. ! ! ! Discussion: ! ! It does this for the target parameters and the feasible parameters. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! NPAR Input, integer NPAR. ! The number of parameters. NPAR = NPARF + NPARB + 1. ! The parameters control the shape of the inflow, ! the shape of the bump obstacle, and the strength of the ! flow. ! ! NPARB Input, integer NPARB. ! The number of parameters associated with the position and ! shape of the bump. ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPARF Input, integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! PAR Input, double precision PAR(NPAR). ! PAR is the current estimate for the parameters. ! ! SPLBMP Output, double precision SPLBMP(NPARB+2). ! SPLBMP contains the spline coefficients for the bump. ! ! TAUBMP Output, double precision TAUBMP(NPARB+2). ! TAUBMP contains the location of the spline abscissas for ! the bump. There are NPARB+2 of them, because the end values ! of the spline are constrained to have particular values. ! ! XBL Input, double precision XBL, the X coordinate of the left corner ! of the bump. ! ! XBR Input, double precision XBR, the X coordinate of the right corner ! of the bump. ! ! YBL Input, double precision YBL, the Y coordinate of the left corner ! of the bump. ! ! YBR Input, double precision YBR, the Y coordinate of the right corner ! of the bump. ! implicit none ! integer npar integer nparb integer nparf ! integer i double precision par(npar) double precision splbmp(nparb+2) double precision taubmp(nparb+2) double precision xbl double precision xbr double precision ybl double precision ybr ! if ( nparb <= 0)return ! ! Set up the bump arrays, including: ! ! TAUBMP, containing the abscissas, which never change, ! SPLBMP(I), the location of the bump at abscissa I. ! do i = 1,nparb+2 taubmp(i) = ((nparb+2-i)*xbl+(i-1)*xbr)/dble(nparb+1) end do ! ! Watch out! The indexing of SPLBMP here is technically illegal. ! splbmp(1) = ybl do i = 2,nparb+1 splbmp(i) = par(nparf+i-1) end do splbmp(nparb+2) = ybr return end subroutine bsp(q,dqdx,dqdy,ielem,iq,nelem,node,np,xc,xq,yc,yq) ! !*****************************************************************************80 ! !! BSP evaluates the linear basis functions associated with pressure. ! ! ! Discussion: ! ! Here is a picture of a typical finite element associated with ! pressure: ! ! 2 ! /| ! / | ! / | ! 1---3 ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 22 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision Q, the value of the IQ-th basis ! function at the point with global coordinates (XQ,YQ). ! ! DQDX, ! DQDY Output, double precision DQDX, DQDY, the X and Y ! derivatives of the IQ-th basis function at the point ! with global coordinates (XQ,YQ). ! ! IELEM Input, integer IELEM, the global element number about which ! we are inquiring. ! ! IQ Input, integer IQ, the index of the desired basis ! function. This is also the node of the reference ! triangle which is associated with the basis function. ! ! Basis function IQ is 1 at node IQ, and zero at the ! other two nodes. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NODE Input, integer NODE(6,NELEM). NODE(J,I) is ! the global node number of the J-th node in the I-th ! element. ! ! NP Input, integer NP, the number of nodes. ! ! XC Input, double precision XC(NP), the global X coordinates ! of the element nodes. ! ! XQ Input, double precision XQ, the global X coordinate of ! the point in which we are interested. ! ! Input, double precision YC(NP), the global Y coordinates ! of the element nodes. ! ! Input, double precision YQ, the global Y coordinate of ! the point in which we are interested. ! implicit none ! integer nelem integer np ! double precision q double precision dqdx double precision dqdy double precision d integer i1 integer i2 integer i3 integer ielem integer iq integer iq1 integer iq2 integer iq3 integer node(6,nelem) double precision xc(np) double precision xq double precision yc(np) double precision yq ! if ( iq < 1 .or. 6 < iq ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BSP - Fatal error!' write ( *, * ) ' The requested basis function is IQ = ',iq write ( *, '(a)' ) ' but only values from 1 to 6 are legal.' stop else if ( 4 <= iq .and. iq <= 6) then q = 0.0D+00 dqdx = 0.0D+00 dqdy = 0.0D+00 return end if iq1 = iq iq2 = mod(iq,3)+1 iq3 = mod(iq+1,3)+1 i1 = node(iq1,ielem) i2 = node(iq2,ielem) i3 = node(iq3,ielem) d = (xc(i2)-xc(i1))*(yc(i3)-yc(i1))-(xc(i3)-xc(i1))*(yc(i2)-yc(i1)) dqdx = (yc(i2)-yc(i3))/d dqdy = (xc(i3)-xc(i2))/d q = 1.0D+00 + dqdx*(xq-xc(i1)) + dqdy*(yq-yc(i1)) return end subroutine ch_cap ( c ) ! !*****************************************************************************80 ! !! CH_CAP capitalizes a single character. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! character c integer itemp ! itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end subroutine cavity(ibs,ibump,ifs,iopt,maxopt,maxpar,nbcrb,npar,nparb, & nparf,npe,nx,ny,par,region,reynld,tolnew,tolopt,tolsim,wateb,watep, & wateu,watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) ! !*****************************************************************************80 ! !! CAVITY sets up the standard driven cavity problem. ! ! ! Discussion: ! ! This cavity has a tangential "inflow" along the top. ! ! The strength of the top tangential flow is PAR(1). ! ! Reference: ! ! Janet Peterson, ! The Reduced Basis Method for Incompressible Viscous Flow Calculations, ! SIAM Journal of Scientific and Statistical Computing, ! Volume 10, Number 4, pages 777-786, July 1989. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! integer IBS. ! IBS is the bump shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer IBUMP. ! IBUMP determines where isoparametric elements will be used. ! ! 0, no isoparametric elements will be used. ! The Y coordinates of midside nodes of elements above the ! bump will be recomputed so that the sides are straight. ! ! 1, isoparametric elements will be used only for the ! elements which directly impinge on the bump. ! Midside nodes of nonisoparametric elements above the ! bump will be recomputed so that the sides are straight. ! ! 2, isoparametric elements will be used for all elements ! which are above the bump. All nodes above the bump ! will be equally spaced in the Y direction. ! ! 3, isoparametric elements will be used for all elements. ! All nodes above the bump will be equally spaced in ! the Y direction. ! ! integer IFS. ! IFS is the inflow shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer IOPT(MAXPAR). ! IOPT is used during an optimization. For each parameter I, ! the meaning of IOPT(I) is: ! 0, the parameter value must remain fixed; ! 1, the parameter value may be varied. ! ! integer MAXOPT. ! MAXOPT is the maximum number of optimization steps. ! ! integer MAXPAR. ! MAXPAR is the maximum number of parameters allowed. ! MAXPAR = MAXPARF + MAXPARB + 1. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARB. ! NPARB is the number of parameters associated with the position and ! shape of the bump. ! ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! integer NPE. ! NPE is the number of nodes per element. ! ! integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! ! The number of elements along a line in the X direction is ! NX-1 (or 2*(NX-1) to make a full rectangular strip). ! ! integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! ! The number of elements along a line in the Y direction is ! NY-1 (or 2*(NY-1) to make a full vertical strip). ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! character ( len = 20 ) REGION. ! REGION specifies the flow region. ! ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! double precision REYNLD. ! REYNLD is the current value of the Reynolds number. ! Normally, REYNLD is stored as PARA(NPARF+NPARB+1). ! ! double precision TOLNEW. ! TOLNEW is the convergence tolerance for the Newton iteration. ! ! double precision TOLOPT. ! TOLOPT is the convergence tolerance for the optimization. ! ! double precision TOLSIM. ! TOLSIM is the convergence tolerance for the Picard iteration. ! ! double precision WATEB. ! WATEB is the multiplier of the bump control cost used ! when computing the total cost. ! ! double precision WATEP, WATEU, WATEV. ! ! WATEP, WATEU and WATEV are weights used in computing the ! cost function based on the costs of the flow discrepancy. ! ! double precision XBL. ! XBL is the X coordinate of the left corner of the bump. ! ! double precision XBR. ! XBR is the X coordinate of the right corner of the bump. ! ! double precision XPROF. ! XPROF is the X coordinate at which the profile is measured. ! XPROF should be a grid value! ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YBL. ! YBL is the Y coordinate of the left corner of the bump. ! ! double precision YBR. ! YBR is the Y coordinate of the right corner of the bump. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer maxpar ! integer i integer ibs integer ibump integer ifs integer iopt(maxpar) integer maxopt integer nbcrb integer npar integer nparb integer nparf integer npe integer nx integer ny double precision par(maxpar) character ( len = 20 ) region double precision reynld double precision tolnew double precision tolopt double precision tolsim double precision wateb double precision watep double precision wateu double precision watev double precision xbl double precision xbr double precision xprof double precision xrange double precision ybl double precision ybr double precision yrange ! ibs = 0 ibump = 0 ! ! The "inflow" is modeled by a piecewise constant function. ! ifs = 0 maxopt = 15 nbcrb = 1 nparb = 0 ! ! For our piecewise constant function, we specify one value. ! nparf = 1 npe = 6 ! ! Peterson used a nonuniform mesh with NX = NY=25. ! nx = 11 ny = 11 region = 'cavity' tolnew = 0.0000000001D+00 tolopt = 0.000000001D+00 tolsim = 0.0000000001D+00 wateb = 0.0D+00 wateu = 1.0D+00 watev = 1.0D+00 watep = 0.0D+00 xbl = 0.0D+00 xbr = 0.0D+00 xprof = 0.50 xrange = 1.0D+00 ybl = 0.0D+00 ybr = 0.0D+00 yrange = 1.0D+00 ! ! Set things that depend on other things. ! npar = nparf+nparb+1 do i = 1,nparf iopt(i) = 0 end do do i = nparf+1,nparf+nparb iopt(i) = 0 end do iopt(nparf+nparb+1) = 1 ! ! Set the parameter that determines the tangential flow. ! par(1) = -1.0D+00 ! ! Set the REYNLD value. Here, it is arbitrarily set ! to 5. Peterson worked with values as high as 5000. ! reynld = 5.0D+00 par(2) = reynld return end subroutine cavity2(ibs,ibump,ifs,iopt,maxopt,maxpar,nbcrb,npar,nparb, & nparf,npe,nx,ny,par,region,reynld,tolnew,tolopt, & tolsim,wateb,watep,wateu,watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) ! !*****************************************************************************80 ! !! CAVITY2 sets up the H C Lee driven cavity problem. ! ! ! Discussion: ! ! This cavity has a tangential "inflow" along the top, and another ! along the bottom. ! ! The strength of the top tangential flow is PAR(1), and the ! strength of the bottom tangential flow is PAR(2). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 07 October 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! integer IBS. ! IBS is the bump shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer IBUMP. ! IBUMP determines where isoparametric elements will be used. ! ! 0, no isoparametric elements will be used. ! The Y coordinates of midside nodes of elements above the ! bump will be recomputed so that the sides are straight. ! ! 1, isoparametric elements will be used only for the ! elements which directly impinge on the bump. ! Midside nodes of nonisoparametric elements above the ! bump will be recomputed so that the sides are straight. ! ! 2, isoparametric elements will be used for all elements ! which are above the bump. All nodes above the bump ! will be equally spaced in the Y direction. ! ! 3, isoparametric elements will be used for all elements. ! All nodes above the bump will be equally spaced in ! the Y direction. ! ! integer IFS. ! IFS is the inflow shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer IOPT(MAXPAR). ! IOPT is used during an optimization. For each parameter I, ! the meaning of IOPT(I) is: ! 0, the parameter value must remain fixed; ! 1, the parameter value may be varied. ! ! integer MAXOPT. ! MAXOPT is the maximum number of optimization steps. ! ! integer MAXPAR. ! MAXPAR is the maximum number of parameters allowed. ! MAXPAR = MAXPARF + MAXPARB + 1. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARB. ! NPARB is the number of parameters associated with the position and ! shape of the bump. ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! integer NPE. ! NPE is the number of nodes per element. ! ! integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! The number of elements along a line in the X direction is ! NX-1 (or 2*(NX-1) to make a full rectangular strip). ! ! integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! The number of elements along a line in the Y direction is ! NY-1 (or 2*(NY-1) to make a full vertical strip). ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! character ( len = 20 ) REGION. ! REGION specifies the flow region. ! ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! ! 'cavity2', a driven cavity, 1 unit on each side, open on ! the top and bottom with tangential velocity specifications there. ! ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! double precision REYNLD. ! REYNLD is the current value of the Reynolds number. ! Normally, REYNLD is stored as PARA(NPARF+NPARB+1). ! ! double precision TOLNEW. ! TOLNEW is the convergence tolerance for the Newton iteration. ! ! double precision TOLOPT. ! TOLOPT is the convergence tolerance for the optimization. ! ! double precision TOLSIM. ! TOLSIM is the convergence tolerance for the Picard iteration. ! ! double precision WATEB. ! WATEB is the multiplier of the bump control cost used ! when computing the total cost. ! ! double precision WATEP, WATEU, WATEV. ! WATEP, WATEU and WATEV are weights used in computing the ! cost function based on the costs of the flow discrepancy. ! ! double precision XBL. ! XBL is the X coordinate of the left corner of the bump. ! ! double precision XBR. ! XBR is the X coordinate of the right corner of the bump. ! ! double precision XPROF. ! XPROF is the X coordinate at which the profile is measured. ! XPROF should be a grid value! ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YBL. ! YBL is the Y coordinate of the left corner of the bump. ! ! double precision YBR. ! YBR is the Y coordinate of the right corner of the bump. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer maxpar ! integer i integer ibs integer ibump integer ifs integer iopt(maxpar) integer maxopt integer nbcrb integer npar integer nparb integer nparf integer npe integer nx integer ny double precision par(maxpar) character ( len = 20 ) region double precision reynld double precision tolnew double precision tolopt double precision tolsim double precision wateb double precision watep double precision wateu double precision watev double precision xbl double precision xbr double precision xprof double precision xrange double precision ybl double precision ybr double precision yrange ! ibs = 0 ibump = 0 ! ! The "inflow" is modeled by a piecewise constant function. ! ifs = 0 maxopt = 15 nbcrb = 1 nparb = 0 ! ! For our piecewise constant boundary flow functions, we specify one value each, ! top and bottom. ! nparf = 2 npe = 6 ! ! Peterson used a nonuniform mesh with NX = NY=25. ! nx = 11 ny = 11 region = 'cavity2' tolnew = 0.0000000001 tolopt = 0.000000001 tolsim = 0.0000000001 wateb = 0.0D+00 wateu = 1.0D+00 watev = 1.0D+00 watep = 0.0D+00 xbl = 0.0D+00 xbr = 0.0D+00 xprof = 0.50 xrange = 1.0D+00 ybl = 0.0D+00 ybr = 0.0D+00 yrange = 1.0D+00 ! ! Set things that depend on other things. ! npar = nparf+nparb+1 do i = 1,nparf iopt(i) = 0 end do do i = nparf+1,nparf+nparb iopt(i) = 0 end do iopt(nparf+nparb+1) = 1 ! ! Set the parameters that determine the tangential flows. ! par(1) = -1.0D+00 par(2) = -1.0D+00 ! ! Set the REYNLD value. Here, it is arbitrarily set ! to 5. Peterson worked with values as high as 5000. ! reynld = 5.0D+00 par(3) = reynld return end subroutine channl(ibs,ibump,ifs,iopt,maxopt,maxpar,nbcrb,npar,nparb, & nparf,npe,nx,ny,par,region,reynld,tolnew,tolopt,tolsim,wateb,watep, & wateu,watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) ! !*****************************************************************************80 ! !! CHANNL sets up the standard channel problem. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! integer IBS. ! IBS is the bump shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer IBUMP. ! IBUMP determines where isoparametric elements will be used. ! 0, no isoparametric elements will be used. ! The Y coordinates of midside nodes of elements above the ! bump will be recomputed so that the sides are straight. ! 1, isoparametric elements will be used only for the ! elements which directly impinge on the bump. ! Midside nodes of nonisoparametric elements above the ! bump will be recomputed so that the sides are straight. ! 2, isoparametric elements will be used for all elements ! which are above the bump. All nodes above the bump ! will be equally spaced in the Y direction. ! 3, isoparametric elements will be used for all elements. ! All nodes above the bump will be equally spaced in ! the Y direction. ! ! integer IFS. ! IFS is the inflow shape option. ! 0, piecewise constant function. ! 1, piecewise linear function. ! 2, piecewise quadratic function. ! ! integer IOPT(MAXPAR). ! IOPT is used during an optimization. For each parameter I, ! the meaning of IOPT(I) is: ! 0, the parameter value must remain fixed; ! 1, the parameter value may be varied. ! ! integer MAXOPT. ! MAXOPT is the maximum number of optimization steps. ! ! integer MAXPAR. ! MAXPAR is the maximum number of parameters allowed. ! MAXPAR = MAXPARF + MAXPARB + 1. ! ! integer NBCRB. ! NBCRB is the number of independent boundary condition ! vectors used for the reduced basis. NBCRB is normally ! at least 1, and must be no more than MAXBCRB. ! ! integer NPAR. ! NPAR is the number of parameters. ! NPAR = NPARF + NPARB + 1. ! The parameters control the shape and strength of the inflow, ! the shape of the bump, and the value of the Reynolds number. ! ! integer NPARB. ! NPARB is the number of parameters associated with the position and ! shape of the bump. ! ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! integer NPARF. ! NPARF is the number of parameters associated with the ! inflow. NPARF must be at least 1. ! ! integer NPE. ! NPE is the number of nodes per element. ! ! integer NX. ! NX controls the spacing of nodes and elements in ! the X direction. There are 2*NX-1 nodes along various ! lines in the X direction. ! The number of elements along a line in the X direction is ! NX-1 (or 2*(NX-1) to make a full rectangular strip). ! ! integer NY. ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! The number of elements along a line in the Y direction is ! NY-1 (or 2*(NY-1) to make a full vertical strip). ! ! double precision PAR(NPAR). ! PAR contains the values of the problem parameters. ! PAR(1:NPARF) = inflow controls. ! PAR(NPARF+1:NPARF+NPARB) = bump controls. ! PAR(NPARF+NPARB+1) = the REYNLD parameter. ! ! character ( len = 20 ) REGION. ! REGION specifies the flow region. ! 'cavity', a driven cavity, 1 unit on each side, open on ! the top with a tangential velocity specification there. ! 'channel', a channel, 10 units long by 3 high, inflow on ! the left, outflow on the right, with a bump on the bottom. ! 'step', a channel, 12 units long by 3 high, inflow on the ! left, outflow on the right, with a step on the bottom. ! ! double precision REYNLD. ! REYNLD is the current value of the Reynolds number. ! Normally, REYNLD is stored as PARA(NPARF+NPARB+1). ! ! double precision TOLNEW. ! TOLNEW is the convergence tolerance for the Newton iteration. ! ! double precision TOLOPT. ! TOLOPT is the convergence tolerance for the optimization. ! ! double precision TOLSIM. ! TOLSIM is the convergence tolerance for the Picard iteration. ! ! double precision WATEB. ! WATEB is the multiplier of the bump control cost used ! when computing the total cost. ! ! double precision WATEP, WATEU, WATEV. ! WATEP, WATEU and WATEV are weights used in computing the ! cost function based on the costs of the flow discrepancy. ! ! double precision XBL. ! XBL is the X coordinate of the left corner of the bump. ! ! double precision XBR. ! XBR is the X coordinate of the right corner of the bump. ! ! double precision XPROF. ! XPROF is the X coordinate at which the profile is measured. ! XPROF should be a grid value! ! ! double precision XRANGE. ! XRANGE is the total width of the region. ! ! double precision YBL. ! YBL is the Y coordinate of the left corner of the bump. ! ! double precision YBR. ! YBR is the Y coordinate of the right corner of the bump. ! ! double precision YRANGE. ! YRANGE is the total height of the region. ! implicit none ! integer maxpar ! integer i integer ibs integer ibump integer ifs integer iopt(maxpar) integer maxopt integer nbcrb integer npar integer nparb integer nparf integer npe integer nx integer ny double precision par(maxpar) character ( len = 20 ) region double precision reynld double precision tolnew double precision tolopt double precision tolsim double precision wateb double precision watep double precision wateu double precision watev double precision xbl double precision xbr double precision xprof double precision xrange double precision ybl double precision ybr double precision yrange ! ibs = 2 ibump = 2 ifs = 2 maxopt = 10 nbcrb = 1 nparb = 3 nparf = 1 npe = 6 nx = 11 ny = 4 region = 'channel' tolnew = 0.0000000001 tolopt = 0.000000001 tolsim = 0.0000000001 wateb = 0.0D+00 wateu = 1.0D+00 watev = 1.0D+00 watep = 0.0D+00 xbl = 1.0D+00 xbr = 3.0D+00 xprof = 3.0D+00 xrange = 10.0D+00 ybl = 0.0D+00 ybr = 0.0D+00 yrange = 3.0D+00 ! ! Set things that depend on other things. ! npar = nparf+nparb+1 do i = 1,nparf iopt(i) = 1 end do do i = nparf+1,nparf+nparb iopt(i) = 1 end do iopt(nparf+nparb+1) = 1 par(1) = 0.5 par(2) = 0.375 par(3) = 0.5 par(4) = 0.375 reynld = 1.0D+00 par(5) = reynld return end subroutine chrctd(string,dval,ierror,lchar) ! !*****************************************************************************80 ! !! CHRCTD accepts a string of characters, and tries to extract a ! double precision real number from the initial part of the ! string. ! ! CHRCTD will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 final comma, ! ! with most quantities optional. ! ! Example: ! ! STRING DVAL ! ! '1' 1.0D+00 ! ' 1 ' 1.0D+00 ! '1A' 1.0D+00 ! '12,34,56' 12.0D+00 ! ' 34 7' 34.0D+00 ! '-1E2ABCD' -100.0D+00 ! '-1X2ABCD' -1.0D+00 ! ' 2E-1' 0.2 ! '23.45' 23.45 ! '-4.2E+2' -420.0D+00 ! '17d2' 1700.0D+00 ! '-14e-2' -0.14 ! 'e2' 100.0D+00 ! '-12.73e-9.23' -12.73 * 10.0D+00 **(-9.23) ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! STRING Input, character ( len = * ) STRING, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! DVAL Output, double precision DVAL, the value that was read ! from the string. ! ! IERROR Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! ! 1, 2, 6 or 7, the input number was garbled. The ! value of IERROR is the last type of input successfully ! read. For instance, 1 means initial blanks, 2 means ! a plus or minus sign, and so on. ! ! LCHAR Output, integer LCHAR, the number of characters read from ! STRING to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none ! character chrtmp double precision dval integer ierror integer ihave integer isgn integer iterm integer jbot integer jsgn integer jtop integer lchar logical s_eqi integer nchar integer ndig double precision rbot double precision rexp double precision rtop character ( len = * ) string ! nchar = len(string) ierror = 0 dval = 0.0D+00 lchar = -1 isgn = 1 rtop = 0.0D+00 rbot = 1.0D+00 jsgn = 1 jtop = 0 jbot = 1 ihave = 1 iterm = 0 10 continue lchar = lchar+1 chrtmp = string(lchar+1:lchar+1) ! ! Blank character. ! if ( chrtmp == ' ') then if ( ihave == 2 .or. ihave .eq. 6 .or. ihave .eq. 7 ) then iterm = 1 else if ( 1 < ihave ) then ihave = 11 end if ! ! Comma ! else if ( chrtmp == ',') then if ( ihave /= 1) then iterm = 1 ihave = 12 lchar = lchar+1 end if ! ! Minus sign. ! else if ( chrtmp == '-') then if ( ihave == 1) then ihave = 2 isgn = -1 else if ( ihave == 6) then ihave = 7 jsgn = -1 else iterm = 1 end if ! ! Plus sign. ! else if ( chrtmp == '+') then if ( ihave == 1) then ihave = 2 else if ( ihave == 6) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( chrtmp == '.') then if ( ihave < 4) then ihave = 4 else if ( 6 <= ihave .and. ihave <= 8 ) then ihave = 9 else iterm = 1 end if ! ! Exponent marker. ! else if ( s_eqi ( chrtmp,'e').or.s_eqi ( chrtmp,'d') ) then if ( ihave < 6) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ihave < 11.and.lge(chrtmp,'0').and.lle(chrtmp,'9') ) then if ( ihave <= 2) then ihave = 3 else if ( ihave == 4) then ihave = 5 else if ( ihave == 6.or.ihave.eq.7) then ihave = 8 else if ( ihave == 9) then ihave = 10 end if read(chrtmp,'(i1)')ndig if ( ihave == 3) then rtop = 10*rtop+ndig else if ( ihave == 5) then rtop = 10*rtop+ndig rbot = 10*rbot else if ( ihave == 8) then jtop = 10*jtop+ndig else if ( ihave == 10) then jtop = 10*jtop+ndig jbot = 10*jbot end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if ! ! If we haven't seen a terminator, and we haven't examined the ! entire string, go get the next character. ! if ( iterm /= 1.and.lchar+1 < nchar)go to 10 ! ! If we haven't seen a terminator, and we have examined the ! entire string, then we're done, and LCHAR is equal to NCHAR. ! if ( iterm /= 1.and.lchar+1 == nchar)lchar=nchar ! ! Number seems to have terminated. Have we got a legal number? ! Not if we terminated in states 1, 2, 6 or 7! ! if ( ihave == 1.or.ihave.eq.2.or.ihave.eq.6.or.ihave.eq.7) then ierror = ihave write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHRCTD - Fatal error!' write ( *, '(a)' ) ' Illegal or nonnumeric input!' return end if ! ! Number seems OK. Form it. ! if ( jtop == 0) then rexp = 1.0D+00 else if ( jbot == 1) then rexp = 10.0D+00 **(jsgn*jtop) else rexp = dble(jsgn*jtop) rexp = rexp/dble(jbot) rexp = 10.0D+00 **rexp end if end if dval = dble(isgn)*rexp*rtop/rbot return end subroutine chrcti(string,intval,ierror,lchar) ! !*****************************************************************************80 ! !! CHRCTI accepts a STRING of characters and reads an integer ! from STRING into INTVAL. The STRING must begin with an integer ! but that may be followed by other information. ! ! CHRCTI will read as many characters as possible until it reaches ! the end of the STRING, or encounters a character which cannot be ! part of the number. ! ! Legal input is ! ! blanks, ! initial sign, ! integer part, ! blanks, ! final comma, ! ! with most quantities optional. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! STRING Input, character ( len = * ) STRING, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal integer. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Sample results: ! ! STRING INTVAL ! ! '1' 1 ! ' 1 ' 1 ! '1A' 1 ! '12,34,56' 12 ! ' 34 7' 34 ! '-1E2ABCD' -100 ! '-1X2ABCD' -1 ! ' 2E-1' 0 ! '23.45' 23 ! ! INTVAL Output, integer INTVAL, the integer read from the string. ! ! IERROR Output, integer IERROR, error flag. ! 0 if no errors, ! Value of IHAVE when error occurred otherwise. ! ! LCHAR Output, integer LCHAR, number of characters read from ! STRING to form the number. ! implicit none ! character chrtmp integer ierror integer ihave integer intval integer isgn integer iterm integer itop integer lchar integer nchar integer ndig character ( len = * ) string ! nchar = len(string) ierror = 0 intval = 0 lchar = -1 isgn = 1 itop = 0 ihave = 1 iterm = 0 10 continue lchar = lchar+1 chrtmp = string(lchar+1:lchar+1) if ( chrtmp == ' ') then if ( ihave == 2) then iterm = 1 else if ( ihave == 3) then ihave = 11 end if else if ( chrtmp == ',') then if ( ihave /= 1) then iterm = 1 ihave = 12 lchar = lchar+1 end if else if ( chrtmp == '-') then if ( ihave == 1) then ihave = 2 isgn = -1 else iterm = 1 end if else if ( chrtmp == '+') then if ( ihave == 1) then ihave = 2 else iterm = 1 end if else if ( lge(chrtmp,'0').and.lle(chrtmp,'9').and.ihave < 11) then ihave = 3 read(chrtmp,'(i1)')ndig itop = 10*itop+ndig else iterm = 1 end if if ( iterm /= 1.and.lchar+1 < nchar)go to 10 if ( iterm /= 1.and.lchar+1 == nchar)lchar=nchar ! ! Number seems to have terminated. Have we got a legal number? ! if ( ihave == 1.or.ihave.eq.2) then ierror = ihave write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHRCTI - Fatal error!' write ( *, * ) ' IERROR = ',ierror write ( *, '(a)' ) ' Illegal or nonnumeric input:' write(*,'(a)')string return end if ! ! Number seems OK. Form it. ! intval = isgn*itop return end subroutine chrdb1(string) ! !*****************************************************************************80 ! !! CHRDB1 accepts a string of characters and removes all ! blanks and nulls, left justifying the remainder and padding with ! blanks. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! STRING Input/output, character ( len = * ) STRING, the string to be ! transformed. ! implicit none ! character chrtmp integer i integer j integer nchar character ( len = * ) string ! nchar = len(string) j = 0 do i = 1,nchar chrtmp = string(i:i) string(i:i) = ' ' if ( chrtmp /= ' '.and.chrtmp.ne.char(0)) then j = j+1 string(j:j) = chrtmp end if end do return end subroutine chrup2(string,strng2,strng3) ! !*****************************************************************************80 ! !! CHRUP2 copies STRING into STRNG2, up to, but not including, the ! first occurrence of the string STRNG3. Setting STRING = 'ABCDEFGH' ! and STRNG3 = 'EF' results in STRNG2='ABCD'. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! STRING Input, character ( len = * ) STRING, the string to be copied. ! ! STRNG2 Output, character ( len = * ) STRNG2, the copied portion of ! STRING. ! ! STRNG3 Input, character ( len = * ) STRNG3, the 'flag' string at which ! the copy stops. ! implicit none ! integer i integer len1 integer len2 integer len3 character ( len = * ) string character ( len = * ) strng2 character ( len = * ) strng3 ! len1 = len(string) len2 = len(strng2) len3 = len(strng3) strng2 = ' ' i = 0 10 continue i = i+1 if ( len1 < i ) then return end if if ( len2 < i ) then return end if if ( i+len3-1 <= len1) then if ( string(i:i+len3-1) == strng3)return end if strng2(i:i) = string(i:i) go to 10 end subroutine ddetfl(afl,detlog,detman,ipivfl,lda,neqnfl,ml,mu) ! !*****************************************************************************80 ! !! DDETFL computes the determinant of a matrix factored by DFACFL. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 13 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision AFL(LDA,N). ! AFL contains the matrix as factored by DFACFL. ! ! Output, double precision DETLOG. ! DETLOG is the integer part of the log base 10 of the determinant ! of the matrix. ! ! Output, double precision DETMAN. ! DETMAN is the mantissa of the determinant of the matrix. ! det(AFL) = DETMAN * 10 ** DETLOG. ! ! Output, integer IPIVFL(NEQNFL), the pivot vector. ! ! Input, integer LDA. ! LDA is the leading dimension of AFL. ! LDA must be at least 2*ML+MU+1. ! ! Input, integer NEQNFL, the order of the original matrix. ! ! Input, integer ML. ! The number of diagonals below the main diagonal. ! ML must be at least 0, and no greater than NEQNFL. ! ! Input, integer MU. ! The number of diagonals above the main diagonal. ! MU must be at least 0, and no greater than NEQNFL. ! implicit none ! integer lda integer neqnfl ! double precision afl(lda,neqnfl) double precision detlog double precision detman integer i integer ipivfl(neqnfl) integer ml integer mu ! detlog = 0.0D+00 detman = 1.0D+00 ! do i = 1,neqnfl detman = detman*afl(ml+mu+1,i) 10 continue if ( 10.0E+00 < abs ( detman ) ) then detman = detman/10.0D+00 detlog = detlog+1.0D+00 go to 10 end if 20 continue if ( detman /= 0.0.and.abs(detman) < 1.0D+00 ) then detman = detman*10.0D+00 detlog = detlog-1.0D+00 go to 20 end if end do do i = 1,neqnfl if ( ipivfl(i) /= i) then detman = -detman end if end do return end subroutine ddetrb(arb,detlog,detman,ipivrb,maxcofrb,ncofrb) ! !*****************************************************************************80 ! !! DDETRB computes the determinant of a matrix factored by DFACRB. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 13 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! ARB Input, double precision ARB(MAXNRB,NCOFRB). ! ARB contains the matrix as factored by DFACFL. ! ! DETLOG Output, double precision DETLOG. ! DETLOG is the integer part of the log base 10 of the determinant ! of the matrix. ! ! DETMAN Output, double precision DETMAN ! DETMAN is the mantissa of the determinant of the matrix. ! det(ARB) = DETMAN * 10 ** DETLOG. ! ! IPIVRB Input, integer IPIVRB(NCOFRB). ! The pivot vector. ! ! MAXNRB Input, integer MAXNRB. ! The leading dimension of the array ARB. ! ! NCOFRB Input, integer NCOFRB. ! The order of the original matrix. ! implicit none ! integer maxcofrb integer ncofrb ! double precision arb(maxcofrb,ncofrb) double precision detlog double precision detman integer i integer ipivrb(ncofrb) ! detlog = 0.0D+00 detman = 1.0D+00 ! do i = 1,ncofrb detman = detman*arb(i,i) 10 continue if ( 10.0E+00 < abs(detman) ) then detman = detman/10.0D+00 detlog = detlog+1.0D+00 go to 10 end if 20 continue if ( detman /= 0.0.and.abs(detman) < 1.0D+00 ) then detman = detman*10.0D+00 detlog = detlog-1.0D+00 go to 20 end if end do do i = 1,ncofrb if ( ipivrb(i) /= i) then detman = -detman end if end do return end subroutine delhms ( time1, time2, nsec ) ! !*****************************************************************************80 ! !! DELHMS returns the number of seconds between TIME1 and TIME2. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 04 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character*10 TIME1, TIME2, two times, in decimal seconds, ! represented as character strings. ! ! Output, integer NSEC, the number of elapsed seconds. ! integer nsec real rsec1 real rsec2 character ( len = 10 ) time1 character ( len = 10 ) time2 ! read ( time1, '(f10.3)' ) rsec1 read ( time2, '(f10.3)' ) rsec2 nsec = int ( rsec2 - rsec2 ) return end subroutine dfacfl(afl,lda,n,ml,mu,ipivfl,info) ! !*****************************************************************************80 ! !! DFACFL factors a double precision band matrix by elimination. ! ! ! Discussion: ! ! DFACFL is a simplified version of the LINPACK routine DGBFA. ! ! In order to use DFACFL, it is necessary to store the matrix AFL ! in "LINPACK General Band Storage" format. ! ! If AFL is a band matrix, the following program segment ! will set up the compressed matrix properly: ! ! m = ml+mu+1 ! do j = 1,n ! i1 = max(1,j-mu) ! i2 = min(n,j+ml) ! do i = i1,i2 ! k = i-j+m ! afl(k,j) = Entry I, J ! end do ! end do ! ! This uses rows ML+1 through 2*ML+MU+1 of the array AFL. ! In addition, the first ML rows in ABD are used for ! elements generated during the triangularization because of pivoting. ! The total number of rows needed in AFL is 2*ML+MU+1. ! The ML+MU by ML+MU upper left triangle and the ! ML by ML lower right triangle are not referenced. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 22 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! AFL Input/output, double precision AFL(LDA,N). ! On input, AFL contains the matrix in band storage. The ! columns of the matrix are stored in the columns of AFL and ! the diagonals of the matrix are stored in rows ! ML+1 through 2*ML+MU+1 of AFL. ! ! On output, an upper triangular matrix in band storage and ! the multipliers which were used to obtain it. ! The factorization can be written AFL = L*U where ! L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! LDA Input, integer LDA. ! The leading dimension of the array AFL. ! LDA must be at least 2*ML+MU+1. ! ! N Input, integer N. ! The order of the original matrix. ! ! ML Input, integer ML. ! The number of diagonals below the main diagonal. ! ML must be at least 0, and no greater than N. ! ! MU Input, integer MU. ! The number of diagonals above the main diagonal. ! MU must be at least 0, and no greater than N. ! ! IPIVFL Output, integer IPIVFL(N). ! An integer vector of pivot indices needed by DSOLFL. ! ! INFO Output, integer INFO. ! = 0 normal value. ! = K if U(K,K) == 0.0. In this case, the matrix is exactly ! numerically singular, and DSOLFL should not be called to attempt ! a linear solution. ! implicit none ! integer lda integer n ! double precision afl(lda,n) integer i integer i0 integer info integer ipivfl(n) integer j integer j1 integer ju integer jz integer k integer l integer lm integer m integer ml integer mm integer mu double precision t ! m = ml+mu+1 info = 0 ! ! Zero out the initial fill-in columns of the matrix. ! j1 = min(n,m)-1 do jz = mu+2,j1 i0 = m+1-jz do i = i0,ml afl(i,jz) = 0.0D+00 end do end do jz = j1 ju = 0 ! ! Carry out Gaussian elimination with partial pivoting ! do k = 1,n-1 ! ! Zero out the next fill-in column. ! jz = jz+1 if ( jz <= n) then do i = 1,ml afl(i,jz) = 0.0D+00 end do end if ! ! Find L = pivot index ! lm = min(ml,n-k) l = m do i = m+1,m+lm if ( abs(afl(l,k)) < abs(afl(i,k)) ) then l = i end if end do ipivfl(k) = l+k-m ! ! A zero pivot means the matrix is singular. ! if ( afl(l,k) == 0.0D+00 ) then info = k else ! ! Interchange rows unless the pivot row is already on the diagonal. ! if ( l /= m) then t = afl(l,k) afl(l,k) = afl(m,k) afl(m,k) = t end if ! ! Compute the multipliers that form the lower diagonal entries of ! the L factor. ! do i = m+1,m+lm afl(i,k) = -afl(i,k)/afl(m,k) end do ! ! Row elimination with column indexing. ! ju = max(ju,mu+ipivfl(k)) ju = min(ju,n) mm = m do j = k+1,ju l = l-1 mm = mm-1 t = afl(l,j) if ( l /= mm) then afl(l,j) = afl(mm,j) afl(mm,j) = t end if do i = 1,lm afl(mm+i,j) = afl(mm+i,j)+afl(m+i,k)*t end do end do end if end do ipivfl(n) = n if ( afl(m,n) == 0.0D+00 ) then info = n end if return end subroutine dfacrb(a,lda,n,ipivot,info) ! !*****************************************************************************80 ! !! DFACRB factors a double precision dense matrix. ! ! ! Discussion: ! ! DFACRB is similar to the LINPACK routine DGEFA, but does not call ! any subroutines or functions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 August 1996. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, double precision A(LDA,N). ! ! On input, A contains the N by N matrix to be factored. ! ! On output, A contains the L and U factors of the matrix, in ! compressed storage. ! ! Input, integer LDA, the leading dimension of A. ! LDA may be larger than N, but must not be smaller than N. ! ! Input, integer N, the order of the matrix. ! ! Output, integer IPIVOT(N), the pivot array. ! ! Output, integer INFO, an error flag. ! ! INFO = 0, no error, the matrix was factored. ! INFO = K, the K-th pivot U(K,K) was zero. ! implicit none ! integer lda integer n ! double precision a(lda,n) integer i integer info integer ipivot(n) integer j integer k integer l double precision t ! info = 0 do k = 1,n-1 ! ! Find the pivot row L. ! l = k do i = k+1,n if ( abs(a(i,l)) < abs(a(i,k)) ) then l = i end if end do ipivot(k) = l ! ! Check for a zero pivot. ! if ( a(l,k) == 0.0D+00 ) then info = k return end if ! ! Check to see whether we must swap rows L and K. ! if ( l /= k) then t = a(l,k) a(l,k) = a(k,k) a(k,k) = t end if ! ! Rescale the pivot row so that A(K,K) = 1. ! do i = k+1,n a(i,k) = -a(i,k)/a(k,k) end do ! ! Wipe out the entries below A(K,K). ! do j = k+1,n t = a(l,j) if ( l /= k) then a(l,j) = a(k,j) a(k,j) = t end if do i = k+1,n a(i,j) = a(i,j)+t*a(i,k) end do end do end do ipivot(n) = n if ( a(n,n) == 0.0D+00 ) then info = n end if return end subroutine difset ( difcof, h, iwrite, ncof ) ! !*****************************************************************************80 ! !! DIFSET computes the NCOF coefficients for a centered finite difference ! estimate of the (NCOF-1)-th derivative of a function. ! ! ! The estimate has the form ! ! FDIF(NCOF-1,X) = Sum (I=1 to NCOF) COF(I) * F(X(I)) ! ! To understand the computation of the coefficients, it is enough ! to realize that the first difference approximation is ! ! FDIF(1,X) = F(X+DX) - F(X-DX) ) / (2*DX) ! ! and that the second difference approximation can be regarded as ! the first difference approximation repeated: ! ! FDIF(2,X) = FDIF(1,X+DX) - FDIF(1,X-DX) / (2*DX) ! = F(X+2*DX) - 2 F(X) + F(X-2*DX) / (4*DX) ! ! and so on for higher order differences. ! ! Thus, the next thing to consider is the integer coefficients of ! the sampled values of F, which are clearly the Pascal coefficients, ! but with an alternating negative sign. In particular, if we ! consider row I of Pascal's triangle to have entries J = 0 through I, ! then P(I,J) = P(I-1,J-1) - P(I-1,J), where P(*,-1) is taken to be 0, ! and P(0,0) = 1. ! ! 1 ! -1 1 ! 1 -2 1 ! -1 3 -3 1 ! 1 -4 6 -4 1 ! -1 5 -10 10 -5 1 ! 1 -6 15 -20 15 -6 1 ! ! Next, we note that the denominator of the approximation for the ! I-th derivative will be (2*DX)**I. ! ! And finally, we must consider the location of the NDIF sampling ! points for F: ! ! X-NDIF*DX, X-(NDIF-2)*DX, X-(NDIF-4)*DX, ..., ! X+(NDIF-4)*DX, X+(NDIF-2*DX), X+(NDIF-1)*DX. ! ! ! Thus, a formula for evaluating FDIF(NDIF,X) is ! ! fdif = 0.0D+00 ! ncof = ndif+1 ! do i = 1,ncof ! xi = x+(2*(i-1)-ncof)*h ! fdif = fdif+difcof(i)*f(xi) ! end do ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! DIFCOF Output, real DIFCOF(NCOF), the coefficients needed to approximate ! the (NCOF-1)-th derivative of a function F. ! ! H Input, real H, the half spacing between points. H must ! be positive. ! ! NCOF Input, integer NCOF. ! NCOF is the number of coefficients desired, which also ! determines NDIF = NCOF-1, the derivative being estimated. ! implicit none ! integer ncof ! double precision difcof(ncof) double precision h integer i integer iwrite integer j integer ndif ! ndif = ncof-1 if ( ndif < 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIFSET - Fatal error!' write ( *, * ) ' Derivative order NDIF = ',ndif write ( *, '(a)' ) ' but NDIF must be at least 0.' stop end if if ( h <= 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIFSET - Fatal error!' write ( *, * ) ' The half sampling spacing is H = ',H write ( *, '(a)' ) ' but H must be positive.' stop end if do i = 1,ncof difcof(i) = 1.0D+00 do j = i-1,2,-1 difcof(j) = -difcof(j)+difcof(j-1) end do if ( 1 < i ) then difcof(1) = -difcof(1) end if end do if ( 2 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIFSET - Unnormalized coefficients:' do i = 1,ncof write(*,'(i6,g14.6)')i,difcof(i) end do end if do i = 1,ncof difcof(i) = difcof(i)/(2.0D+00 *h)**ndif end do if ( 2 <= iwrite ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIFSET - Normalized coefficients:' do i = 1,ncof write(*,'(i6,g14.6)')i,difcof(i) end do end if return end subroutine discst(costp,costu,costv,gfl,gfltar,indx,neqnfl,np,nprof,ny,yc) ! !*****************************************************************************80 ! !! DISCST computes the discrepancy integrals for the pressure, ! horizontal and vertical velocities, along the profile line. ! ! Discussion: ! ! This integration scheme assumes that the profile line, and ! the element sides that define it, are straight. Otherwise, ! the integration scheme used is not correct. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 01 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! COSTP Output, double precision COSTP. ! ! The integral of the difference between ! the computed and target pressure functions along the ! profile line. ! ! COSTU Output, double precision COSTU. ! ! The integral of the difference between ! the computed and target horizontal velocity functions along ! the profile line. ! ! COSTV Output, double precision COSTV. ! ! The integral of the difference between ! the computed and target vertical velocity functions along ! the profile line. ! ! GFL Input, double precision GFL(NEQNFL), the current solution ! estimate for the full problem. ! ! GTARFL Input, double precision GTARFL(NEQNFL), the target solution vector. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! NEQNFL Input, integer NEQNFL, the number of equations in the full system. ! ! NP Input, integer NP, the number of nodes used to define the finite ! element mesh. NP = (2*NX-1)*(2*NY-1). ! ! NPROF Input, integer NPROF(2*MAXNY-1). ! ! NPROF contains the numbers of the nodes along the profile ! line. ! ! NY Input, integer NY. ! ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! ! YC Input, double precision YC(NP), the Y coordinates of the nodes. ! implicit none ! integer nquad1 ! parameter (nquad1 = 5) ! integer neqnfl integer np integer ny ! double precision bval double precision costp double precision costu double precision costv double precision gfl(neqnfl) double precision gfltar(neqnfl) integer i integer ii integer indx(3,np) integer j integer k integer npol integer nprof(2*ny-1) double precision pcof(2) double precision pval double precision ucof(3) double precision uval double precision vcof(3) double precision vval double precision wquad1(nquad1) double precision xsiquad(nquad1) double precision yc(np) double precision yhi double precision ylo double precision ypol(3) double precision yval ! ! Get the weights and abscissas to approximate a line integral. ! call gquad1(nquad1,wquad1,xsiquad) ! ! Compute the integral of the difference squared between the ! current velocity and the target values. ! costu = 0.0D+00 costv = 0.0D+00 ! ! The line along which we integrate is broken into NY-1 ! subintervals, over each of which, U and V are represented ! by quadratic functions. ! do i = 1,ny-1 ! ! Get the values of U and V at the beginning, middle, and ! end of the subinterval. Use these to compute the quadratic ! representation of U and V for any point on the subinterval. ! ylo = yc(nprof(2*i-1)) yhi = yc(nprof(2*i+1)) npol = 3 do k = 1,npol ii = 2*i-2+k ypol(k) = yc(nprof(ii)) j = indx(1,nprof(ii)) ucof(k) = gfl(j)-gfltar(j) j = indx(2,nprof(ii)) vcof(k) = gfl(j)-gfltar(j) end do ! ! Evaluate the discrepancy at each quadrature point. ! do j = 1,nquad1 yval = 0.5D+00 *((1.0D+00 + xsiquad(j))*ylo+(1.0D+00 -xsiquad(j))*yhi) uval = 0.0D+00 vval = 0.0D+00 do k = 1,npol call lbase(k,npol,bval,ypol,yval) uval = uval+bval*ucof(k) vval = vval+bval*vcof(k) end do costu = costu+0.5D+00 *wquad1(j)*(yhi-ylo)*uval**2 costv = costv+0.5D+00 *wquad1(j)*(yhi-ylo)*vval**2 end do end do ! ! Compute the square root of the integral of the difference ! squared between the current pressure and the target values. ! costp = 0.0D+00 do i = 1,ny-1 ylo = yc(nprof(2*i-1)) yhi = yc(nprof(2*i+1)) npol = 2 do k = 1,npol ii = 2*i-3+2*k ypol(k) = yc(nprof(ii)) j = indx(3,nprof(ii)) if ( j <= 0) then pcof(k) = 0.0D+00 else pcof(k) = gfl(j)-gfltar(j) end if end do do j = 1,nquad1 yval = 0.5D+00 *((1.0D+00 + xsiquad(j))*ylo+ (1.0D+00 -xsiquad(j))*yhi) pval = 0.0D+00 do k = 1,npol call lbase(k,npol,bval,ypol,yval) pval = pval+bval*pcof(k) end do costp = costp+0.5D+00 *wquad1(j)*(yhi-ylo)*pval**2 end do end do return end subroutine dsolfl ( afl, lda, n, ml, mu, ipivfl, b ) ! !*****************************************************************************80 ! !! DSOLFL solves a (full) banded linear system. ! ! ! Discussion: ! ! The linear system has the form: ! ! AFL*X = B ! ! where AFL, X, and B are double precision, and AFL is a banded matrix ! which has already been decomposed into LU factors by DFACFL. ! ! DSOLFL is a simplied version of the LINPACK routine DGBSL. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision AFL(LDA,N). ! The factored matrix produced by DFACFL. ! ! Input, integer LDA. ! The leading dimension of the array AFL. ! ! Input, integer N. ! The order of the original matrix. ! ! Input, integer ML. ! The number of diagonals below the main diagonal. ! ! Input, integer MU. ! The number of diagonals above the main diagonal. ! ! Input, integer IPIVFL(N). ! The pivot vector from DFACFL. ! ! Input/output, double precision B(N). ! On input, the right hand side vector. ! On output, the solution vector X. ! implicit none ! integer lda integer n ! double precision afl(lda,n) double precision b(n) integer i integer ipivfl(n) integer k integer l integer la integer lb integer lm integer m integer ml integer mu double precision t ! m = mu+ml+1 ! ! First solve L*Y = B. ! if ( ml /= 0) then do k = 1,n-1 lm = min(ml,n-k) l = ipivfl(k) if ( l /= k) then t = b(l) b(l) = b(k) b(k) = t end if do i = 1,lm b(k+i) = b(k+i)+afl(m+i,k)*b(k) end do end do end if ! ! Now solve U*X = Y. ! do k = n,1,-1 if ( afl(m,k) == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DSOLFL - Fatal error!' write ( *, * ) ' Pivot K = ',k,' is zero.' stop else b(k) = b(k)/afl(m,k) end if lm = min(k,m)-1 la = m-lm lb = k-lm do i = 1,lm b(lb-1+i) = b(lb-1+i)-afl(la-1+i,k)*b(k) end do end do return end subroutine dsolrb ( a, lda, n, ipivot, b ) ! !*****************************************************************************80 ! !! DSOLRB solves a (reduced) dense linear system. ! ! ! Discussion: ! ! The linear system has the form: ! ! A*X = B ! ! where A is a full storage double precision array which has been ! LU-factored by DFACRB. ! ! DSOLRB is similar to the LINPACK routine DGESL, but does not call ! any subroutines or functions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 14 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision A(LDA,N). ! A contains the LU factors of a matrix, as computed by DFACRB. ! ! Input, integer LDA. ! LDA is the leading dimension of the matrix A. ! ! Input, integer N. ! N is the order of the matrix A. ! ! Input, integer IPIVOT(N). ! IPIVOT is the pivot vector computed by DFACRB. ! ! Input/output, double precision B(N). ! On input, B is the right hand side of the linear system. ! On output, B is the solution of the linear system. ! implicit none ! integer lda integer n ! double precision a(lda,n) double precision b(n) integer i integer ipivot(n) integer k integer l double precision t ! ! First solve L*Y = B. ! do k = 1,n-1 l = ipivot(k) t = b(l) if ( l /= k) then b(l) = b(k) b(k) = t end if do i = k+1,n b(i) = b(i)+t*a(i,k) end do end do ! ! Now solve U*X = Y. ! do k = n,1,-1 b(k) = b(k)/a(k,k) t = -b(k) do i = 1,k-1 b(i) = b(i)+t*a(i,k) end do end do return end function dveq(n,dvec1,dvec2) ! !*****************************************************************************80 ! !! DVEQ returns .TRUE. if the N elements of the double precision ! vectors DVEC1 and DVEC2 are equal. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! N Input, integer N, the number of entries in the vectors. ! ! DVEC1, ! DVEC2 Input, double precision DVEC1(N), DVEC2(N), the two vectors ! to be compared. ! ! DVEQ Output, logical DVEQ. ! DVEQ is .TRUE. if all N elements of DVEC1 and DVEC2 are equal, ! and .FALSE. otherwise. ! implicit none ! integer n ! double precision dvec1(n) double precision dvec2(n) logical dveq integer i ! dveq = .false. do i = 1,n if ( dvec1(i) /= dvec2(i))return end do dveq = .true. return end function dvneq(n,dvec1,dvec2) ! !*****************************************************************************80 ! !! DVNEQ returns .TRUE. if any of the N elements of the double precision ! vectors DVEC1 and DVEC2 are not equal. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N. ! N is the number of entries in the vectors. ! ! Input, double precision DVEC1(N), DVEC2(N). ! DVEC1 and DVEC2 are the two vectors to be compared. ! ! Output, logical DVNEQ. ! DVNEQ is .TRUE. if any elements of DVEC1 and DVEC2 differ, ! and .FALSE. otherwise. ! implicit none ! integer n ! double precision dvec1(n) double precision dvec2(n) logical dvneq integer i ! dvneq = .true. do i = 1,n if ( dvec1(i) /= dvec2(i))return end do dvneq = .false. return end subroutine fact(n,factn) ! !*****************************************************************************80 ! !! FACT computes the (real) factorial of a nonnegative integer. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the nonnegative value for which N! ! is desired. ! ! Output, double precision FACTN, the factorial of N. ! implicit none ! double precision factn integer i integer n ! if ( n < 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACT - Fatal error!' write ( *, * ) ' Negative input argument is N = ',n stop end if factn = 1.0D+00 do i = 1,n factn = factn*dble(i) end do return end subroutine getcst(cost,costb,costp,costu,costv,gfl,gfltar,indx,neqnfl,np, & nparb,nprof,ny,splbmp,taubmp,wateb,watep,wateu,watev,xbl,xbr,ybl,ybr,yc) ! !*****************************************************************************80 ! !! GETCST is given the value of the solution, GFL, the target ! solution GTARFL, and information about the shape of the bump, ! and returns the value of the overall and individual cost ! functions. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 August 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! COST Output, double precision COST, the weighted cost. ! ! COSTB Output, double precision COSTB. ! ! COSTB is the integral of the difference of the ! derivatives of the straight line joining the two straight line ! line segments of the bottom, and the bump that is ! actually drawn there. ! ! This measures the cost of bump control. ! ! COSTP Output, double precision COSTP. ! ! The integral of the difference between ! the computed and target pressure functions along the ! profile line. ! ! COSTU Output, double precision COSTU. ! ! The integral of the difference between ! the computed and target horizontal velocity functions along ! the profile line. ! ! COSTV Output, double precision COSTV. ! ! The integral of the difference between ! the computed and target vertical velocity functions along ! the profile line. ! ! GFL Input, double precision GFL(NEQNFL), the current solution ! estimate for the full problem. ! ! GTARFL Input, double precision GTARFL(NEQNFL), the target solution vector. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! NEQNFL Input, integer NEQNFL, the number of equations in the full system. ! ! NP Input, integer NP, the number of nodes used to define the finite ! element mesh. NP = (2*NX-1)*(2*NY-1). ! ! NPARB Input, integer NPARB. ! ! The number of parameters associated with the position and ! shape of the bump. ! ! Note that if NPARB = 0, the bump is replaced by a flat wall. ! ! NPROF Input, integer NPROF(2*MAXNY-1). ! ! NPROF contains the numbers of the nodes along the profile ! line. ! ! NY Input, integer NY. ! ! NY controls the spacing of nodes and elements in ! the Y direction. There are 2*NY-1 nodes along various ! lines in the Y direction. ! ! SPLBMP Input, double precision SPLBMP(NPARB+2). ! ! SPLBMP contains the spline coefficients for the bump. ! ! TAUBMP Input, double precision TAUBMP(NPARB+2). ! ! TAUBMP contains the location of the spline abscissas for ! the bump. There are NPARB+2 of them, because the end values ! of the spline are constrained to have particular values. ! ! WATEB Input, double precision WATEB. ! ! WATEB is the multiplier of the bump control cost used ! when computing the total cost. ! ! WATEP, ! WATEU, ! WATEV Input, double precision WATEP, WATEU, WATEV. ! ! These are weights used in computing the overall cost ! function based on the costs of the flow discrepancy. ! ! XBL Input, double precision XBL, the X coordinate of the left corner ! of the bump. ! ! XBR Input, double precision XBR, the X coordinate of the right corner ! of the bump. ! ! YBL Input, double precision YBL, the Y coordinate of the left corner ! of the bump. ! ! Input, double precision YBR, the Y coordinate of the right corner ! of the bump. ! ! Input, double precision YC(NP), the Y coordinates of the nodes. ! implicit none ! integer neqnfl integer np integer nparb integer ny ! double precision cost double precision costb double precision costp double precision costu double precision costv double precision gfl(neqnfl) double precision gfltar(neqnfl) integer indx(3,np) integer nprof(2*ny-1) double precision splbmp(nparb+2) double precision taubmp(nparb+2) double precision wateb double precision watep double precision wateu double precision watev double precision xbl double precision xbr double precision ybl double precision ybr double precision yc(np) ! call bmpcst(costb,nparb,splbmp,taubmp,xbl,xbr,ybl,ybr) call discst(costp,costu,costv,gfl,gfltar,indx,neqnfl,np,nprof,ny,yc) cost = wateb*costb+watep*costp+wateu*costu+watev*costv return end subroutine gquad1(nquad1,wquad1,xsiquad) !*****************************************************************************80 ! !! GQUAD1 defines a 1 dimensional Gauss quadrature rule. ! ! ! Discussion: ! ! GQUAD1 returns the weights and abscissas for a 1 dimensional, ! 3 or 5 point Gauss quadrature rule defined on the interval [-1,1]. ! ! The integral of a function F(X) over the interval [-1,1] ! ! Integral (-1 to 1) F(X) DX ! ! may then be approximated by ! ! Sum (I = 1 to NQUAD1) WQUAD1(I) * F(XSIQUAD(I)) ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! NQUAD1 Input, integer NQUAD1. ! The user specifies the rule desired by setting NQUAD1 ! to 3 or 5. Any other value is illegal, and will cause ! GQUAD1 to stop. ! ! WQUAD1 Output, double precision WQUAD1(NQUAD1). ! WQUAD1(I) is the weight factor corresponding to the ! I-th quadrature point. ! ! XSIQUAD ! Output, double precision XSIQUAD(NQUAD1). ! XSIQUAD(I) is the I-th quadrature point. ! implicit none ! integer nquad1 ! double precision wquad1(nquad1) double precision xsiquad(nquad1) ! if ( nquad1 == 3) then xsiquad(1) = -0.7745966692 xsiquad(2) = 0.0D+00 xsiquad(3) = 0.7745966692 wquad1(1) = 5.0D+00 / 9.0D+00 wquad1(2) = 8.0D+00 / 9.0D+00 wquad1(3) = 5.0D+00 / 9.0D+00 else if ( nquad1 == 5) then xsiquad(1) = -0.906179845938664D+00 xsiquad(2) = -0.538469310105683D+00 xsiquad(3) = 0.0D+00 xsiquad(4) = 0.538469310105683D+00 xsiquad(5) = 0.906179845938664D+00 wquad1(1) = 0.236926885056189D+00 wquad1(2) = 0.478628670499366D+00 wquad1(3) = 0.568888888888889D+00 wquad1(4) = 0.478628670499366D+00 wquad1(5) = 0.236926885056189D+00 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GQuad1 - Fatal error!' write ( *, '(a)' ) ' An illegal value of NQUAD1 was input.' write ( *, '(a)' ) ' Only NQUAD1 = 3 or 5 are legal.' write ( *, * ) ' The input value was ',nquad1 write ( *, '(a)' ) ' The code is stopping now.' stop end if return end subroutine grid(gridx,i,ihi,ilo,x,xhi,xlo) !*****************************************************************************80 ! !! GRID computes the X or Y coordinate of the I-th gridpoint. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! GRIDX Input, character*20 GRIDX. ! GRIDX tells how the finite element nodes should be layed out ! in the X direction. ! 'uniform' makes them equally spaced. ! 'cos' uses the COS function to cluster them near edges. ! 'sqrtsin' uses the SQRT(SIN()) function to cluster near edges. ! ! I Input, integer I. ! I is the index of the grid point whose X coordinate is to ! be computed. Normally, ILO <= I <= IHI. ! ! IHI, ! ILO Input, integer IHI, ILO. ! ILO is the index of the grid point whose X coordinate is XLO, ! IHI is the same for XHI. ! ! X Output, double precision X. ! X is the X coordinate of the I-th grid point, according to ! the specified scheme. ! ! XHI, ! XLO Input, double precision XHI, XLO. ! XLO is the X coordinate of grid point ILO, and XHI ! is the X coordinate of grid point IHI. ! implicit none ! double precision pi parameter (pi = 3.14159265) ! character ( len = 20 ) gridx integer i integer ihi integer ilo logical s_eqi double precision s double precision theta double precision thi double precision tlo double precision x double precision xhi double precision xlo ! if ( s_eqi ( gridx,'uniform')) then x = (dble(ihi-i)*xlo+dble(i-ilo)*xhi)/dble(ihi-ilo) else if ( s_eqi ( gridx,'sin')) then tlo = -pi/2.0D+00 thi = pi/2.0D+00 theta = (dble(ihi-i)*tlo + dble(i-ilo)*thi)/dble(ihi-ilo) s = sin(theta) x = ((1.0D+00 -s)*xlo+(s+1.0D+00 )*xhi)/2.0D+00 ! ! Equivalent to 'SIN'. ! else if ( s_eqi ( gridx,'cos')) then tlo = -pi thi = 0.0D+00 theta = (dble(ihi-i)*tlo + dble(i-ilo)*thi)/dble(ihi-ilo) x = ((1.0D+00 -cos(theta))*xlo+(1.0D+00 + cos(theta))*xhi)/2.0D+00 else if ( s_eqi ( gridx,'sqrtsin')) then tlo = -pi/2.0D+00 thi = pi/2.0D+00 theta = (dble(ihi-i)*tlo + dble(i-ilo)*thi)/dble(ihi-ilo) if ( 0.0D+00 <= sin(theta) ) then s = sqrt(sin(theta)) else s = -sqrt(-sin(theta)) end if x = ((1.0D+00 -s)*xlo+(s+1.0D+00 )*xhi)/2.0D+00 end if return end subroutine intprs(gfl,indx,nelem,neqnfl,node,np,p) !*****************************************************************************80 ! !! INTPRS interpolates the pressure at the midside nodes. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! GFL Input, double precision GFL(NEQNFL). ! GFL is the current solution estimate for the full problem, ! containing pressure and velocity coefficients. The vector ! INDX must be used to index this data. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the global index of U, ! V and P at that node, or 0 or a negative value. The global ! index of U, V, or P is the index of the coefficient vector ! that contains the value of the finite element coefficient ! associated with the corresponding basis function at the ! given node. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NEQNFL Input, integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! NODE Input, integer NODE(6,MAXELM) or NODE(6,NELEM). ! ! NODE(I,J) contains, for an element J, the global index of ! the node whose local number in J is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! Global nodes Elements NODE ! 1 2 3 4 5 6 ! 74 84 94 3-6-1 2 Left element = (94,72,74,83,73,84) ! | / /| ! 73 83 93 5 4 4 5 Right element = (72,94,92,83,93,82) ! |/ / | ! 72 82 92 2 1-6-3 ! ! NP Input, integer NP, the number of nodes. ! ! P Input, real P(NP), the pressure. ! implicit none ! integer nelem integer neqnfl integer np ! double precision gfl(neqnfl) integer i integer in1 integer in2 integer in3 integer in4 integer in5 integer in6 integer indx(3,np) integer node(6,nelem) double precision p(np) ! ! For each element,... ! do i = 1,nelem ! ! Get the six global node numbers. ! in1 = node(1,i) in2 = node(2,i) in3 = node(3,i) in4 = node(4,i) in5 = node(5,i) in6 = node(6,i) ! ! Read off the three computed values, and average the other three. ! p(in1) = gfl(indx(3,in1)) p(in2) = gfl(indx(3,in2)) p(in3) = gfl(indx(3,in3)) p(in4) = 0.5D+00 *(p(in1)+p(in2)) p(in5) = 0.5D+00 *(p(in2)+p(in3)) p(in6) = 0.5D+00 *(p(in3)+p(in1)) end do return end subroutine l2norm(gfl,gflnrm,indx,nelem,neqnfl,node,np,xc,yc) !*****************************************************************************80 ! !! L2NORM computes the "big" L2 norm of the velocity over the flow region. ! ! ! Discussion: ! ! A 13 point Gauss rule is used. ! ! Note that this is the "BIG L2" norm, that is, the square root ! of the integral of the square of the velocity over the flow region, ! and NOT the "little l2" norm, which is simply the square root of the ! sum of the squares of the coefficients. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! GFL Input, double precision GFL(NEQNFL). ! ! GFL is the current solution vector, in which are stored ! the finite element coefficients that define the velocity ! and pressure functions, U, V and P. ! ! GFLNRM Output, double recision GFLNRM. ! GFLNRM is the approximate value of the square root of ! the integral of the square of the velocity over the ! flow domain. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! NELEM Input, integer NELEM, the number of elements. ! ! NEQNFL Input, integer NEQNFL, the number of finite element equations used ! to define the horizontal and vertical velocities and the ! pressure. ! ! NODE Input, integer NODE(6,NELEM). ! ! NODE(I,J) contains, for an element J, the global node index of ! the element node whose local number is I. ! ! The local ordering of the nodes is suggested by this diagram: ! ! 2 ! /| ! 4 5 ! / | ! 1-6-3 ! ! NP Input, integer NP, the number of nodes used to define the finite ! element mesh. NP = (2*NX-1)*(2*NY-1). ! ! XC Input, double precision XC(NP). ! ! The X coordinates of the nodes. ! ! YC Input, double precision YC(NP). ! ! The Y coordinates of the nodes. ! implicit none ! integer nquad ! parameter (nquad = 13) ! integer nelem integer neqnfl integer np ! double precision area double precision area2 double precision dwdx double precision dwdy double precision eta double precision etaquad(nquad) double precision gfl(neqnfl) double precision gflnrm integer i integer ielem integer in integer indx(3,np) integer ip integer ip1 integer ip2 integer ip3 integer iquad integer jp integer node(6,nelem) double precision u double precision v double precision vmax double precision w double precision wquad(nquad) double precision xc(np) double precision xq double precision xsi double precision xsiquad(nquad) double precision yc(np) double precision yq ! wquad(1) = 0.175615257433204D+00 wquad(2) = 0.175615257433204D+00 wquad(3) = 0.175615257433204D+00 wquad(4) = 0.053347235608839D+00 wquad(5) = 0.053347235608839D+00 wquad(6) = 0.053347235608839D+00 wquad(7) = 0.077113760890257D+00 wquad(8) = 0.077113760890257D+00 wquad(9) = 0.077113760890257D+00 wquad(10) = 0.077113760890257D+00 wquad(11) = 0.077113760890257D+00 wquad(12) = 0.077113760890257D+00 wquad(13) = -0.149570044467670D+00 do i = 1,nquad wquad(i) = wquad(i) / 2.0D+00 end do xsiquad(1) = 0.260345966079038D+00 etaquad(1) = 0.479308067841923D+00 xsiquad(2) = 0.260345966079038D+00 etaquad(2) = 0.260345966079038D+00 xsiquad(3) = 0.479308067841923D+00 etaquad(3) = 0.260345966079038D+00 xsiquad(4) = 0.065130102902216D+00 etaquad(4) = 0.869739794195568D+00 xsiquad(5) = 0.065130102902216D+00 etaquad(5) = 0.065130102902216D+00 xsiquad(6) = 0.869739794195568D+00 etaquad(6) = 0.065130102902216D+00 xsiquad(7) = 0.048690315425316D+00 etaquad(7) = 0.638444188569809D+00 xsiquad(8) = 0.312865496004875D+00 etaquad(8) = 0.638444188569809D+00 xsiquad(9) = 0.048690315425316D+00 etaquad(9) = 0.312865496004875D+00 xsiquad(10) = 0.638444188569809D+00 etaquad(10) = 0.312865496004875D+00 xsiquad(11) = 0.312865496004875D+00 etaquad(11) = 0.048690315425316D+00 xsiquad(12) = 0.638444188569809D+00 etaquad(12) = 0.048690315425316D+00 xsiquad(13) = 1.0D+00 / 3.0D+00 etaquad(13) = 1.0D+00 / 3.0D+00 do i = 1,nquad xsiquad(i) = 1.0D+00 - xsiquad(i) end do gflnrm = 0.0D+00 area2 = 0.0D+00 vmax = 0.0D+00 ! ! Consider an element. ! do ielem = 1,nelem ! ! Compute the area of the element. For now, we assume that all ! elements are triangles, and NOT isoparametric! ! ip1 = node(1,ielem) ip2 = node(2,ielem) ip3 = node(3,ielem) area = abs( & (yc(ip1)+yc(ip2))*(xc(ip2)-xc(ip1)) & +(yc(ip2)+yc(ip3))*(xc(ip3)-xc(ip2)) & +(yc(ip3)+yc(ip1))*(xc(ip1)-xc(ip3)) ) ! ! Evaluate the integrand at the quadrature points. ! do iquad = 1,nquad xsi = xsiquad(iquad) eta = etaquad(iquad) call xofxsi(eta,ielem,nelem,node,np,xq,xc,xsi,yq,yc) ! ! Evaluate U, V and P at the IQUAD-th quadrature point by ! finding the value of each of the 6 basis functions there, ! and multiplying by their respective coefficients. ! u = 0.0D+00 v = 0.0D+00 do in = 1,6 call qbf(ielem,in,w,dwdx,dwdy,nelem,node,np,xc,xq,yc,yq) ip = node(in,ielem) jp = indx(1,ip) u = u+gfl(jp)*w jp = indx(2,ip) v = v+gfl(jp)*w end do gflnrm = gflnrm+area*wquad(iquad)*(u**2+v**2) if ( vmax < u**2 + v**2 ) then vmax = u**2+v**2 end if area2 = area2+area*wquad(iquad) end do end do gflnrm = sqrt(gflnrm) return end subroutine lbase ( ival, npol, pval, xpol, xval ) !*****************************************************************************80 ! !! LBASE evalualates the IVAL-th Lagrange basis polynomial. ! ! ! Discussion: ! ! The Lagrange interpolation basis polynomials are based ! on the NPOL points XPOL. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, the polynomial to evaluate. ! IVAL should be between 1 and NPOL. ! ! Input, integer NPOL, the number of points that define ! the Lagrange polynomials. ! ! Output, double precision PVAL, the value of the IVAL-th ! Lagrange polynomial at the point XVAL. ! ! Input, double precision XPOL(NPOL), the abscissas of the ! Lagrange polynomials. The entries in XPOL should be ! distinct. ! ! Input, double precision XVAL, the point at which the ! IVAL-th Lagrange polynomial is to be evaluated. ! implicit none ! integer npol ! integer i integer ival double precision pval double precision xpol(npol) double precision xval ! pval = 1.0D+00 do i = 1, npol if ( i /= ival ) then pval = pval * ( xval - xpol(i) ) / ( xpol(ival) - xpol(i) ) end if end do return end function s_eqidb(strng1,strng2) !*****************************************************************************80 ! !! S_EQIDB is a case insensitive comparison of two strings for ! equality, ignoring blanks. ! ! Thus, LEQIDB('Nor Way','NORway') is .TRUE. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! STRNG1, ! STRNG2 Input, character*(*) STRNG1, STRNG2, the strings to ! compare. ! ! LEQIDB Output, logical LEQIDB, the result of the comparison. ! integer i1 integer i2 integer len1 integer len2 logical s_eqidb character s1 character s2 character ( len = * ) strng1 character ( len = * ) strng2 ! len1 = len(strng1) len2 = len(strng2) s_eqidb = .false. i1 = 0 i2 = 0 10 continue ! ! If we've matched all the nonblank characters in both strings, ! then return with LEQIDB = .TRUE. ! if ( i1 == len1.and.i2.eq.len2) then s_eqidb = .true. return end if ! ! Get S1, the next nonblank character in the first string. ! 20 continue i1 = i1+1 if ( len1 < i1 ) then return end if if ( strng1(i1:i1) == ' ')go to 20 s1 = strng1(i1:i1) ! ! Get S2, the next nonblank character in the second string. ! 30 continue i2 = i2+1 if ( len2 < i2 ) then return end if if ( strng2(i2:i2) == ' ')go to 30 s2 = strng2(i2:i2) if ( s1 /= s2)return go to 10 end function nbinom(m,n) !*****************************************************************************80 ! !! NBINOM calculates a binomial coefficient. ! ! ! Discussion: ! ! The routine calculates the number of combinations of M things taken N ! at a time. NBINOM is ACM algorithm 160 translated to FORTRAN. ! ! The formula used is ! ! NBINOM = M! / ( N! * (M-N)! ) ! ! This value is calculated in a way that tries to avoid overflow. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M. ! M is the number of objects to choose from in the set, ! or the row of Pascal's triangle in which the coefficient lies. ! M should be zero or greater. ! ! N Input, integer N. ! N is the number of objects selected from the set, ! or the column of Pascal's triangle in which the coefficient ! lies. N should be 0 or greater, and no greater than M. ! ! NBINOM Output, integer NBINOM. ! NBINOM is the number of combinations of M things taken N ! at a time. ! integer i integer m integer n integer n1 integer nbinom ! if ( m < 0 ) then nbinom = 0 return end if if ( n < 0 ) then nbinom = 0 return end if if ( m < n ) then nbinom = 0 return end if if ( n < m-n ) then n1 = m-n else n1 = n end if nbinom = 1 do i = 1, m-n1 nbinom = (nbinom*(n1+i)) / i end do return end subroutine nrmflo ( gfl, indx, neqnfl, np, resfl ) !*****************************************************************************80 ! !! NRMFLO returns norms of a flow solution or flow residual. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! GFL Input, double precision GFL(NEQNFL). ! GFL is the current solution vector, in which are stored ! the finite element coefficients that define the velocity ! and pressure functions, U, V and P. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K), ! and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J, either because ! the variable is specified in some other way, or because ! (in the case of pressure), there is no coefficient associated ! with that node. ! ! NEQNFL Input, integer NEQNFL, the number of finite element equations used ! to define the horizontal and vertical velocities and the ! pressure. ! ! Input, integer NP, the number of nodes. ! implicit none ! integer neqnfl integer np ! double precision anrmf double precision anrmfp double precision anrmfu double precision anrmfv double precision anrmg double precision anrmp double precision anrmu double precision anrmv double precision enrmf double precision enrmfp double precision enrmfu double precision enrmfv double precision enrmg double precision enrmp double precision enrmu double precision enrmv double precision fp double precision fu double precision fv double precision gfl(neqnfl) integer i integer indx(3,np) integer inrmf integer inrmfp integer inrmfu integer inrmfv integer inrmg integer inrmp integer inrmu integer inrmv double precision p double precision resfl(neqnfl) double precision u double precision v ! anrmf = 0.0D+00 anrmfp = 0.0D+00 anrmfu = 0.0D+00 anrmfv = 0.0D+00 anrmg = 0.0D+00 anrmp = 0.0D+00 anrmu = 0.0D+00 anrmv = 0.0D+00 enrmfp = 0.0D+00 enrmf = 0.0D+00 enrmfu = 0.0D+00 enrmfv = 0.0D+00 enrmg = 0.0D+00 enrmp = 0.0D+00 enrmu = 0.0D+00 enrmv = 0.0D+00 inrmf = 1 inrmfp = 1 inrmfu = 1 inrmfv = 1 inrmg = 1 inrmp = 1 inrmu = 1 inrmv = 1 do i = 1,np u = gfl(indx(1,i)) enrmu = enrmu+u**2 enrmg = enrmg+u**2 if ( anrmu < abs(u) ) then anrmu = abs(u) inrmu = i end if if ( anrmg < abs(u) ) then anrmg = abs(u) inrmg = i end if fu = resfl(indx(1,i)) enrmf = enrmf+fu**2 enrmfu = enrmfu+fu**2 if ( anrmf < abs(fu) ) then anrmf = abs(fu) inrmf = i end if if ( anrmfu < abs(fu) ) then anrmfu = abs(fu) inrmfu = i end if v = gfl(indx(2,i)) enrmv = enrmv+v**2 enrmg = enrmg+v**2 if ( anrmv < abs(v) ) then anrmv = abs(v) inrmv = i end if if ( anrmg <= abs(v) ) then anrmg = abs(v) inrmg = i end if fv = resfl(indx(2,i)) enrmf = enrmf+fv**2 enrmfv = enrmfv+fv**2 if ( anrmf < abs(fv) ) then anrmf = abs(fv) inrmf = i end if if ( anrmfv < abs(fv) ) then anrmfv = abs(fv) inrmfv = i end if if ( 0 < indx(3,i) ) then p = gfl(indx(3,i)) enrmp = enrmp+p**2 enrmg = enrmg+p**2 if ( anrmp <= abs(p) ) then inrmp = i anrmp = abs(p) end if if ( anrmg <= abs(p) ) then inrmg = i anrmg = abs(p) end if fp = resfl(indx(3,i)) enrmf = enrmf+fp**2 enrmfp = enrmfp+fp**2 if ( anrmf < abs(fp) ) then inrmf = i anrmf = abs(fp) end if if ( anrmfp < abs(fp) ) then anrmfp = abs(fp) inrmfp = i end if end if end do enrmf = sqrt(enrmf) enrmfp = sqrt(enrmfp) enrmfu = sqrt(enrmfu) enrmfv = sqrt(enrmfv) enrmg = sqrt(enrmg) enrmp = sqrt(enrmp) enrmu = sqrt(enrmu) enrmv = sqrt(enrmv) ! ! Print out results. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' MxNorm Node l2 Norm' write ( *, '(a)' ) ' ' write ( *, '(a,g14.6,i6,g14.6)' ) 'U ', anrmu, inrmu, enrmu write ( *, '(a,g14.6,i6,g14.6)' ) 'V ', anrmv, inrmv, enrmv write ( *, '(a,g14.6,i6,g14.6)' ) 'P ', anrmp, inrmp, enrmp write ( *, '(a,g14.6,i6,g14.6)' ) 'GFL', anrmg, inrmg, enrmg write ( *, '(a,g14.6,i6,g14.6)' ) 'FU ', anrmfu, inrmfu, enrmfu write ( *, '(a,g14.6,i6,g14.6)' ) 'FV ', anrmfv, inrmfv, enrmfv write ( *, '(a,g14.6,i6,g14.6)' ) 'FP ', anrmfp, inrmfp, enrmfp write ( *, '(a,g14.6,i6,g14.6)' ) 'F ', anrmf, inrmf, enrmf return end subroutine pcval ( nvec, xval, xvec, yval, yvec ) !*****************************************************************************80 ! !! PCVAL evaluates a piecewise constant function at a given point. ! ! ! Discussion: ! ! The piecewise constant function is specified as suggested by the ! following graph: ! ! ! Y(2)-> *---------* ! | | ! Y(1)-> *----------* | ! | ! | ! Y(3)-> *---------...... ! ! ^ ^ ^ ! | | | ! X(1) X(2) X(3) ! ! Note that if XVAL falls to the left of XVEC(1), then YVAL = YVEC(1). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise constant function. NVEC must be at ! least 1. ! ! Input, double precision XVAL, the point at which the function ! is to be evaluated. ! ! Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! Output, double precision YVAL, the value of the piecewise ! constant function at the point XVAL. ! ! Input, double precision YVEC(NVEC), the value of the piecewise ! constant function at each of the abscissas. ! implicit none ! integer nvec ! integer i double precision xval double precision xvec(nvec) double precision yval double precision yvec(nvec) ! ! Step 1: Check if XVAL lies outside the intervals. ! if ( xval <= xvec(1)) then yval = yvec(1) return else if ( xvec(nvec) <= xval ) then yval = yvec(nvec) return end if ! ! Step 2: Find index I so that XVEC(I) <= XVAL < XVEC(I+1) ! do i = 1, nvec-1 if ( xvec(i) <= xval .and. xval <= xvec(i+1) ) then yval = xvec(i) return end if end do write ( *, * ) ' ' write ( *, * ) 'PCVal - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ', xval stop end subroutine pldx ( nvec, xval, xvec, yder, yvec ) !*****************************************************************************80 ! !! PLDX evaluates the derivative of a piecewise linear function. ! ! ! Discussion: ! ! Note that if XVAL falls to the left of XVEC(1), then YDER = 0, ! and similarly, if XDER is greater than XVEC(NVEC), YVAL = 0. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise linear. NVEC must be odd, and ! at least 3. ! ! XVAL Input, double precision XVAL, the point at which the ! derivative with respect to X is to be evaluated. ! ! XVEC Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! YDER Output, double precision YDER, the value of the derivative of ! the piecewise linear function with respect to X, at the point ! XVAL. ! ! YVEC Input, double precision YVEC(NVEC), the value of the ! piecewise linear function at each of the abscissas. ! implicit none ! integer nvec ! integer i integer ival double precision xval double precision xvec(nvec) double precision yder double precision yvec(nvec) ! ! Step 1: Check if XVAL lies outside the intervals. ! if ( xval <= xvec(1)) then yder = 0 return else if ( xvec(nvec) <= xval ) then yder = 0 return end if ! ! Step 2: Find index I so that XVEC(I) <= XVAL < XVEC(I+1) ! do i = 1,nvec-1 if ( xvec(i) <= xval.and.xval <= xvec(i+1)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PLVal - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval stop 10 continue ! ! Step 3: Evaluate the slope of the linear function at XVAL. ! i = ival yder = (yvec(i+1)-yvec(i)) / (xvec(i+1)-xvec(i)) return end subroutine pldx1(ivec,nvec,xval,xvec,yder) !*****************************************************************************80 ! !! PLDX1 evaluates the X derivative of the piecewise linear ! polynomial which is 1 at the IVEC-th node and 0 at the others. ! ! Note that if XVAL falls to the left of XVEC(1), then YDER = 0, ! and similarly, if XVAL is greater than XVEC(NVEC), YDER = 0. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVEC, the coefficient with respect to which ! the partial derivative is desired. ! ! Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise linear. NVEC must be odd, and ! at least 3. ! ! Input, double precision XVAL, the point at which the function ! is to be evaluated. ! ! Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! Output, double precision YDER, the value of the derivative of ! the piecewise linear function at the point XVAL. ! implicit none ! integer nvec ! integer i integer ival integer ivec double precision xval double precision xvec(nvec) double precision yder ! ! Step 1: Check if XVAL lies outside the intervals. ! if ( xval <= xvec(1)) then yder = 0.0D+00 return else if ( xvec(nvec) <= xval ) then yder = 0.0D+00 return end if ! ! Step 2: Find index I so that XVEC(I) <= XVAL < XVEC(I+1) ! do i = 1,nvec-1 if ( xvec(i) <= xval.and.xval <= xvec(i+1)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PLDX1 - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval stop 10 continue ! ! Step 3: Evaluate the slope of the IVEC-th linear function at XVAL. ! i = ival if ( ival == ivec) then yder = (0.0D+00 -1.0D+00 )/(xvec(ival+1)-xvec(ival)) else if ( ival+1 == ivec) then yder = (1.0D+00 -0.0D+00 )/(xvec(ival+1)-xvec(ival)) else yder = 0.0D+00 end if return end subroutine pltopn ( disfil, igunit ) !*****************************************************************************80 ! !! PLTOPN opens the plotting file. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = 30 ) DISFIL, the name of the file into ! which the graphics information will be stored. ! ! IGUNIT Input/output, integer IGUNIT. ! ! On input, if IGUNIT is zero, then the routine believes ! that the graphics unit has not yet been opened. ! ! If the FORTRAN unit has already been opened, then IGUNIT ! should be nonzero, and the routine will know not to try ! to open the file, since it is already open. ! ! On output, IGUNIT is the FORTRAN unit used for writing data ! to the plotfile FILEG. ! implicit none ! character ( len = 30 ) disfil integer igunit ! ! If IGUNIT is not zero, then the graphics unit has already ! been opened. ! if ( igunit == 0) then write ( *, * ) ' ' write ( *, * ) 'PltOpn - Note:' write ( *, * ) ' Opening the DISPLAY plot file '//disfil write ( *, * ) ' ' ! ! Delete any old copy of the file. ! igunit = 11 open(unit = igunit,file=disfil,status='unknown', & form = 'formatted',access='sequential',err=10) return ! ! Write a warning if the plot file could not be opened. ! 10 continue write ( *, * ) ' ' write ( *, * ) 'PltOpn - Warning!' write ( *, * ) ' The plot file could not be opened.' igunit = 0 ! ! Else plotfile is already open. ! else write ( *, * ) ' ' write ( *, * ) 'PltOpn - Note' write ( *, * ) ' The plot file is already open.' write ( *, * ) ' New information will be appended to it.' end if return end subroutine plval ( nvec, xval, xvec, yval, yvec ) !*****************************************************************************80 ! !! PLVAL evaluates a piecewise linear function at a given point. ! ! ! Note that if XVAL falls to the left of XVEC(1), then YVAL = YVEC(1), ! and similarly, if XVAL is greater than XVEC(NVEC), YVAL = YVEC(NVEC). ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! NVEC Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise linear. NVEC must be at least 1. ! ! XVAL Input, double precision XVAL, the point at which the function ! is to be evaluated. ! ! XVEC Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! YVAL Output, double precision YVAL, the value of the piecewise ! linear function at the point XVAL. ! ! YVEC Input, double precision YVEC(NVEC), the value of the piecewise ! function at each of the abscissas. ! implicit none ! integer nvec ! integer i integer ival double precision xval double precision xvec(nvec) double precision yval double precision yvec(nvec) ! ! Step 1: Check if XVAL lies outside the intervals. ! if ( xval <= xvec(1)) then yval = yvec(1) return else if ( xvec(nvec) <= xval ) then yval = yvec(nvec) return end if ! ! Step 2: Find index I so that XVEC(I) <= XVAL < XVEC(I+1) ! do i = 1,nvec-1 if ( xvec(i) <= xval.and.xval <= xvec(i+1)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PLVal - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval stop 10 continue ! ! Step 3: Evaluate the linear function at XVAL. ! i = ival if ( xval == xvec(i+1)) then yval = yvec(i+1) else if ( xval == xvec(i)) then yval = yvec(i) else yval = ( yvec(i)*(xvec(i+1)-xval) & +yvec(i+1)*(xval-xvec(i)) ) / (xvec(i+1)-xvec(i)) end if return end subroutine plval1 ( ivec, nvec, xval, xvec, yval ) !*****************************************************************************80 ! !! PLVAL1 evaluates a piecewise linear basis polynomial. ! ! ! Discussion: ! ! The piecewise linear basis polynomial is 1 ! at node IVEC and 0 at the other nodes. ! ! Note that if XVAL falls to the left of XVEC(1), then YVAL = 0, ! and similarly, if XVAL is greater than XVEC(NVEC), YVAL = 0. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVEC, the coefficient with respect to which ! the partial derivative is desired. ! ! Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise linear. NVEC must be odd, and ! at least 3. ! ! Input, double precision XVAL, the point at which the function ! is to be evaluated. ! ! Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! Output, double precision YDER, the value of the derivative of ! the piecewise linear function at the point XVAL. ! implicit none ! integer nvec ! integer i integer ival integer ivec double precision xval double precision xvec(nvec) double precision yval ! ! Step 1: Check if XVAL lies outside the intervals. ! if ( xval <= xvec(1)) then yval = 0.0D+00 return else if ( xvec(nvec) <= xval ) then yval = 0.0D+00 return end if ! ! Step 2: Find index I so that XVEC(I) <= XVAL < XVEC(I+1) ! do i = 1,nvec-1 if ( xvec(i) <= xval.and.xval <= xvec(i+1)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PLVAL1 - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval stop 10 continue ! ! Step 3: Determine the index of the left endpoint of the least and ! greatest intervals that IVEC can affect. ! i = ival if ( ival == ivec) then if ( xval == xvec(ival)) then yval = 1.0D+00 else yval = (xvec(ival+1)-xval) / (xvec(ival+1)-xvec(ival)) end if else if ( ival+1 == ivec) then if ( xval == xvec(ival+1) ) then yval = 1.0D+00 else yval = (xval-xvec(ival)) / (xvec(ival+1)-xvec(ival)) end if else yval = 0.0D+00 end if return end subroutine pqdx ( nvec, xval, xvec, yder, yvec ) !*****************************************************************************80 ! !! PQDX evaluates the derivative of a piecewise quadratic function with ! respect to its argument at a given point. ! ! Note that if XDER falls to the left of XVEC(1), then YVAL = 0, ! and similarly, if XVAL is greater than XVEC(NVEC), YDER = 0. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! NVEC Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise quadratic. NVEC must be odd, and ! at least 3. ! ! XVAL Input, double precision XVAL, the point at which the ! derivative with respect to X is to be evaluated. ! ! XVEC Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! YDER Output, double precision YDER, the value of the derivative ! of the piecewise quadratic function with respect to X, ! at the point XVAL. ! ! YVEC Input, double precision YVEC(NVEC), the value of the piecewise ! quadratic function at each of the abscissas. ! implicit none ! integer nvec ! integer i integer ival double precision xval double precision xvec(nvec) double precision yder double precision yvec(nvec) ! ! Step 0: Check data. ! if ( nvec < 3) then write ( *, * ) ' ' write ( *, * ) 'PQDX - Fatal error.' write ( *, * ) ' NVEC is ',nvec write ( *, * ) ' but NVEC must be at least 3.' stop end if if ( mod(nvec,2) /= 1) then write ( *, * ) ' ' write ( *, * ) 'PQDX - Fatal error!' write ( *, * ) ' Even value of NVEC = ',nvec stop end if ! ! Step 1: Find odd index I so that XVEC(I) <= XVAL < XVEC(I+2) ! if ( xval <= xvec(1)) then yder = yvec(1) return else if ( xvec(nvec) <= xval ) then yder = yvec(nvec) return end if do i = 1,nvec-2,2 if ( xvec(i) <= xval.and.xval <= xvec(i+2)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PQDX - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval stop 10 continue ! ! Step 2: Evaluate the derivative of the quadratic function at XVAL. ! i = ival yder = yvec(i)*(2*xval-xvec(i+1)-xvec(i+2)) & /((xvec(i)-xvec(i+1))*(xvec(i)-xvec(i+2))) & +yvec(i+1)*(2*xval-xvec(i)-xvec(i+2)) & /((xvec(i+1)-xvec(i))*(xvec(i+1)-xvec(i+2))) & +yvec(i+1)*(2*xval-xvec(i)-xvec(i+2)) & /((xvec(i+1)-xvec(i))*(xvec(i+1)-xvec(i+2))) return end subroutine pqdx1 ( ivec, nvec, xval, xvec, yder ) !*****************************************************************************80 ! !! PQDX1 evaluates the X derivative of the piecewise quadratic ! polynomial which is 1 at the IVEC-th node and 0 at the others. ! ! Note that if XVAL falls to the left of XVEC(1), then YDER = 0, ! and similarly, if XVAL is greater than XVEC(NVEC), YDER = 0. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! IVEC Input, integer IVEC, the coefficient with respect to which ! the partial derivative is desired. ! ! NVEC Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise quadratic. NVEC must be odd, and ! at least 3. ! ! XVAL Input, double precision XVAL, the point at which the function ! be evaluated. ! ! XVEC Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! YDER Output, double precision YDER, the value of the derivative of ! the piecewise quadratic function at the point XVAL. ! implicit none ! integer nvec ! integer i integer ihi integer ilo integer ival integer ivec double precision xval double precision xvec(nvec) double precision yder ! ! Step 0: Check data. ! if ( nvec < 3) then write ( *, * ) ' ' write ( *, * ) 'PQDX1 - Fatal error!' write ( *, * ) ' NVEC = ',nvec write ( *, * ) ' but NVEC must be at least 3.' stop end if if ( mod(nvec,2) /= 1) then write ( *, * ) ' ' write ( *, * ) 'PQDX1 - Fatal error!' write ( *, * ) ' Even value of NVEC = ',nvec stop end if ! ! Step 1: Find odd index I so that XVEC(I) <= XVAL < XVEC(I+2) ! if ( xval <= xvec(1)) then yder = 0 return else if ( xvec(nvec) <= xval ) then yder = 0 return end if do i = 1,nvec-2,2 if ( xvec(i) <= xval.and.xval <= xvec(i+2)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PQDX1 - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval stop 10 continue ! ! Step 2: Determine the index of the left endpoint of the least and ! greatest intervals that IVEC can affect. ! if ( mod(ivec,2) == 0) then ilo = ivec-1 ihi = ivec-1 else ilo = max(ivec-2,1) ihi = ivec end if ! ! Step 3: If XVAL is outside of the intervals that IVEC can affect, ! the derivative is zero. ! if ( ival < ilo .or. ihi < ival ) then yder = 0 return end if ! ! Step 3: Evaluate the derivative of the quadratic function at XVAL. ! i = ival if ( ivec == ival ) then yder = ( 2.0D+00 * xval - xvec(i+1) - xvec(i+2) ) & / ( ( xvec(i) - xvec(i+1) ) * ( xvec(i) - xvec(i+2) ) ) else if ( ivec == ival+1) then yder = ( 2.0D+00 * xval-xvec(i)-xvec(i+2)) & /((xvec(i+1)-xvec(i))*(xvec(i+1)-xvec(i+2))) else if ( ivec == ival+2) then yder = ( 2.0D+00 * xval-xvec(i)-xvec(i+1)) & /((xvec(i+2)-xvec(i))*(xvec(i+2)-xvec(i+1))) else write ( *, * ) ' ' write ( *, * ) 'PQDX1 - Fatal error!' write ( *, * ) ' IVEC = ',ivec write ( *, * ) ' IVAL = ',ival end if return end subroutine pqval ( nvec, xval, xvec, yval, yvec ) !*****************************************************************************80 ! !! PQVAL evaluates a piecewise quadratic function at a given point. ! ! ! Discussion: ! ! The piecewise quadratic is defined by NVEC values, where NVEC ! is odd, and at least 3. The function is defined by specifying ! a list of nodes XVEC(I), and specifying its value YVEC(I) at each ! node. ! ! The function will be a quadratic polynomial over each of ! (NVEC-1)/2 intervals that are made up a set of three consecutive ! nodes, with the first one odd. Thus, XVEC(1), XVEC(2) and XVEC(3) ! lie in the first interval. ! ! At the odd nodes, the quadratic that defines the function may ! change, but the function remains continuous there, though not ! differentiable. ! ! Note that if XVAL falls to the left of XVEC(1), then YVAL = YVEC(1), ! and similarly, if XVAL is greater than XVEC(NVEC), YVAL = YVEC(NVEC). ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! NVEC Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise quadratic. ! ! NVEC must be odd, and at least 3. ! ! XVAL Input, double precision XVAL, the point at which the function ! is be evaluated. ! ! XVEC Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! YVAL Output, double precision YVAL, the value of the piecewise ! quadratic function at the point XVAL. ! ! YVEC Input, double precision YVEC(NVEC), the value of the ! piecewise quadratic function at each of the abscissas. ! implicit none ! integer nvec ! integer i integer ival double precision xval double precision xvec(nvec) double precision yval double precision yvec(nvec) ! ! Step 0: Check data. ! if ( nvec < 3) then write ( *, * ) ' ' write ( *, * ) 'PQVal - Fatal error!' write ( *, * ) ' Value of NVEC = ',nvec write ( *, * ) ' but NVEC must be at least 3.' stop end if if ( mod(nvec,2) /= 1) then write ( *, * ) ' ' write ( *, * ) 'PQVal - Fatal error!' write ( *, * ) ' Even value of NVEC = ',nvec stop end if ! ! Step 1: Find odd index I so that XVEC(I) <= XVAL < XVEC(I+2) ! if ( xval <= xvec(1)) then yval = yvec(1) return else if ( xvec(nvec) <= xval ) then yval = yvec(nvec) return end if do i = 1,nvec-2,2 if ( xvec(i) <= xval.and.xval <= xvec(i+2)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PQVal - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval write ( *, * ) ' There are ',nvec,' nodes.' write ( *, * ) ' First node is at ',xvec(1) write ( *, * ) ' Last node is at ',xvec(nvec) do i = 1,nvec write ( *, * ) xvec(i) end do stop 10 continue ! ! Step 2: Evaluate the quadratic function at XVAL. ! i = ival yval = yvec(i)*(xval-xvec(i+1)) * (xval-xvec(i+2)) & /((xvec(i)-xvec(i+1))*(xvec(i)-xvec(i+2))) & +yvec(i+1)*(xval-xvec(i)) * (xval-xvec(i+2)) & /((xvec(i+1)-xvec(i))*(xvec(i+1)-xvec(i+2))) & +yvec(i+2)*(xval-xvec(i)) * (xval-xvec(i+1)) & /((xvec(i+2)-xvec(i))*(xvec(i+2)-xvec(i+1))) return end subroutine pqval1 ( ivec, nvec, xval, xvec, yval ) !*****************************************************************************80 ! !! PQVAL1 evaluates the piecewise quadratic polynomial which is 1 ! at node IVEC and 0 at the other nodes. ! ! Note that if XVAL falls to the left of XVEC(1), then YVAL = 0, ! and similarly, if XVAL is greater than XVEC(NVEC), YVAL = 0. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! IVEC Input, integer IVEC, the coefficient with respect to which ! the partial derivative is desired. ! ! NVEC Input, integer NVEC, the number of abscissas and coefficients ! that define the piecewise quadratic. NVEC must be odd, and ! at least 3. ! ! XVAL Input, double precision XVAL, the point at which the function ! is to be evaluated. ! ! XVEC Input, double precision XVEC(NVEC), the abscissas of the ! function. These should be distinct and in ascending order. ! ! YDER Output, double precision YDER, the value of the derivative of ! the piecewise quadratic function at the point XVAL. ! implicit none ! integer nvec ! integer i integer ihi integer ilo integer ival integer ivec double precision xval double precision xvec(nvec) double precision yval ! ! Step 0: Check data. ! if ( nvec < 3) then write ( *, * ) ' ' write ( *, * ) 'PQVal1 - Fatal error!' write ( *, * ) ' Value of NVEC is ',nvec write ( *, * ) ' but NVEC must be at least 3.' stop end if if ( mod(nvec,2) /= 1) then write ( *, * ) ' ' write ( *, * ) 'PQVal1 - Fatal error!' write ( *, * ) ' Even value of NVEC = ',nvec stop end if ! ! Step 1: Find odd index I so that XVEC(I) <= XVAL < XVEC(I+2) ! if ( xval <= xvec(1)) then yval = 0.0D+00 return else if ( xvec(nvec) <= xval ) then yval = 0.0D+00 return end if do i = 1,nvec-2,2 if ( xvec(i) <= xval.and.xval <= xvec(i+2)) then ival = i go to 10 end if end do write ( *, * ) ' ' write ( *, * ) 'PQVal1 - Fatal error!' write ( *, * ) ' Could not bracket XVAL = ',xval stop 10 continue ! ! Step 2: Determine the index of the left endpoint of the least and ! greatest intervals that IVEC can affect. ! if ( mod(ivec,2) == 0) then ilo = ivec-1 ihi = ivec-1 else ilo = max(ivec-2,1) ihi = ivec end if ! ! Step 3: If XVAL is outside of the intervals that IVEC can affect, ! the value is zero. ! if ( ival < ilo .or. ihi < ival ) then yval = 0 return end if ! ! Step 3: Evaluate the quadratic function at XVAL. ! i = ival if ( ivec == ival) then yval = (xval-xvec(i+1)) * (xval-xvec(i+2)) & /((xvec(i)-xvec(i+1))*(xvec(i)-xvec(i+2))) else if ( ivec == ival+1) then yval = (xval-xvec(i)) * (xval-xvec(i+2)) & /((xvec(i+1)-xvec(i))*(xvec(i+1)-xvec(i+2))) else if ( ivec == ival+2) then yval = (xval-xvec(i)) * (xval-xvec(i+1)) & /((xvec(i+2)-xvec(i))*(xvec(i+2)-xvec(i+1))) else write ( *, * ) ' ' write ( *, * ) 'PQVal1 - Fatal error!' write ( *, * ) ' IVEC = ',ivec write ( *, * ) ' IVAL = ',ival end if return end subroutine prbmat ( afl, ihi, ilo, jhi, jlo, ldafl, neqnfl, nlband ) !*****************************************************************************80 ! !! PRBMAT prints the nonzeroes in a submatrix of a band matrix. ! ! ! Discussion: ! ! The submatrix is the rectangular region including rows ILO to IHI, ! columns JLO to JHI. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! AFL Input, double precision AFL(LDAFL,MAXNFL). ! If Newton iteration is being carried out, then AFL contains the ! Jacobian matrix for the full system. If Picard iteration is ! being carried out, AFL contains the Picard matrix. ! AFL is stored in LINPACK general band storage mode, with ! dimension 3*NBANDL+1 by NEQNFL. ! ! IHI, ! ILO, ! JHI, ! JLO Input, integer IHI, ILO, JHI, JLO. ! PRMAT is to print all nonzero entries in rows ILO through IHI, ! and columns JLO through JHI, of the matrix AFL. ! ! LDAFL Input, integer LDAFL. ! LDAFL is the first dimension of the matrix AFL as declared in ! the main program. LDAFL must be at least 3*NLBAND+1. ! ! NEQNFL Input, integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! NLBAND Input, integer NLBAND, the lower bandwidth of the matrix AFL. ! The zero structure of AFL is assumed to be symmetric, and so ! NLBAND is also the upper bandwidth of AFL. ! implicit none ! integer, parameter :: incx = 5 ! integer ldafl integer neqnfl ! double precision afl(ldafl,neqnfl) character ( len = 14 ) ctemp(incx) integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo integer nlband ! do j2lo = jlo,jhi,incx j2hi = j2lo+incx-1 j2hi = min(j2hi,neqnfl) j2hi = min(j2hi,jhi) inc = j2hi+1-j2lo write ( *, * ) ' ' do j = j2lo,j2hi j2 = j+1-j2lo write(ctemp(j2),'(i7,7x)')j end do write(*,'(''Columns '',5a14)')(ctemp(j2),j2 = 1,inc) ! write ( *, * ) 'Columns ',j2lo,' to ',j2hi write ( *, * ) ' Row' write ( *, * ) ' ' i2lo = ilo i2lo = max(ilo,1) i2lo = max(j2lo-nlband,i2lo) i2hi = ihi i2hi = min(ihi,neqnfl) i2hi = min(j2hi+nlband,i2hi) do i = i2lo,i2hi do j2 = 1,inc j = j2lo-1+j2 if ( i-j <= nlband.and.j-i <= nlband) then write(ctemp(j2),'(g14.6)')afl(i-j+2*nlband+1,j) if ( afl(i-j+2*nlband+1,j) == 0.0D+00 )ctemp(j2)=' 0.0' else ctemp(j2) = ' ' end if end do write(*,'(i5,1x,5a14)')i,(ctemp(j2),j2 = 1,inc) end do end do write ( *, * ) ' ' return end subroutine prdat(disfil,drey,epsdif,gridx,gridy,hx,hy,ibs,ibump,ifs,ijac, & iopt,maxnew,maxopt,maxsim,nbcrb,ncofrb,nelem,nferb,neqnfl,np,npar,nparb, & nparf,ntay,nx,ny,region,reytay,tecfil,tolnew,tolopt,tolsim,wateb,watep, & wateu,watev,xbl,xbr,xprof,xrange,ybl,ybr,yrange) !*****************************************************************************80 ! !! PRDAT prints the problem information. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! implicit none ! integer npar ! character ( len = 30 ) disfil double precision drey double precision epsdif character ( len = 20 ) gridx character ( len = 20 ) gridy double precision hx double precision hy integer i integer ibs integer ibump integer ifs integer ijac integer iopt(npar) integer maxnew integer maxopt integer maxsim integer nbcrb integer ncofrb integer nelem integer neqnfl integer nferb integer np integer nparb integer nparf integer ntay integer nx integer ny character ( len = 20 ) region double precision reytay character ( len = 30 ) tecfil double precision tolnew double precision tolopt double precision tolsim character ( len = 6 ) type double precision wateb double precision watep double precision wateu double precision watev double precision xbl double precision xbr double precision xprof double precision xrange double precision ybl double precision ybr character ( len = 3 ) yesno double precision yrange ! write ( *, * ) ' ' write ( *, * ) ' DISPLAY graphics file is DISFIL = ', trim ( disfil ) write ( *, * ) ' REYNLD increment for finite differences DREY = ',drey write ( *, * ) ' Finite difference perturbation EPSDIF = ',epsdif write ( *, * ) ' X grid generation option GRIDX = '//gridx write ( *, * ) ' Y grid generation option GRIDY = '//gridy write ( *, * ) ' X spacing, HX = ',hx write ( *, * ) ' Y spacing, HY = ',hy write ( *, * ) ' Bump piecewise polynomial order IBS = ',ibs write ( *, * ) ' Bump option IBUMP = ',ibump write ( *, * ) ' Flow piecewise polynomial order IFS = ',ifs write ( *, * ) ' Jacobian option IJAC = ',ijac write ( *, * ) ' ' write ( *, * ) ' Variable Type Free to Vary?' write ( *, * ) ' ' do i = 1,npar if ( i <= nparf) then type = 'Inflow' else if ( i <= nparf+nparb) then type = 'Shape' else type = 'Reynld' end if if ( iopt(i) == 0) then yesno = 'No' else yesno = 'Yes' end if write(*,'(6x,i5,2x,a6,2x,a3)')i,type,yesno end do write ( *, * ) ' ' write ( *, * ) ' Maximum Newton iterations MAXNEW = ',maxnew write ( *, * ) ' Maximum optimization steps MAXOPT = ',maxopt write ( *, * ) ' Maximum Newton iterations MAXSIM = ',maxsim write ( *, * ) ' # of RB boundary conditions NBCRB = ',nbcrb write ( *, * ) ' Number of reduced equations, NCOFRB = ',ncofrb write ( *, * ) ' Number of elements, NELEM = ',nelem write ( *, * ) ' Number of full equations, NEQNFL = ',neqnfl write ( *, * ) ' # of FE reduced basis cofs, NFERB = ',nferb write ( *, * ) ' Number of nodes, NP = ',np write ( *, * ) ' Number of parameters NPAR = ',npar write ( *, * ) ' Number of inflow parameters NPARF = ',nparf write ( *, * ) ' Number of Taylor vectors NTAY = ',ntay write ( *, * ) ' Number of bump parameters NPARB = ',nparb write ( *, * ) ' Number of X elements, NX = ',nx write ( *, * ) ' Number of Y elements, NY = ',ny write ( *, * ) ' The flow region is REGION = ', trim ( region ) write ( *, * ) ' REYNLD value for Taylor, REYTAY = ',reytay write ( *, * ) ' TECPLOT graphics file is TECFIL = ', trim ( tecfil ) write ( *, * ) ' Newton convergence tolerance TOLNEW = ',tolnew write ( *, * ) ' Optimization tolerance TOLOPT = ',tolopt write ( *, * ) ' Picard convergence tolerance TOLSIM = ',tolsim write ( *, * ) ' Bump control cost, WATEB = ',wateb write ( *, * ) ' Pressure discrepancy, WATEP = ',watep write ( *, * ) ' U discrepancy, WATEU = ',wateu write ( *, * ) ' V discrepancy, WATEV = ',watev write ( *, * ) ' Left X of bump, XBL = ',xbl write ( *, * ) ' Right X of bump, XBR = ',xbr write ( *, * ) ' Flow profile measured at XPROF = ',xprof write ( *, * ) ' X range, XRANGE = ',xrange write ( *, * ) ' Left Y of bump, YBL = ',ybl write ( *, * ) ' Right Y of bump, YBR = ',ybr write ( *, * ) ' Y range, YRANGE = ',yrange return end subroutine prdmat(a,ihi,ilo,jhi,jlo,mhi,mlo,nhi,nlo) !*****************************************************************************80 ! !! PRDMAT prints out a portion of a dense matrix. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 11 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real A(MLO:MHI,NLO:NHI), the matrix to be printed. ! ! IHI, ! ILO Input, integer IHI, ILO. ! ILO is the first and IHI the last row to print. ! ! JHI, ! JLO Input, integer JHI, JLO. ! JLO is the first, and JHI the last column to print. ! ! MHI, ! MLO Input, integer MHI, MLO. ! The rows of A go from MLO to MHI. ! ! NHI, ! NLO Input, integer NHI, NLO. ! The columns of A go from NLO to NHI. ! implicit none ! integer incx parameter (incx = 5) ! integer mhi integer mlo integer nhi integer nlo ! double precision a(mlo:mhi,nlo:nhi) character ( len = 14 ) ctemp(incx) integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo ! write ( *, * ) ' ' do j2lo = jlo,jhi,incx j2hi = j2lo+incx-1 if ( nhi < j2hi ) then j2hi = nhi end if if ( jhi < j2hi ) then j2hi = jhi end if inc = j2hi+1-j2lo write ( *, * ) ' ' do j = j2lo,j2hi j2 = j+1-j2lo write(ctemp(j2),'(i7,7x)')j end do write(*,'(''Columns '',5a14)')(ctemp(j2),j2 = 1,inc) write ( *, * ) ' Row' write ( *, * ) ' ' i2lo = max(ilo,mlo) i2hi = min(ihi,mhi) do i = i2lo,i2hi do j2 = 1,inc j = j2lo-1+j2 write(ctemp(j2),'(g14.6)')a(i,j) if ( a(i,j) == 0.0D+00 )ctemp(j2)=' 0.0' end do write(*,'(i5,1x,5a14)')i,(ctemp(j),j = 1,inc) end do end do write ( *, * ) ' ' return end subroutine prelem ( ihi, ilo, nelem, node, np, xc, yc ) !*****************************************************************************80 ! !! PRELEM prints out data about one or more elements. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IHI, ILO. ! ILO is the first element of interest, and IHI the last. ! ! NELEM Input, integer NELEM. ! NELEM is the numberof elements. ! ! NODE Input, integer NODE(6,NELEM), contains the numbers ! of the nodes that make up each element. Element number ! I is associated with nodes NODE(1,I) through NODE(6,I). ! ! NP Input, integer NP. ! ! NP is the number of nodes. NP = (2*NX-1)*(2*NY-1). ! ! XC, ! YC Input, double precision XC(NP), YC(NP). ! XC and YC are the X and Y coordinates of the nodes. ! implicit none ! integer nelem integer np ! integer i integer ielem integer ihi integer ihi2 integer ilo integer ilo2 integer ip integer node(6,nelem) double precision xc(np) double precision yc(np) ! if ( ilo < 1) then ilo2 = 1 else ilo2 = ilo end if if ( nelem < ihi ) then ihi2 = nelem else ihi2 = ihi end if do ielem = ilo2,ihi2 write ( *, * ) ' ' write ( *, * ) 'Element IELEM = ',ielem write ( *, * ) ' ' write ( *, * ) ' Nodes:' write ( *, * ) ' ' do i = 1,6 ip = node(i,ielem) write ( *, * ) i,ip,xc(ip),yc(ip) end do end do return end subroutine prfxfln ( neqnfl, resfl ) !*****************************************************************************80 ! !! PRFXFLN prints out the norm of a full residual. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEQNFL, the number of equations (and coefficients) ! in the full finite element system. ! ! Input, double precision RESFL(NEQNFL). ! RESFL contains the residual in the full basis equations. ! implicit none ! integer neqnfl ! double precision anrmr double precision dnrm2 double precision enrmr integer idamax integer itemp double precision resfl(neqnfl) ! itemp = idamax(neqnfl,resfl,1) anrmr = abs(resfl(itemp)) enrmr = dnrm2(neqnfl,resfl,1) write ( *, * ) ' ' write ( *, * ) ' MxNorm l2 Norm' write ( *, * ) ' ' write(*,'(''Fx(GFL) '',2g14.6)')anrmr,enrmr return end subroutine prgrb ( grb, ncofrb ) !*****************************************************************************80 ! !! PRGRB prints out the reduced basis solution. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision GRB(NCOFRB), coefficients for the ! reduced system. ! ! Input, integer NCOFRB, the number of coefficients for the ! reduced system. ! implicit none ! integer ncofrb ! double precision anrmg double precision dnrm2 double precision enrmg double precision grb(ncofrb) integer i integer idamax integer itemp ! if ( ncofrb <= 0) then write ( *, * ) ' ' write ( *, * ) 'PrGRB - Fatal error.' write ( *, * ) ' Input value of NCOFRB = ',ncofrb stop end if write ( *, * ) ' ' write ( *, * ) 'PrGRB - The reduced basis coefficients:' write ( *, * ) ' ' do i = 1,ncofrb write(*,'(i6,g14.6)')i,grb(i) end do itemp = idamax(ncofrb,grb,1) anrmg = abs(grb(itemp)) enrmg = dnrm2(ncofrb,grb,1) write ( *, * ) ' ' write ( *, * ) ' MxNorm l2 Norm' write ( *, * ) ' ' write(*,'(''GRB '',2g14.6)')anrmg,enrmg return end subroutine prindx ( ihi, ilo, indx, np, xc, yc ) !*****************************************************************************80 ! !! PRINDX prints out the integer variables that define the ! relationships between the nodes and elements. ! ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 21 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! IHI, ! ILO Input, integer IHI, ILO. ! ILO is the first, and IHI the last node at which the ! information is desired. ! ! INDX Input, integer INDX(3,NP). ! ! INDX contains, for each node I, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry G(K). ! ! If INDX(I,J) is positive, then that means that a degree of ! freedom for variable J (U, V or P) is associated with node ! I, and an equation will be generated to determine its value. ! ! If INDX(I,J) is zero, then that means the the value of variabl ! J (U, V or P) has been specified at node I. No equation is ! generated to determine its value. ! ! NP Input, integer NP. ! ! NP is the number of nodes. NP = (2*NX-1)*(2*NY-1). ! ! XC, ! YC Input, double precision XC(NP), YC(NP). ! XC and YC are the X and Y coordinates of the nodes. ! implicit none ! integer np ! integer i integer ihi integer ilo integer indx(3,np) double precision xc(np) double precision yc(np) ! write ( *, * ) ' ' write ( *, * ) 'PrIndx:' write ( *, * ) ' ' write ( *, * ) ' Node X Y U V P' write ( *, * ) ' ' do i = max(ilo,1),min(ihi,np) if ( indx(3,i) /= 0) then write(*,'(i6,2g14.6,3i6)')i,xc(i),yc(i),indx(1,i),indx(2,i),indx(3,i) else write(*,'(i6,2g14.6,2i6)')i,xc(i),yc(i),indx(1,i),indx(2,i) end if end do return end subroutine prmatfl(a,eqn,ihi,ilo,indx,jhi,jlo,maxnfl,ncol,neqnfl,np) !*****************************************************************************80 ! !! PRMATFL a matrix A associated with a full flow problem. ! ! ! Discussion: ! ! PRMATFL prints out a range of rows and columns of a dense matrix, ! whose rows are indirectly indexed by node number, and whose ! columns are indexed in the usual way. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 08 July 1996 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! A Input, double precision A(MAXNFL,NCOFRB). ! A is the matrix whose entries are to be printed. ! ! EQN Input, character ( len = 2 ) EQN(MAXNFL). ! EQN records the "type" of each equation that will be generated, and ! which is associated with an unknown. Note that most boundary ! conditions do not result in an equation. The current values are: ! ! 'U' The horizontal momentum equation. ! 'UB' The condition U = 0 applied at a node on the bump. ! 'UI' The condition U = UInflow(Y,Lambda) at the inflow. ! 'UW' The condition U = 0 applied at a node on a fixed wall. ! 'U0' A dummy value of U = 0 should be set. ! ! 'V' The vertical momentum equation. ! 'VB' The condition V = 0 applied at a node on the bump. ! 'VI' The condition V = VInflow(Y,Lambda) at the inflow. ! 'VW' The condition V = 0 applied at a node on a fixed wall. ! 'V0' A dummy value of V = 0 should be set. ! ! 'P' The continuity equation. ! 'PB' The condition P = 0 applied at (XMAX,YMAX). ! 'P0' A dummy value of P = 0 should be set. ! ! IHI, ! ILO Input, integer IHI, ILO. ! ILO is the first node, and IHI the last node, for which the ! data should be printed. ! ! INDX Input, integer INDX(3,NP). ! ! INDX(I,J) contains, for each node J, the index of U, V and P at ! that node, or 0 or a negative value. ! ! If K = INDX(I,J) is positive, then the value of the degree ! of freedom is stored in the solution vector entry GFL(K). ! ! If INDX(I,J) is positive, then that means that a degree of ! freedom for variable I (U, V or P) is associated with node ! J, and an equation will be generated to determine its value. ! ! If INDX(I,J) is not positive, then no equation is ! generated to determine for variable I at node J. ! ! JHI, ! JLO Input, integer JHI, JLO. ! JLO is the first, and JHI the last column of A to print. ! ! MAXNFL Input, integer MAXNFL. ! MAXNFL is the maximum number of equations in the full system. ! ! NEQNFL Input, integer NEQNFL. ! NEQNFL is the number of equations (and coefficients) in the full ! finite element system. ! ! NCOFRB Input, integer NCOFRB. ! NCOFRB is the number of sensitivities. ! ! NP Input, integer NP. ! NP is the number of nodes. ! implicit none ! integer maxnfl integer ncol integer neqnfl integer np ! double precision a(maxnfl,ncol) character ( len = 2 ) eqn(neqnfl) integer i integer ihi integer ihi2 integer ilo integer ilo2 integer indx(3,np) integer j integer jhi integer jhi2 integer jlo integer jlo2 integer k integer l integer lhi integer llo integer ncols ! if ( neqnfl <= 0) then write ( *, * ) ' ' write ( *, * ) 'PrMatFL - Fatal error!' write ( *, * ) ' NEQNFL = ',neqnfl stop end if if ( ncol <= 0) then write ( *, * ) ' ' write ( *, * ) 'PrMatFL - Fatal error!' write ( *, * ) ' NCOL = ',ncol stop end if if ( ilo < 1) then ilo2 = 1 write ( *, * ) ' ' write ( *, * ) 'PrMatFL - Warning!' write ( *, * ) ' Input ILO = ',ilo write ( *, * ) ' Reset to ILO2 = ',ilo2 else ilo2 = ilo end if if ( np < ihi ) then ihi2 = np write ( *, * ) ' ' write ( *, * ) 'PrMatFL - Warning!' write ( *, * ) ' Input IHI = ',ihi write ( *, * ) ' Reset to IHI2 = ',ihi2 else ihi2 = ihi end if if ( ihi2 < ilo2 ) then write ( *, * ) ' ' write ( *, * ) 'PrMatFL - Warning:' write ( *, * ) ' Input ILO = ',ilo, ' IHI= ',ihi write ( *, * ) ' Effective ILO2 = ',ilo2,' IHI2=',ihi2 return end if if ( jlo < 1) then jlo2 = 1 write ( *, * ) ' ' write ( *, * ) 'PrMatFL - Warning!' write ( *, * ) ' Input value of JLO was ',jlo write ( *, * ) ' Reset to JLO2 = ',jlo2 else jlo2 = jlo end if if ( ncol < jhi ) then jhi2 = ncol write ( *, * ) ' ' write ( *, * ) 'PrMatFL - Warning!' write ( *, * ) ' Input value of JHI was ',jhi write ( *, * ) ' Reset to JHI2 = ',jhi2 else jhi2 = jhi end if