! **deck a502 program a502 !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to solve linear potential flow boundary value problems in * ! * both supersonic and subsonic regimes. * ! * * ! * this is the main program. tapes 1,2,3,4,10,11,12 and 14 are * ! * random files. the rest are sequential. tapes 1,2,3 and 4 are * ! * opened here. tape 10 is opened in subroutine * ! * tinver of overlay(3hfee,10b,0b). tape 11 is opened in * ! * subroutine blockr of overlay(3hfee,10b,0b). tapes 12 and 14 * ! * are opened in subroutine vinfcc of overlay(3hfee,6b,0b). the * ! * last four tapes use portions of the scratch common block * ! * /skrch1/ for index arrays. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * !c * * * * m e t h o d * * * * ! * - - - - - - - * ! * * ! * the theory is presented in the engineering document * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * d e f i n i t i o n o f g l o b a l v a r i a b l e s * ! * - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storeage defined description * ! * * ! * abetms /comprs/ flow absolute value of betams * ! * * ! * aj argument geomc sub-panel area jacobian * ! * (ratio of area element in * ! * global coordinates to area * ! * element in local sub-panel * ! * coordinates) * ! * * ! * alpc /comprs/ block compressibility direction * ! * input angle of attack * ! * * ! * alpha /acase/ block angles of attack * ! * input * ! * * ! * amach /acase/ block freestream mach number * ! * input * ! * * ! * aq /pandq/ surfit transformation matrix from * ! * global to near plane * ! * coordinate system * ! * * ! * aqi /pandq/ surfit transformation matrix from * ! * near plane to global * ! * coordinate system * ! * ar /pandq/ obliqu transformation from global to * ! * local sub-panel coordinates * ! * * ! * ari /pandq/ obliqu transformation from local sub-* ! * panel to global coordinates * ! * * ! * arotc /comprs/ rotate orthogonal matrix transforming* ! * global coordinates to fluid * ! * axis coordinates * ! * * ! * arotci /comprs/ rotate inverse of arotc * ! * * ! * arp /pandq/ psddqg matrices transforming the * ! * combined potential/velocity * ! * vector from local sub-panel to* ! * global coordinates * ! * * ! * astd /pandq/ daspl matrix relating nine canonical* ! * sing panel doublet values to * ! * neighboring singularity * ! * parameters * ! * * ! * asts /pandq/ sing matrix relating linear source * ! * coefficients of panel source * ! * distribution to neighboring * ! * source parameters * ! * * ! * bet /bcond/ bconcl boundary condition (multiple) * ! * bcopt right hand side values * ! * cbet * ! * btrnsf * ! * * ! * beta /acase/ block angles of sideslip * ! * input * ! * * ! * betam /comprs/ flow square root of abetms * ! * * ! * betams /comprs/ flow 1.-(freestream mach number)**2* ! * * ! * betc /comprs/ block compressibility direction * ! * input angle of sideslip * ! * * ! * bet1 /bcon/ block first boundary condition * ! * input (multiple) right hand side * ! * bconcl values * ! * * ! * bet2 /bcon/ block second boundary condition * ! * input (multiple) right hand side * ! * bconcl values * ! * * ! * bref /fmcof/ block reference length for * ! * input moment about x axis * ! * * ! * cl /bcond/ bconcl boundary condition coefficient* ! * bcopt of lower surface perturbation * ! * ccof normal mass flux * ! * btrnsf * ! * * ! * cl1 /bcon/ block first boundary conidition * ! * input coefficient of lower surface * ! * bconcl perturbation normal mass flux * ! * * ! * cl2 /bcon/ block second boundary condition * ! * input coefficient of lower surface * ! * bconcl perturbation normal mass flux * ! * * ! * compd /comprs/ flow compressibility direction * ! * vector * ! * * ! * cp /pandq/ geomc nine canonical panel points * ! * (includes corner points,edge * ! * midpoints and center) * ! * * ! * cref /fmcof/ block reference length for * ! * input moment about y axis * ! * * ! * cu /bcond/ bconcl boundary condition coefficient* ! * bcopt of upper surface perturbation * ! * ccof normal mass flux * ! * btrnsf * ! * * ! * cu1 /bcon/ block first boundary condition * ! * input coefficient of upper surface * ! * bconcl perturbation normal mass flux * ! * * ! * cu2 /bcon/ block second boundary condition * ! * input coefficient of upper surface * ! * bconcl perturbation normal mass flux * ! * * ! * c1 /pandq/ psddqg quadrilateral skewness param- * ! * eter corresponding to the * ! * first near plane coordinate * ! * * ! * c2 /pandq/ psddqg quadrilateral skewness param- * ! * eter corresponding to the * ! * second near plane coordinate * ! * * ! * c3 /pandq/ psddqg quadrilateral skewness param- * ! * eter corresponding to the * ! * third near plane corrdinate * ! * * ! * czinv /comprs/ flow compressibility matrix * ! * * ! * diam /pandq/ geomc compressible panel diameter * ! * * ! * dl /bcond/ bconcl boundary condition coefficient* ! * bcopt of lower surface perturbation * ! * ccof potential * ! * btrnsf * ! * * ! * dl1 /bcon/ block first boundary condition * ! * input coefficient of lower surface * ! * bconcl perturbation potential * ! * * ! * dl2 /bcon/ block second boundary condition * ! * input coefficient of lower surface * ! * bconcl perturbation potential * ! * * ! * dref /fmcof/ block reference length for * ! * input moment about z axis * ! * * ! * du /bcond/ bconcl boundary condition coefficient* ! * bcopt of upper surface perturbation * ! * ccof potential * ! * btrnsf * ! * * ! * du1 /bcon/ block first boundary condition * ! * input coefficient of upper surface * ! * bconcl perturbation potential * ! * * ! * du2 /bcon/ block second boundary condition * ! * input coefficient of upper surface * ! * bconcl perturbation potential * ! * * ! * dvdd /pivm/ eivc dependence on doublet values * ! * pivc at nine canonical panel points* ! * of potential (and possibly * ! * velocity) at control point * ! * induced by panel doublet * ! * distribution * ! * influence coefficient blocks * ! * * ! * dvdfs /skrch1/ vtrns potential and velocity * ! * influence coefficients * ! * * ! * dvds /pivm/ pivc dependence on taylors series * ! * source coefficients of * ! * potential (and possibly * ! * velocity) at control point * ! * induced by panel source * ! * distribution * ! * * ! * en /pandq/ geomc unit normal (in global * ! * coordinates) to each plane * ! * surface of panel. first four * ! * vectors are normals to outer * ! * triangles and fifth is normal * ! * to inner parallelogram * ! * * ! * e1 /pandq/ ffdqg source monopole potential and * ! * veolcity far field moments * ! * * ! * e2 /pandq/ ffdqg source dipole potential and * ! * veolcity far field moments * ! * * ! * e4 /pandq/ ffdqg source quadrupole potential * ! * and velocity far field * ! * moments * ! * * ! * error /cm05/ block error flag * ! * * ! * fsv /acase/ flow freestream velocity vectors * ! * * ! * fsvm /acase/ block magnitude of freestream * ! * input velocity * ! * * ! * f1 /pandq/ ffdqg doublet monopole veolcity * ! * far field moments * ! * * ! * f2 /pandq/ ffdqg doublet dipole veolcity * ! * far field moments * ! * * ! * f4 /pandq/ ffdqg doublet quadrupole velocity * ! * far field moments * ! * * ! * ibconp /prnt/ block boundary condition print flag * ! * input =1 if print desired * ! * * ! * icontp /prnt/ block control point diagnostic * ! * input print flag * ! * * ! * icrchr /skrch1/ abtanl network corner control * ! * point characterization * ! * = 0 no control point * ! * = 1 to 4 * ! * control point matches * ! * doublet strength along * ! * abutment to which side * ! * 1 to 4 belongs * ! * = 5 control point forces * ! * doublet strength to * ! * vanish * ! * = 6 control point retains * ! * original boundary * ! * conditions * ! * * ! * ics /pandq/ iscal =0 - panel is quadrilateral * ! * =1 thru 4 - panel is triangle * ! * because edge ics is * ! * collapsed * ! * * ! * iedgep /prnt/ block =1 if edge matching * ! * input diagnostic printout is * ! * desired * ! * * ! * igeomp /prnt/ block geometry print flag =1 if * ! * input print desired * ! * * ! * iid /pandq/ daspl index array for panel doublet * ! * sing singularity parameters * ! * * ! * iin /pandq/ geomc sub-panel inclination * ! * flag * ! * =+1 subinclined * ! * =-1 superinclined * ! * * ! * iis /pandq/ sing index array for panel source * ! * singularity parameters * ! * * ! * ind /pandq/ daspl number of doublet singularity * ! * sing parameters on which panel * ! * doublet distribution depends * ! * * ! * ins /pandq/ sing number of source singularity * ! * parameters on which panel * ! * source distribution depends * ! * * ! * ipc /cntrq/ contrl index of panel on which * ! * control point zc lies * ! * * ! * ipn /pandq/ geomc index of panel whose defining * ! * quantities are currently in * ! * common block /pandq/ * ! * * ! * ipot /index/ block indicator for alternate * ! * input potential and velocity * ! * computations * ! * =-2 lower surface values to be* ! * computed from singularity * ! * splines only * ! * =-1 lower surface values to be* ! * computed from singularity * ! * splines and influence * ! * coefficients * ! * =0 values to be computed * ! * from influence * ! * coefficients only * ! * =+1 upper surface values to be* ! * computed from singularity * ! * splines and influence * ! * coefficients * ! * =+2 upper surface values to be* ! * computed from singularity * ! * splines only * ! * * ! * ipraic /prnt/ block =0 if no pic diagnostic * ! * input printout is desired * ! * =k if pic diagnostic print- * ! * out is desired for kth * ! * control point * ! * * ! * iray /solnt/ block part of the calling sequence * ! * to the solution package * ! * see subroutine tinver for * ! * further description * ! * * ! * isdchr /skrch1/ abtanl network edge control point * ! * characterization * ! * = 0 no control points * ! * = 1 to 4 * ! * control points match * ! * doublet strength along * ! * abutment to which side * ! * 1 to 4 belongs * ! * = 5 control points force * ! * doublet strength to * ! * vanish * ! * = 6 control points retain * ! * original boundary * ! * conditions * ! * * ! * isingp /prnt/ block singularity spline diagnostic * ! * input print flag * ! * * ! * isings /prnt/ block singularity print flag * ! * input =1 if singularity strength * ! * on each panel is to be printed* ! * * ! * its /pandq/ daspl panel singularity type * ! * sing =1 source alone * ! * =2 doublet alone * ! * =3 source and doublet * ! * * ! * jcn /cntrq/ contrl overall index of control point* ! * whose defining quantities are * ! * currently in common block * ! * /cntrq/ * ! * * ! * jobmes /cm49/ block job status and message flag * ! * * ! * jzc /cntrq/ contrl cumulative row/column index * ! * of zc in network kc * ! * * ! * nacase /acase/ block number of freestream cases * ! * input for simultaneous solution * ! * * ! * naic /solnt/ block i/o unit on which the aic * ! * matrix resides * ! * * ! * nans /solnt/ block i/o unit on which the solution* ! * matrix resides * ! * * ! * nbc /index/ bconcl number of boundary condition * ! * records for each network * ! * * ! * nbca /index/ bconcl cumulative sum of nbc * ! * * ! * nbcot /index/ bconcl total number of boundary * ! * conditions * ! * * ! * nbdq /brwi/ block number of boundary condition * ! * defining quantities per block * ! * * ! * nc /index/ contrl array containing the number * ! * of control points in each * ! * network * ! * * ! * nca /index/ tcntrl array containing cumulative * ! * sum of array nc * ! * * ! * ncd /pandq/ daspl number of parameters (i.e. * ! * sing quadratic coefficients) * ! * defining panel doublet * ! * distribution * ! * * ! * ncdq /crwi/ block number of control point * ! * defining quantities per block * ! * * ! * ncs /pandq/ sing number of parameters (i.e. * ! * linear coefficients) defining * ! * panel source distribution * ! * * ! * nct /bcond/ bconcl boundary condition left hand * ! * bcopt side coefficient descriptor * ! * ccof =1 non-zero normal mass flux * ! * btrnsf coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * nctrt /index/ tcntrl total number of control points* ! * * ! * nct1 /bcon/ block first boundary condition left * ! * input hand side coefficient * ! * bconcl descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * nct2 /bcon/ block second boundary condition left* ! * input hand side coefficient * ! * bconcl descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * ndtchk /datchk/ block data check flag * ! * input =1 data check only desired * ! * full solution otherwise * ! * * ! * nib /brwi/ fee index array for ntb * ! * * ! * nic /crwi/ fee index array for ntc * ! * * ! * nis /srwi/ fee index array for nts * ! * * ! * niv /vrwi/ fee index array for ntv * ! * * ! * nlopt /bcond/ bconcl indicator governing left hand * ! * bcopt side coefficient selection * ! * btrnsf * ! * * ! * nlopt1 /bcon/ block first boundary condition * ! * input left hand side coefficient * ! * bconcl option indicator * ! * * ! * nlopt2 /bcon/ block second boundary condition * ! * input left hand side coefficient * ! * bconcl option indicator * ! * * ! * nm /index/ input array containing number of * ! * rows in each network corner * ! * point grid * ! * * ! * nn /index/ input array containing number of * ! * columns in each network * ! * corner point grid * ! * * ! * nnb /brwi/ block length of nib * ! * * ! * nnc /crwi/ block length of nic * ! * * ! * nnett /index/ input number of networks * ! * * ! * nns /srwi/ block length of nis * ! * * ! * nnv /vrwi/ block length of niv * ! * * ! * np /index/ geomc array containing number of * ! * panels in each network * ! * * ! * npa /index/ tgeomc array containing cumulative * ! * sum of array np * ! * * ! * npant /index/ tgeomc total number of panels * ! * * ! * nrhs /solnt/ block i/o unit on which the right * ! * hand side matrix resides * ! * * ! * nropt /bcond/ bconcl indicator governing right hand* ! * bcopt side value selection * ! * btrnsf * ! * * ! * nropt1 /bcon/ block first boundary condition * ! * input right hand side value * ! * bconcl option indicator * ! * * ! * nropt2 /bcon/ block second boundary condition * ! * input right hand side value * ! * bconcl option indicator * ! * * ! * nrb /brwi/ block current record in buffer * ! * itrns * ! * trns * ! * * ! * nrc /crwi/ block current record in buffer * ! * itrns * ! * trns * ! * * ! * nsb /brwi/ block number of boundary condition * ! * defining quantity blocks in * ! * buffer * ! * * ! * nsc /crwi/ block number of control point * ! * defining quantity blocks in * ! * buffer * ! * * ! * nsc1 /solnt/ block scratch i/o unit for * ! * solution package use * ! * * ! * nsc2 /solnt/ block scratch i/o unit for * ! * solution package use * ! * * ! * nsc3 /solnt/ block scratch i/o unit for * ! * use in generating influence * ! * coefficients * ! * * ! * nsc4 /solnt/ block scratch i/o unit used for * ! * transposing blocks of * ! * influence coefficients * ! * * ! * nsd /index/ daspl number of doublet singularity* ! * sing parameters in each network * ! * * ! * nsda /index/ tsing array containing cumulative * ! * sum of singularity parameters * ! * in previous networks and in * ! * source spline of current * ! * network * ! * * ! * nsdq /srwi/ block number of panel defining * ! * quantities per block * ! * * ! * nsngk /index/ bcan total number of known * ! * singularity parameters * ! * * ! * nsngt /index/ tsing total number of singularity * ! * parameters * ! * * ! * nsngu /index/ bcan total number of unknown * ! * singularity parameters * ! * * ! * nss /index/ sing number of source singularity * ! * parameters in each network * ! * * ! * nssa /index/ tsing array containing cumulative * ! * sum of singularity parameters * ! * in previous networks * ! * * ! * nsymm /symm/ block symmetry flag * ! * input =0 no planes of symmetry* ! * =1 x-z plane of symmetry* ! * =2 x-z and x-y plane * ! * of symmetry * ! * * ! * ntb /brwi/ block file on which boundary * ! * condition defining quantity * ! * blocks are stored * ! * * ! * ntc /crwi/ block file on which control point * ! * defining quantity blocks are * ! * stored * ! * * ! * ntd /index/ input array containing network * ! * doublet types * ! * * ! * nts /index/ input array containing network * ! * source types * ! * * ! * nts /srwi/ block file on which panel defining * ! * quantity blocks are stored * ! * * ! * ntsin /cinout/ block system input device ! * * ! * ntsout /cinout/ block system output device ! * * ! * ntv /vrwi/ block file on which control point * ! * influence coefficient arrays * ! * are stored * ! * * ! * nvdq /vrwi/ vinfcc number of singularity * ! * parameters influencing control* ! * point * ! * * ! * nwv /vrwi/ vinfcc array containing number of * ! * components (0 thru 4) of * ! * influence coefficients stored * implicit double precision (a-h,o-z) ! * for each control point * ! * * ! * nz /index/ geomc array containing number of * ! * grid points in each network * ! * * ! * nza /index/ tgeomc array containing running * ! * sum of nz * ! * * ! * nzmpt /index/ tgeomc total number of grid points * ! * * ! * p /pandq/ tgeomc coordinates of four panel * ! * corner points in local central* ! * sub-panel coordinate system * ! * * ! * pi /ncons/ block 3.14159 etc. * ! * * ! * pi2 /ncons/ block 2.*pi * ! * * ! * pi4i /ncons/ block 1./(4.*pi) * ! * * ! * pp /pandq/ psddqg coordinates of sub-panel * ! * vertices in repective sub- * ! * panel coordinate systems * ! * * ! * * ! * qa /pandq/ psddqg dependence of coefficients of * ! * near plane approximate * ! * quadratic doublet distribution* ! * on doublet value at nine * ! * canonical panel points * ! * * ! * qi /qnfq/ qnfdqg dependence of coefficients of * ! * two sub-panel approximate * ! * cubic doublet distribution * ! * on doublet value at nine * ! * canonical panel points * ! * * ! * qq /pandq/ psddqg transformation from doublet * ! * values at nine canonical panel* ! * points to quadratic taylor * ! * coefficients in local * ! * sub-panel coordinate systems * ! * * ! * rr /pandq/ psddqg matrix describing the * ! * dependence of each sub-panel * ! * linear source coefficients * ! * on the overall panel linear * ! * linear source coefficients * ! * * ! * sbetam /comprs/ flow sign of betams * ! * * ! * sgnx /norx/ pifcal superinclined panel * ! * qnfcal orientation parameter * ! * * ! * sref /fmcof/ block reference area for force * ! * input and moment calculations * ! * * ! * tl /bcond/ bconcl boundary condition coefficient* ! * bcopt vector of lower surface per- * ! * ccof turbation tangential velocity * ! * btrnsf * ! * * ! * tl1 /bcon/ block t first boundary condition * ! * input coefficient vector of lower * ! * bconcl surface perturbation * ! * tangential velocity * ! * * ! * tl2 /bcon/ block t second boundary condition * ! * input coefficient vector of lower * ! * bconcl surface perturbation * ! * tangential velocity * ! * * ! * tu /bcond/ bconcl boundary condition coefficient* ! * bcopt vector of upper surface per- * ! * ccof turbation tangential velocity * ! * btrnsf * ! * * ! * tu1 /bcon/ block t first boundary condition * ! * input coefficient vector of upper * ! * bconcl surface perturbation * ! * tangential velocity * ! * * ! * tu2 /bcon/ block second boundary condition * ! * input coefficient vector of upper * ! * bconcl surface perturbation * ! * tangential velocity * ! * * ! * w1 /pandq/ ffdqg doublet monopole potential * ! * far field moments * ! * * ! * w2 /pandq/ ffdqg doublet dipole potential * ! * far field moments * ! * * ! * w4 /pandq/ ffdqg doublet quadrapole potential * ! * far field moments * ! * * ! * xref /fmcof/ block global x coordinate of * ! * input origin for moment calculations* ! * * ! * yref /fmcof/ block global y coordinate of * ! * input origin for moment calculations* ! * * ! * zc /cntrq/ contrl control point position in * ! * zcadj global coordinates * ! * * ! * zdc /cntrq/ contrl control point function flag * ! * =0. panel center control * ! * point with specified * ! * boundary conditions * ! * =-1. network edge control * ! * point with specified * ! * boundary conditions * ! * =1. to 4. * ! * network edge control * ! * point used to match * ! * doublet strength across * ! * respective network edge * ! * 1. to 4. * ! * * ! * zm /mspnts/ input coordinates of grid points * ! * of all networks in the * ! * global coordinate system * ! * * ! * znc /cntrq/ contrl upper surface normal at * ! * control point (in global * ! * coordinates) * ! * * ! * zref /fmcof/ block global z coordinate of * ! * input origin for moment calculations* ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call brwi parameter (nsbp=6) common/brwi/nbdq,nsb,nrb,ntb,nnb,nib((maxcp+nsbp-1)/nsbp+1) !end brwi !call crwi parameter (nscp=13) common/crwi/ncdq,nsc,nrc,ntc,nnc,nic((maxcp+nscp-1)/nscp+1) !end crwi !call srwi common/srwi/nsdq,nss,nrs,nts,nns,nis(maxpan+1) !end srwi !call vrwi common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp) !end vrwi !call irwi common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21) !end irwi !call skrch1 common /skrch1/ w(9000000) !end skrch1 !call secprp common /secprp/ optcrd(5), optmrp(5), cutdat(9,5,25) & & , actfx, actfy, actfz, actmx, actmy, actmz, actar & & , refeta(5) & & , numgrp, numnet(5), netdat(5,150,2), numcut(5) & & , igrps, isecpr(5) & & , iprtnf(5), iprtpp(5), ixyzop(5), iform(150,2) & & , nosnet, icomop, isignl, icomtd(150) !end secprp !c ! * print out job status and cost for step just completed * !call xcntrl common /xcntrl/ icntrl,jcntrl !end xcntrl !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser !call xrwi common /xrwi/ ntxrwi, nnxrwi, nwxrwi(200), nixrwi(202) !end xrwi !call yrwi common /yrwi/ ntyrwi, nnyrwi, nwyrwi(200), niyrwi(202) !end yrwi !call lamrwi common /lamrwi/ ntlam, nnlam, nilam(302) !end lamrwi !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp !call datchk common/datchk/ndtchk ! /datchk/ !end datchk parameter (ncmax=50) !call jobsum common /jobsum/ nc, ncdum, tdata(12,ncmax) ! /jobsum/ common /jobsch/ ttljob(ncmax) character*8 ttljob !end jobsum !call dictms common /dictms/ nrecmx(100), llindx(100), ndirwr(100) & ! /dictms & , rwmstr & & , lldict, lldmax, indxms(2,800000) & & , buffms(512) integer buffms logical rwmstr !end dictms !call locinf common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i ! /locinf/ double precision rlocdm !end locinf !call rlcplx ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc ! /rlcplx/ !end rlcplx !call vercom common /vercom/ versn ! /vercom/ character*45 versn !end vercom CHARACTER(LEN=80):: fileName INTEGER:: errCode CHARACTER(LEN=*),PARAMETER:: VERSION = "15.0 (10 December 2009)" !------------------------------------------------------------------------------- WRITE(*,*) 'Panair High Order Panel Code, Version '//VERSION DO WRITE(*,*) 'Enter name of input file:' READ(*,'(A)') fileName IF (fileName =='') STOP OPEN(UNIT=5, FILE=fileName, & & IOSTAT=errCode, STATUS='OLD', ACTION='READ') IF (errCode .EQ. 0) EXIT WRITE(*,*) 'Unable to find this file. Try again' END DO INQUIRE(UNIT=5, NAME=fileName) OPEN(UNIT=6, FILE='panair.out', STATUS='REPLACE') OPEN(UNIT=7, FILE='panair.err', STATUS='REPLACE') ! ! define sizes of integers and reals ! relative to what loc returns !!! kkloci = locfcn(ilocdm(2)) - locfcn(ilocdm(1)) !!! kklocr = locfcn(rlocdm(2)) - locfcn(rlocdm(1)) !!! above statements commented out and replaced with the following !!! by RLC 23 August 2011 INQUIRE(IOLENGTH=kkloci) ilocdm(1) INQUIRE(IOLENGTH=kklocr) rlocdm(1) kklocr = 1*kklocr kkloci = 1*kkloci kklr2i = kklocr/kkloci call remarx ('++ Running A502, F.T. Johnson, M.A. Epton et al') versn = 'PDAS version j01, 08 Dec 2020 ' !---- versn = 'version id = ht2 (12 feb 92) boeing ver i00 ' ! 123456789012345678901234567890123456789012345 call remarx (versn) ityprc = 1 !... Set up to use nw words as dynamic memory nw = 9000000 call inicor (nw,w, .false., .false., .true.) !!! call inisec ! removed by RLC 1 Jan 97 nc = 0 ! initialize /dictms/ lldmax = 800000 lldict = 0 do 100 k = 1,100 nrecmx(k) = 0 llindx(k) = -1 ndirwr(k) = 0 100 continue call block !--- call link('unit5=(input,open,text), !--- x output=terminal,unit6=(output,create,text,line=150), !--- x print6=(output,create,text,line=150)//') open(unit=8 ,file='ft08',form='unformatted',status='REPLACE') open(unit=9 ,file='ft09',form='unformatted',STATUS='REPLACE') open(unit=13,file='ft13',form='formatted',STATUS='REPLACE') open(unit=18,file='ft18',form='unformatted',STATUS='REPLACE') open (unit=93,file='ft93',form='unformatted',status='REPLACE') open (unit=69,file='ft88',form='unformatted',status='REPLACE') open (unit=89,file='ft89',form='unformatted',status='REPLACE') open (unit=98,file='ft98',form= 'formatted',status='REPLACE') open (unit=99,file='ft99',form='unformatted',status='REPLACE') ! pvinfc files, nsqg, nsqb open (unit=31,file='ft31',form='unformatted',status='REPLACE') open (unit=32,file='ft32',form='unformatted',status='REPLACE') call wopen( 1, 10,0,ierr) call wopen( 2, 10,0,ierr) call wopen( 3, 10,0,ierr) call openms(ntlam,nilam,nnlam,0) call openms(ntb,nib,nnb,0) call openms(nts,nis,nns,0) call openms(ntc,nic,nnc,0) call openms(nti,nii,nni,0) call openms(ntxrwi,nixrwi,nnxrwi,0) call jzero (nwxrwi,200) ! why not just nwxrwi(:)=0 ?? call openms (ntyrwi,niyrwi,nnyrwi,0) call icopy (200, 0,0, nwyrwi,1) ! why not just nwyrwi(:)=0 ?? ! call cstprt ('initialz') !--- call upt ( !--- x 'a502i00' !--- x ,'d22012' !--- x ) ! * solve case * call flow call writms (ntxrwi,nwxrwi,200,201,-1,0) call closms (ntxrwi) call closms (ntlam) call closms (nts) ! *** icntrl = 8 ! *** call eblock write (6,'( " rwms pkg, lldict:", I6 )') lldict call outvci ('llindx',100,llindx) call outvci ('nrecmx',100,nrecmx) call cstsum call frecor (' ') stop END program a502 ! ===================================================== ! **deck a502er subroutine a502er(sub,msg) implicit double precision (a-h,o-z) character*(*) sub,msg character*50 xmsg write (6,6000) sub,msg 6000 format ('0 ***** fatal error in routine: ',a8, & & ' job will terminate immediately ***** '/ & & 22x,'message: ',a80) xmsg(1:7) = 'a502er ' xmsg(8:13)= sub xmsg(14:50)= msg call remarx (xmsg) CALL AbortPanair('a502bd') return END subroutine a502er ! **deck a502ms subroutine a502ms(sub,msg) implicit double precision (a-h,o-z) character*(*) sub,msg character*50 xmsg !call a502cn common /a502cn/ i502er !end a502cn write (6,6000) sub,msg 6000 format ('0 ***** fatal error in routine: ',a8, & & ' job will terminate at next check point **************'/ & & 22x,'message: ',a80 ) i502er = i502er + 1 xmsg(1:7) = 'a502ms ' xmsg(8:13)= sub xmsg(14:50)= msg if ( i502er.lt.100 ) call remarx (xmsg) return END subroutine a502ms ! **deck a502wr subroutine a502wr (label,lmsg) implicit double precision (a-h,o-z) character*(*) label,lmsg character*50 xmsg ! ! ! write (6,6000) label, lmsg 6000 format ('0 ***** warning ***** possible error condition' & & ,' detected in subroutine: ',a8 & & ,/,20x,a80) xmsg(1:7) = 'a502wr ' xmsg(8:13)= label xmsg(14:50)= lmsg call remarx (xmsg) return END subroutine a502wr !+ SUBROUTINE AbortPanair(a) ! ------------------------------------------------------------------------------ ! PURPOSE - Stop processing immediately. Renamed from Abort by RLC, Mar2009, ! to avoid conflict with intrinsic subroutine ABORT in gfortran and g95. CHARACTER(LEN=*),INTENT(IN):: a CHARACTER(LEN=*),PARAMETER:: FMT= '(" ABORT called by ",A,". PanAir is stopping.")' !------------------------------------------------------------------------------- WRITE(7,FMT) a WRITE(6,FMT) a STOP END Subroutine AbortPanair ! ------------------------------------------------- ! **deck abt2fg subroutine abt2fg (iul,kedg,i1kseg,i2kseg,kzedg,kncedg,knfsg & & ,jul,ledg,i1lseg,i2lseg,lzedg,lncedg,lnfsg & & ,nefgst,nefgsa,kptefg, ipmx,iptr,kkvlst,wtvlst & & ,nm,nn,z,nnett,epsgeo & & ) implicit double precision (a-h,o-z) dimension nefgsa(nefgst), kptefg(1:*) & & , kkvlst(2,1:*), wtvlst(2,1:*) dimension nm(1:*), nn(1:*), z(3,1:*) ! ! enter into the data structure: [kptefg,(iptr,kkvlst,wtvlst)] ! the equivalence relations of edge segment (kedg,i1kseg,i2kseg) ! which abuts edge segment (ledg,i1lseg,i2lseg). Note that ! in order to enter the full set of equivalence relations, ! abt2fg is called twice, the second time reversing the roles ! of the two edge segments ! dimension zfgk(3), zfgl(3), zy(3) ! kzfsg = kzedg + (i1kseg - 1)*kncedg lzfsg = lzedg + (i1lseg - 1)*lncedg do 400 ifg = 2*i1kseg,(2*i2kseg-2) call edgfgi (iul,kedg,ifg, nm,nn,nefgsa, kkmp) imp1 = (ifg+1)/2 imp2 = (ifg+2)/2 kz1 = kzedg + (imp1-1)*kncedg kz2 = kzedg + (imp2-1)*kncedg call avg2pt (z(1,kz1),z(1,kz2),zfgk) ! find fine grid point on ledg nearest ! to zfgk. if the match is close, ! enter equivalence relation call nredge (zfgk, z(1,lzfsg),lncedg,lnfsg & & ,1,0.d0, zy,ty,dy) ty = ty + i1lseg - 1 tty = 2.d0*ty - 1.d0 jfg1 = tty jfg1 = max( 2*i1lseg-1, min( 2*i2lseg-2, jfg1) ) jfg2 = jfg1 + 1 ! yfg1 = jfg1 yfg2 = jfg2 if ( abs(yfg1-tty) .lt. 1.d-5 ) goto 320 if ( abs(yfg2-tty) .lt. 1.d-5 ) goto 340 goto 360 ! jfg1 looks close. make final check 320 continue jmp1 = (jfg1+1)/2 jmp2 = (jfg1+2)/2 lz1 = lzedg + (jmp1-1)*lncedg lz2 = lzedg + (jmp2-1)*lncedg call avg2pt (z(1,lz1),z(1,lz2),zfgl) call distnc (zfgk,zfgl,dzfg) if ( dzfg .gt. epsgeo ) goto 360 call edgfgi (jul,ledg,jfg1, nm,nn,nefgsa, llmp) call mpteqc (kptefg,nefgst, kkmp,llmp) goto 400 ! jfg2 looks close. make final check 340 continue jmp1 = (jfg2+1)/2 jmp2 = (jfg2+2)/2 lz1 = lzedg + (jmp1-1)*lncedg lz2 = lzedg + (jmp2-1)*lncedg call avg2pt (z(1,lz1),z(1,lz2),zfgl) call distnc (zfgk,zfgl,dzfg) if ( dzfg .gt. epsgeo ) goto 360 call edgfgi (jul,ledg,jfg2, nm,nn,nefgsa, llmp) call mpteqc (kptefg,nefgst, kkmp,llmp) goto 400 ! fine grid point does not match up, ! add entry to (kkvlst,wtvlst). 360 continue iptr = iptr + 1 if ( iptr.gt.ipmx ) then write (7,'('' kedg,iul, ledg,jul, ipmx,iptr'',3(2x,2i6))') & & kedg,iul, ledg,jul, ipmx,iptr call a502er ('abt2fg',' overflow of wtvlst/kkvlst buffers') endif kptefg(kkmp) = -iptr call edgfgi (jul,ledg,jfg1, nm,nn,nefgsa, llmp1) call edgfgi (jul,ledg,jfg2, nm,nn,nefgsa, llmp2) w2 = tty - yfg1 w1 = 1.d0 - w2 jmpa = (jfg1+1)/2 jmpb = (jfg2+2)/2 if ( mod(jfg2,2).eq.0 ) then wa = (1.d0+w1)/2.d0 wb = w2/2.d0 else wa = w1/2.d0 wb = (1.d0+w2)/2.d0 endif wtvlst(1,iptr) = w1 wtvlst(2,iptr) = w2 kkvlst(1,iptr) = llmp1 kkvlst(2,iptr) = llmp2 lza = lzedg + (jmpa-1)*lncedg lzb = lzedg + (jmpb-1)*lncedg zfgl(1) = wa*z(1,lza) + wb*z(1,lzb) zfgl(2) = wa*z(2,lza) + wb*z(2,lzb) zfgl(3) = wa*z(3,lza) + wb*z(3,lzb) call distnc (zfgk,zfgl,dzfg) if ( dzfg.gt.epsgeo ) then call a502ms ('abt2fg','fine grid matching error') endif goto 400 ! 400 continue ! ! ! return END subroutine abt2fg !! subroutine abtabo (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,zsv & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtabo subroutine abtabo (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,zsv & ! Added by Martin Hegedus, 4/21/09 & ,iedgtp, nedmpa, kposab & & ,nfdseg,kfdseg,kfdkey,kfdsgn & & ,iabtx,nedaba,mtchab & & ,nedmp,kempec,tauemp,kptemp,nbraia,ifsgai & & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension zsv(3,4000) dimension iedgtp(600), nedmpa(601), kposab(750) dimension kfdseg(3200), kfdkey(800), kfdsgn(800) dimension nedaba(mxnabt+1), mtchab(4,mxnabt) dimension kempec(1000), tauemp(1000), kptemp(1000), nbraia(250) & & , ifsgai(2,800) ! dimension taulst(mxedmp) & & , keclst(mxedmp), kecedg(mxedmp), keytau(mxedmp) dimension labten(21) logical ident logical anedge, sided6, pesed6 !call lndblx ! /lndblx/ common /lndblx/ genwak(3,mxnett), slndbl(mxnett) & & , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett) !end lndblx !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg character*8 mtchtp,nwtp,char !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser character*6 poslbl(3) data poslbl / 'first ', 'second', 'both ' / ! print the descriptions of all the ! abutments iabt = iabs( iabtx ) iedg1 = nedaba(iabt) + 1 iedg2 = nedaba(iabt+1) ne = nedaba(iabt+1) - nedaba(iabt) ifsg = kfdkey(iedg1) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) jfsgmu = mtchab(1,iabt) jfsgwk = mtchab(2,iabt) jfsgvd = mtchab(3,iabt) idcpm = mtchab(4,iabt) ! print a header for the abutment kpos = kposab(iabt) iwarn = 0 if ( ne.gt.1 ) go to 500 ! if ( jfsgmu.ne.0 ) iwarn = 1 knet = (kedseg-1)/4+1 ksd = kedseg - 4*(knet-1) ntdk = ntd(knet) if ( ntdk.ne.18 .and. ntdk.ne.20 .and. ntdk.ne.6 ) goto 500 if ( kpos.ne.0 ) go to 500 if ( ksd.eq.1 .and. ntdk.eq.18 ) iwarn = 2 if ( ksd.eq.1 .and. ntdk.eq.6 ) iwarn = 2 if ( ksd.eq.1 .and. ntdk.eq.20 ) iwarn = 3 if ( ksd.eq.2 .or. ksd.eq.4 ) iwarn = 4 if ( ksd.eq.3 .and. idsvfw(knet).ne.0 ) iwarn = 5 if ( ksd.eq.3 .and. idsvfw(knet).eq.0 ) iwarn = 6 ! 500 continue if ( iwarn.eq.2 ) call a502ms('abtabo' & & ,'detached leading edge on type 18 wake nw') if ( iwarn.eq.0 ) write (6,9100) iabt if ( iwarn.eq.1 ) write (6,9101) iabt if ( iwarn.eq.2 ) write (6,9102) iabt if ( iwarn.eq.3 ) write (6,9103) iabt if ( iwarn.eq.4 ) write (6,9104) iabt if ( iwarn.eq.5 ) write (6,9105) iabt if ( iwarn.eq.6 ) write (6,9108) iabt anedge = .false. sided6 = .false. pesed6 = .false. do 600 iedg = iedg1,iedg2 ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) knet = (kedseg-1)/4 + 1 ksd = kedseg - 4*(knet-1) ntdk = ntd(knet) if ( ntdk.eq.12 & & .or. (ntdk.eq.18 .and. ksd.eq.1) & & .or. (ntdk.eq.6 .and. ksd.eq.1) & & ) anedge = .true. if ( ntdk.ne.6 ) go to 600 if ( ksd.eq.1 .or. ksd.eq.3 ) go to 600 ! side edge, type 6 nw sided6 = .true. call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) if ( i1kseg.ne.1 .or. i2kseg.ne.knedg ) pesed6 = .true. 600 continue if ( anedge .and. sided6 ) write (6,9106) if ( pesed6 ) write (6,9107) kpos = min ( 3, max (0, kpos) ) if ( kpos.ne.0 ) write (6,9200) poslbl(kpos) taulst(1) = 0.d0 if ( kfdsgn(ifsg) .lt. 0 ) taulst(1) = 1.d0 taulst(2) = 1.d0 - taulst(1) ntau = 2 do 5600 iend = 1,2 nabten = 0 ikseg = i1kseg if ( iend.eq.2 ) ikseg = i2kseg call edgmpi (kedseg,ikseg,nedmpa, kmp) impec = iabs( kempec(kmp) ) keclst(iend) = impec kpt1 = nbraia(impec) + 1 kpt2 = nbraia(impec+1) do 5540 kpt = kpt1,kpt2 call addin2 (nabten,labten, +kfdsgn(ifsgai(1,kpt))) call addin2 (nabten,labten, -kfdsgn(ifsgai(2,kpt))) if ( nabten.gt.20 ) call abtend('nabten overflow, 5540 loop') 5540 continue if ( iend.eq.1 ) impec1 = impec if ( iend.eq.2 ) impec2 = impec if ( iabtx .lt. 0 ) go to 5600 ! *** write (6,9010) impec, (labten(i),i=1,nabten) 5600 continue write (6,9011) impec1, impec2 do 5800 iedg = iedg1,iedg2 ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kedg = kedseg isgn = isign( 1, kfdsgn(ifsg) ) knet = (kedg-1)/4 + 1 ksd = kedg - 4*(knet-1) ietype = iedgtp(kedg) impx1 = i1kseg + 1 impx2 = i2kseg - 1 if ( impx1.gt.impx2 ) go to 5710 do 5700 impx = impx1,impx2 imp = impx if ( isgn.lt.0 ) imp = i1kseg + i2kseg - impx call edgmpi ( kedseg,imp,nedmpa, iedmp) if ( kempec(iedmp).lt.0 ) go to 5700 ntau = ntau + 1 taulst(ntau) = tauemp(iedmp) keclst(ntau) = kempec(iedmp) kmp = iedmp nloop = 0 5650 continue nloop = nloop + 1 if ( nloop .gt. mxempt ) call abtend & & ('abtabo: infinite loop trapped (1)') kempec(kmp) = -iabs(kempec(kmp)) kmp = kptemp( kmp ) if ( kmp .ne. iedmp ) go to 5650 ! 5700 continue 5710 continue 5800 continue call dshell (ntau,taulst,keytau) call keysrt (ntau,keclst,keytau) ! + call outvec ("taulst",ntau,taulst) ! + call outvec ("keclst",ntau,keclst) call jshell (ntau,keclst,keytau) ! + call outvec ("keclst",ntau,keclst) ! + call outvec ("keytau",ntau,keytau) mtchtp = ' ' if ( idcpm .eq. 1 ) mtchtp = 'vor-mtch' if ( idcpm .eq. 2 ) mtchtp = 'cp2-mtch' if ( idcpm .eq. 3 ) mtchtp = 'cpi-mtch' do 5900 iedg = iedg1,iedg2 ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kedg = kedseg isgn = isign( 1, kfdsgn(ifsg) ) knet = (kedg-1)/4 + 1 ksd = kedg - 4*(knet-1) ietype = iedgtp(kedg) nwtp = ' ' char = ' ' if ( ifsg .eq. jfsgmu ) char = 'mu-match' if ( ifsg.eq.jfsgwk ) nwtp = mtchtp if ( ifsg.eq.jfsgvd ) char = mtchtp call jzero (kecedg,ntau) do 5850 impx = i1kseg,i2kseg imp = impx if ( isgn.lt.0 ) imp = i1kseg + i2kseg - impx call edgmpi (kedseg,imp,nedmpa, iedmp) call cmpied (iedmp, nnett,nedmpa,nza,nm,nn, kz) call pident (z(1,kz), zsv(1,kz), ident) impec = iabs( kempec(iedmp) ) kempec(iedmp) = impec call ibsrch (keclst,ntau,impec, loc) loc = loc + 1 if ( loc.gt.ntau ) go to 5850 if ( keclst(loc).ne.impec ) go to 5850 if ( .not. ident ) imp = -imp impabt = keytau(loc) if ( impx.eq.i1kseg ) impabt = 1 if ( impx.eq.i2kseg ) impabt = ntau kecedg(impabt) = imp 5850 continue write (6,9012) knet,ksd,iduser(knet) & & ,ntd(knet),ietype,char,nwtp & & , (kecedg(i),i=1,ntau) 5900 continue return 9100 format ('0abutment #',i4,4x, & &' '& &,20x,' ' ) 9101 format ('0abutment #',i4,4x, & &'doublet strength matched to zero along this abutment '& &,20x,' *** warning ***' ) 9102 format ('0abutment #',i4,4x, & &'type 18 wake leading edge left unabutted '& &,20x,' *** fatal ***') 9103 format ('0abutment #',i4,4x, & &'type 20 wake leading edge left unabutted '& &,20x,'*** serious warning ***') 9104 format ('0abutment #',i4,4x, & &'wake side edge left unabutted '& &,20x,' *** warning ***') 9105 format ('0abutment #',i4,4x, & &'wake trailing edge unabutted. wake filaments will be added '& &,20x,' *** gentle reminder ***') 9106 format (19x, & &'abutment involving an analysis edge with a side edge of type 6' & &,' nw',19x,' *** warning ***') 9107 format (19x, & &'side edge of type 6 nw involved in partial edge abutment '& &,20x,' *** warning ***') 9108 format ('0abutment #',i4,4x, & &'wake trailing edge unabutted. wake filaments suppressed '& &,20x,' *** gentle reminder ***') 9200 format (' abutment lies on ',a6,' plane(s) of symmetry ') 9010 format ( ' abutment intersection #',i4,' has abutment ends:' & & ,20i4) 9011 format ( & &' dblt edge ' ,& &'starts at ai #',i4,' ends at ai #',i4,/, & &' nw.edge nw/id type type matching kutta-fl ' ,& &'corresponding edge points ( minus (-) indicates point moved by' ,& &' $eat ') 9012 format (1x,i3,1h.,i1,2x,a10,1x,i2,3x,i2,3x,a8,2x,a8,4x,20i4 & & ,/,(51x,20i4) ) END subroutine abtabo !! subroutine abtaio (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,iedgtp,icrntp, nedmpa, kposab & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtaio subroutine abtaio (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,iedgtp,icrntp, nedmpa, kposab & ! Added by Martin Hegedus, 4/21/09 & ,nfsga, nfdseg,kfdseg,kfdkey,kfdsgn & & ,nabint,nmpaia,kemkey,nbraia,ifsgai,mcmpai & & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! character xtra*5 dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension iedgtp(600), icrntp(600), nedmpa(601), kposab(751) dimension nfsga(601), kfdseg(3200), kfdkey(800), kfdsgn(800) dimension nmpaia(1001), nbraia(250), ifsgai(2,800), mcmpai(800) & & , kemkey(1000) dimension ipqbr(2,40), cbr(40), kbr(40), lbr(40), nwkbr(40) & & , nodbr(40), kfsgpk(40), ndmbr(40) & & , ipaben(40), ixtaib(40) dimension ipnod(80), lnod(80), knod(80) dimension encrn(3), emcrn(3), ux(3), vx(3) !call symcnd ! /symcnd/ common /symcnd/ isympa !end symcnd !call indxsp common /indxsp/ nxsptt, nxspa(151), locxsp(1200) & & , ngsptt, ngspa(151), locgsp(1200) !end indxsp !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg dimension locxex(4) logical pesed6 !call abtprt common /abtprt/ igeoin, igeout, nwxref, nwprop, iabutd & & , iabsum !end abtprt !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser character*3 chrpos(0:3) character*8 poslbl(0:3) character*4 chmatc(4), char data chmatc / '<---', '--->', 'aero', 'null' / data chrpos / ' ', '1st', '2nd', '1&2' / data poslbl / ' ', '1-st pos', '2-nd pos', 'both pos' / ! generate the (nbraia,ifsgai) data- ! structure describing the abutment if ( iabsum.ge.2 ) write (6,9100) nbraia(1) = 0 nxsptt = 0 ngsptt = 0 do 5500 iabint = 1,nabint kpt1 = nmpaia(iabint) + 1 kpt2 = nmpaia(iabint+1) ! find the unique (kfsg1,kfsg2) pairs ! associated with each equivalence clas nfsgpk = 0 do 5200 kpt = kpt1,kpt2 kmp = kemkey(kpt) call fsgcmp (kmp,nedmpa,nfsga,kfdseg,nnett & & ,kfsg1,kfsg2) !--- call xsgcmp (kmp,nedmpa,nfsga,kfdseg,nnett !--- x ,kfsg1x,kfsg2x) kfsg1x = kfsg1 kfsg2x = kfsg2 if ( kfsg1x.ne.kfsg1 .or. kfsg2x.ne.kfsg2 ) then write (7,8001) iabint,kfsg1,kfsg1x,kfsg2,kfsg2x & & , (kfdseg(l+4*kfsg1 -3),l=1,3) & & , (kfdseg(l+4*kfsg1x-3),l=1,3) & & , (kfdseg(l+4*kfsg2 -3),l=1,3) & & , (kfdseg(l+4*kfsg2x-3),l=1,3) endif 8001 format (' fsgcmp error, abtaio, iabint,kfsg*:', 5i6 & & ,/ ,3x,3i4,3x,3i4,3x,3i4,3x,3i4 ) kfsg12 = 10000 * kfsg1 + kfsg2 call addin2 (nfsgpk,kfsgpk, kfsg12) 5200 continue nbrbas = nbraia(iabint) nbraia(iabint+1) = nbrbas + nfsgpk ! assemble information about current ! AI for ABTINT analysis nnod = 0 nbr = 0 pesed6 = .false. ! do 5250 ifsgpk = 1,nfsgpk ! extract and save fundamental sgmt ! indices (node type indices) for ! current branch kfsg12 = kfsgpk(ifsgpk) kfsg1 = kfsg12 / 10000 kfsg2 = mod( kfsg12, 10000 ) ifsgai(1,ifsgpk+nbrbas) = kfsg1 ifsgai(2,ifsgpk+nbrbas) = kfsg2 ! define the abutment ends: ! initial pt: -iabt ! final pt : +iabt kabtx = kfdsgn( kfsg1 ) labtx = -kfdsgn( kfsg2 ) ! get usual info for 2 fund. segments call icopy (4, kfdseg(4*kfsg1-3),1, kokseg,1) call icopy (4, kfdseg(4*kfsg2-3),1, lokseg,1) kedg = kedseg call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) ledg = ledseg call mnmod (ledg,4,lsd,lnet) call edgind (lsd,nm(lnet),nn(lnet) & & ,lzedg,lncedg,lncint,lnedg) lzedg = lzedg + nza(lnet) ! increment the branch counter nbr = nbr + 1 ibr = nbr ipqbr(1,ibr) = kabtx ipqbr(2,ibr) = labtx ! put the abutment-end indices for ! the current control point into ! a single packed index in order ! to check for duplicates kkabtx = 2*iabs(kabtx) if ( kabtx.lt.0 ) kkabtx = kkabtx - 1 llabtx = 2*iabs(labtx) if ( labtx.lt.0 ) llabtx = llabtx - 1 kkabt = min(kkabtx,llabtx) llabt = max(kkabtx,llabtx) ipaben(ibr) = kkabt*10000 + llabt ! record if current branch corresponds ! to an extra control point ixtaib(ibr) = 0 if ( ksd.eq.lsd ) ixtaib(ibr) = 1 ! kzprv = previous pt on nw bdry ! kzcrn = corner pt on nw bdry ! kznxt = subsequent pt on nw bdry ndmbr(ibr) = 0 ! kzprv = kzedg + (i2kseg-2)*kncedg kzcrn = kzedg + (i2kseg-1)*kncedg kznxt = lzedg + i1lseg*lncedg ! define the branch type if ( kedg .eq. ledg ) go to 5220 ! regular corner kzint = kznxt + lncint kznrm = kzprv ledgp = mod(lsd,4) + 1 + 4*(lnet-1) if ( iedgtp(ledgp).eq.1 ) kznrm = kzint kbr(ibr)= icrntp(ledg) go to 5230 ! extra control point corner 5220 continue kzint = kzcrn + kncint kznrm = kzint kbr(ibr)= iedgtp(ledg) if ( ntd(knet).eq.6 .and. ksd.ne.1 ) kbr(ibr) = 2 if ( ntd(knet).eq.6 .and. ksd.ne.1 ) pesed6 = .true. 5230 continue ! set p-o-s info while doing 1st branch if ( ifsgpk .eq. 1 ) & !! & call abtpos ( z(1,kzcrn),epsgeo,nsymm, kpos ) ! Removed by Martin Hegedus, 4/21/09 & call abtpos ( z(1,kzcrn),epsgeo,nisym,njsym, kpos ) ! Added by Martin Hegedus, 4/21/09 ! generate error msg on dud branches if ( kbr(ibr) .ge. 2 ) go to 5232 call abtmsg(' dud branch encountered in a.i. scan') write (6,'(1x,a10,1x, 5i10)') & & ' ',iabint,ifsgpk,kabtx,labtx,knet write (6,'(1x,a10,1x, 4i10)') & & '1-st fes',knet,ksd,i1kseg,i2kseg write (6,'(1x,a10,1x, 4i10)') & & '2-nd fes',lnet,lsd,i1lseg,i2lseg 5232 continue ! define an extra v-parm point if ( ksd.eq.lsd ) then ngsptt = ngsptt + 1 locxex(1) = knet locxex(2) = ksd locxex(3) = i2kseg jfg = 2*i2kseg - 1 mfn = 2*nm(knet) - 1 nfn = 2*nn(knet) - 1 call edg2nw (jfg,ksd, mfn,nfn, ijfn) locxex(4) = ijfn call icopy (4, locxex,1, locgsp(4*ngsptt-3),1) endif ! detect if an extra c.p. must be added if ( ksd.ne.lsd .or. kbr(ibr).lt.4 ) go to 5235 ! no extra c.p.'s on type 6 nw, ! edges 2, 3, 4 if ( ntd(knet).eq.6 .and. ksd.ne.1 ) go to 5235 ! extra c.p. is defined and included nxsptt = nxsptt + 1 locxex(1) = knet locxex(2) = ksd locxex(3) = i2kseg if ( ksd.eq.1 ) icrs = 1 if ( ksd.eq.2 ) icrs = i2kseg if ( ksd.eq.3 ) icrs = nm(knet) if ( ksd.eq.4 ) icrs = nm(knet) + 1 - i2kseg if ( ksd.eq.1 ) jcrs = i2kseg if ( ksd.eq.2 ) jcrs = nn(knet) if ( ksd.eq.3 ) jcrs = nn(knet) + 1 - i2kseg if ( ksd.eq.4 ) jcrs = 1 ifn = 2*icrs - 1 jfn = 2*jcrs - 1 locxex(4) = ifn + (jfn-1)*(2*nm(knet)-1) call icopy (4, locxex,1, locxsp(4*(nxsptt)-3),1) 5235 continue ! compute nw normal at A.I. point call vadd (z(1,kzcrn), -1.d0, z(1,kznrm), ux, 3) call vadd (z(1,kznxt), -1.d0, z(1,kzcrn), vx, 3) call cross (ux,vx,encrn) call uvect (encrn) ! set the weight using an interior ! pointing tangent call vadd ( z(1,kzint), -1.d0, z(1,kzcrn), emcrn, 3) call uvect (emcrn) call vip ( comprs,1, emcrn,1, 3, cbr(ibr) ) ! set p-o-s info for the nodes (abmts) ! of this branch lbr(ibr) = 0 if ( mod(kpos,2) .eq. 1 .and. & & encrn(1)**2 +encrn(3)**2 .le. epsgeo**2 ) lbr(ibr)=1 if ( kpos .ge. 2 .and. & & encrn(1)**2 +encrn(2)**2 .le. epsgeo**2 ) lbr(ibr)=2 ! encode a nw branch identifier nwkbr(ibr) = 1000000 * knet + 1000 * ksd + i2kseg ! develop the list of unique nodes in ! the AI graph (nodes=abutment ends) do 5240 i = 1,2 call addin2 ( nnod, ipnod, ipqbr(i,ibr) ) 5240 continue 5250 continue ! do 5270 inod = 1,nnod knod(inod) = 0 lnod(inod) = kposab( iabs( ipnod(inod) ) ) 5270 continue ! set symmetry condition indicator isym = isympa call abtint (isym,kpos & & ,nbr,ipqbr,cbr,kbr,lbr,ndmbr,nwkbr & & ,nnod,ipnod,lnod,knod & & ,nodbr,nodpos,nfail) if ( pesed6 ) write (6,9008) iabint if ( nfail.ne.0 ) call abtmsg & & ('abtaio: failure detected in call abtint') if ( nfail.ne.0 ) iabsum = max (2,iabsum) ! sort the packed abutment-end list ! and look for the same pair of ! abutment ends appearing twice in ! the list. note that this is ! considered a problem only if the ! same pair of abutment ends bracket ! more than 1 NON-EXTRA control points call sortak (nbr,ipaben,ixtaib) iplast = 0 ixtlst = 0 ipforc = 0 nonext = 0 do 5280 ibr = 1,nbr ! initialize for counting the non-extra ! control points in a run if ( ipaben(ibr).ne.iplast ) nonext = 0 ! if c.p. is non-extra, increase nonext if ( ixtaib(ibr).eq.0 ) nonext = nonext + 1 if ( ipaben(ibr).eq.iplast ) then if ( nonext.gt.1 ) ipforc = 1 endif iplast = ipaben(ibr) ixtlst = ixtaib(ibr) 5280 continue if ( ipforc.gt.0 ) then write (6,9304) call remarx & & ('abtaio: probable overlap at abmt int, see print out') endif ! print the results of the AI analysis if ( iabsum.ge.2 .or. ipforc.gt.0 ) & & write (6,9007) iabint, poslbl(kpos) do 5400 ifsgpk = 1,nfsgpk ibr = ifsgpk kfsg12 = kfsgpk(ifsgpk) kfsg1 = kfsg12 / 10000 kfsg2 = mod( kfsg12, 10000 ) kabtx = kfdsgn( kfsg1 ) labtx = -kfdsgn( kfsg2 ) call icopy (4, kfdseg(4*kfsg1-3),1, kokseg,1) call icopy (4, kfdseg(4*kfsg2-3),1, lokseg,1) kedg = kedseg call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) ledg = ledseg call mnmod (ledg,4,lsd,lnet) call edgind (lsd,nm(lnet),nn(lnet) & & ,lzedg,lncedg,lncint,lnedg) lzedg = lzedg + nza(lnet) icn = lsd if ( ksd .eq. lsd ) icn = -icn ictype = icrntp( ledseg ) if ( ksd .eq. lsd ) ictype = iedgtp( ledseg ) xtra = ' ' if ( ksd .eq. lsd ) xtra = 'extra' imatch = 3 if ( kbr(ibr) .le. 2 ) imatch = 4 inodbr = nodbr(ibr) if ( inodbr .le. 0 ) go to 5350 inodbr = ipnod(inodbr) if ( inodbr .eq. ipqbr(1,ibr) ) imatch = 1 if ( inodbr .eq. ipqbr(2,ibr) ) imatch = 2 5350 continue char = chmatc(imatch) mcmpai(ifsgpk+nbrbas) = imatch ntdk = ntd(knet) if ( iabsum.lt.2 .and. ipforc.le.0 ) goto 5400 ! generate the description of the ! current branch in the abmt int kpos = kposab( iabs(kabtx) ) lpos = kposab( iabs(labtx) ) kpos = min ( 3, max ( 0, kpos)) lpos = min ( 3, max ( 0, lpos)) write (6,9208) xtra,knet,icn,ictype,ntdk & & ,knet,ksd,i2kseg,kabtx,chrpos(kpos), char & & ,lnet,lsd,i1lseg,labtx,chrpos(lpos) & & ,iduser(knet) 5400 continue 5500 continue ! done with AI analysis call jzero (ngspa,nnett+1) call jzero (nxspa,nnett+1) ! print summ of extra control points if ( nxsptt .le. 0 ) go to 6010 call shlsr2 (nxsptt,locxsp) if ( iabsum .gt. 0 ) call bmark ('extra-cp') if ( iabsum .gt. 0 ) write (6,9300) do 6000 l = 1,nxsptt call icopy (4, locxsp(4*(l)-3),1, locxex,1) knet = locxex(1) ksd = locxex(2) kpt = locxex(3) kfngrd = locxex(4) call mnmod (kfngrd, 2*nm(knet)-1, ifn, jfn) nxspa(knet+1) = nxspa(knet+1) + 1 if ( iabsum .le. 0 ) go to 6000 icrs = (ifn+1)/2 jcrs = (jfn+1)/2 write (6,9301) l, knet,ksd,kpt, icrs,jcrs, ifn,jfn 6000 continue if ( iabsum .gt. 0 ) call emark ('extra-cp') 6010 continue ! print summary of extra v-parm points if ( ngsptt .le. 0 ) goto 6060 call shlsr2 (ngsptt,locgsp) if ( iabsum .gt. 0 ) call bmark ('extra-vp') if ( iabsum .gt. 0 ) write (6,9302) do 6050 l = 1,ngsptt call icopy (4, locgsp(4*(l)-3),1, locxex,1) knet = locxex(1) ksd = locxex(2) kpt = locxex(3) kfngrd = locxex(4) call mnmod (kfngrd, 2*nm(knet)-1, ifn, jfn) ngspa(knet+1) = ngspa(knet+1) + 1 if ( iabsum .le. 0 ) go to 6050 icrs = (ifn+1)/2 jcrs = (jfn+1)/2 write (6,9301) l, knet,ksd,kpt, icrs,jcrs, ifn,jfn 6050 continue if ( iabsum .gt. 0 ) call emark ('extra-vp') 6060 continue ! wrap up processing of extra c.p.'s ! and extra v-parameters do 6100 k = 1,nnett nxspa(k+1) = nxspa(k+1) + nxspa(k) ngspa(k+1) = ngspa(k+1) + ngspa(k) 6100 continue if ( iabsum .gt.1 ) call outvci ('nxspa',nnett+1,nxspa) if ( iabsum.gt.1 ) call outvci ('ngspa',nnett+1,ngspa) ! 7000 continue return 9100 format (1h1,28x,'abutment intersection summary',//) 9007 format(/,'0ai #',i3,1x,a,2x,'point dblt',7x, & & 'previous segment boundary next segment '/ & & 9x,'nw corner type type', 7x, & & 'nw edge pt abmt pos condition nw edge pt abmt pos'/) 9008 format ('0 abutment intersection #',i4,' occurs at a point' & & ,' interior to a side edge of a type 6 nw',20x,'*** warning ***') 9208 format(1x,a5,1x,i4,i5,i6,i6,6x,3i4,i5,1x,a3,7x,a4,4x,3i4,i5,1x,a3 & & ,2x,a ) 9300 format (//,'0 ***** summary of extra control points ***** ' & & ,//, 8x, 'nw', 2x,'edge', 2x,'point', 2x,'row', 2x,'col' & & ,4x,'fine grid location' ) 9301 format (2x,i3,1h.,i4, i6, i7, i5, i5 & & ,3x,2i5 ) 9302 format (//,'0 ***** summary of extra v-parameter points ***** ' & & ,//, 8x, 'nw', 2x,'edge', 2x,'point', 2x,'row', 2x,'col' & & ,4x,'fine grid location' ) 9304 format (//,' *** probable error *** two cp''s in the following '& & ,' abutment intersection share common abutment ends, probably' & & ,' overlapping' ) END subroutine abtaio !! subroutine abtaip (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,iedgtp,icrntp, nfdseg,kfdseg,kfdsgn,kposab & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtaip subroutine abtaip (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,iedgtp,icrntp, nfdseg,kfdseg,kfdsgn,kposab & ! Added by Martin Hegedus, 4/21/09 & ,iabint,nbraia,ifsgai,mcmpai) implicit double precision (a-h,o-z) character xtra*5 dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension iedgtp(600), icrntp(600), kfdseg(3200), kfdsgn(800) dimension nbraia(250), ifsgai(2,800), mcmpai(800) dimension kposab(750) ! !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser character*3 chrpos(0:3) character*8 poslbl(0:3) character*4 chmatc(4), char data chmatc / '<---', '--->', 'aero', 'null'/ ! data chrpos / ' ', '1st', '2nd', '1&2' / data poslbl / ' ', '1-st pos', '2-nd pos', 'both pos' / ! ibr1 = nbraia(iabint) + 1 ibr2 = nbraia(iabint+1) kfsg = ifsgai(1,ibr1) call icopy (4, kfdseg(4*kfsg-3),1, kokseg,1) kedg = kedseg call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) kzcrn = kzedg + (i2kseg-1)*kncedg !! call abtpos (z(1,kzcrn), epsgeo, nsymm, kpos) ! Removed by Martin Hegedus, 4/21/09 call abtpos (z(1,kzcrn), epsgeo, nisym,njsym, kpos) ! Added by Martin Hegedus, 4/21/09 write (6,9007) iabint, poslbl(kpos) do 1000 ibr = ibr1,ibr2 kfsg1 = ifsgai(1,ibr) kfsg2 = ifsgai(2,ibr) imatch = mcmpai(ibr) kabtx = kfdsgn( kfsg1 ) labtx = -kfdsgn( kfsg2 ) kpos = kposab( iabs(kabtx) ) lpos = kposab( iabs(labtx) ) kpos = min ( 3, max ( 0, kpos)) lpos = min ( 3, max ( 0, lpos)) call icopy (4, kfdseg(4*kfsg1-3),1, kokseg,1) call icopy (4, kfdseg(4*kfsg2-3),1, lokseg,1) call mnmod (kedseg,4,ksd,knet) call mnmod (ledseg,4,lsd,lnet) char = chmatc( imatch ) ntdk = ntd(knet) ictype = icrntp( ledseg ) if ( ksd .eq. lsd ) ictype = iedgtp( ledseg ) xtra = ' ' if ( ksd .eq. lsd ) xtra = 'extra' icn = lsd if ( ksd .eq. lsd ) icn = -lsd write (6,9208) xtra,knet,icn,ictype,ntdk & & ,knet,ksd,i2kseg,kabtx,chrpos(kpos), char & & ,lnet,lsd,i1lseg,labtx,chrpos(lpos) & & ,iduser(knet)(1:10) 9007 format & &(/,'0ai #',i3,1x,a8,2x,'point dblt',7x & &,'previous segment boundary next segment ',/, & & 9x,'nw corner type type', 7x,'nw edge pt abmt pos conditi& &on nw edge pt abmt pos',/) 9208 format(1x,a5,1x,i4,i5,i6,i6,6x,3i4,i5,1x,a3,7x,a4,4x,3i4,i5,1x,a3 & & ,2x,a ) 1000 continue return END subroutine abtaip ! **deck abtchk subroutine abtchk(k,isd,l,jsd,nok) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts dimension z(3,200) data nzsk /200/ nforc=0 neq=0 nok=0 call mnmod(isd,2,misd,nisd) izmax=nn(k)*(2-misd)+nm(k)*(misd-1) if(izmax.gt.nzsk) go to 910 iz1=1 iz2=izmax call mnmod(jsd,2,mjsd,njsd) jzmax=nn(l)*(2-mjsd)+nm(l)*(mjsd-1) nza(1)=0 netmax=max (k,l) do 100 i=1,netmax 100 nza(i+1)=nza(i)+nm(i)*nn(i) nzak=nza(k) call mshind(isd,1,1,nm(k),nn(k),kp1) kp1=nzak+kp1 call cpetp(l,jsd,1,jzmax,zm(1,kp1),jz1) call mshind(isd,izmax,1,nm(k),nn(k),kp2) kp2=nzak+kp2 call cpetp(l,jsd,1,jzmax,zm(1,kp2),jz2) if(jz1.ne.jz2) go to 175 if((jz1.ne.1).and.(jz1.ne.jzmax)) go to 900 jz1=1 jz2=jzmax 175 continue nj=iabs(jz2-jz1)+1 if(nj.eq.2) go to 200 jsin=1 if(jz2.lt.jz1) jsin=-1 call cpetp(l,jsd,jz1+jsin,jz2,zm(1,kp1),jzm) if(jzm.eq.jz2) neq=1 200 continue call edgabt(k,isd,iz1,iz2,l,jsd,jz1,jz2,z,nok,nch) if(nok.ne.0) go to 350 if(nforc.eq.1) go to 900 if(nj.gt.nzsk) go to 910 jzmn=min (jz1,jz2) jzmx=max (jz1,jz2) iz=iz1 if(jz2.lt.jz1) iz1=iz2 if(jz2.lt.jz1) iz2=iz call edgabt(l,jsd,jzmn,jzmx,k,isd,iz1,iz2,z,nok,nch) 350 if((nforc.eq.0).and.(nch.eq.0)) nok=0 if(nforc.eq.0) go to 900 do 500 iz=1,izmax call mshind(isd,iz,1,nm(k),nn(k),kp) kp=nzak+kp zm(1,kp)=z(1,iz) zm(2,kp)=z(2,iz) zm(3,kp)=z(3,iz) 500 continue 900 continue if((nok.ne.0).or.(neq.eq.0)) go to 905 neq=0 jz=jz1 jz1=jz2 jz2=jz iz1=1 iz2=izmax go to 200 905 return 910 continue write(6,9100) 9100 format(//1x,44hscratch point array z in abtchk is too small,//) stop END subroutine abtchk ! **deck abtcor subroutine abtcor ! ! abort exit routine for getcor pkg., dumps current dynamic ! cm tables at abort time. ! !call dynmap ! /dynmap/ parameter (nlev=15) parameter (nlws=200) common /dynmap/ realth, intlth, nrl2in & & , levdyn, lwsdyn & & , levprt, lwsprt, sumprt & & , maxdyn, maxlev, maxlws & & , mxxdyn, mxxlev, mxxlws & & , llwstg, llmplv, llmlws & & , incrdf, npadio & & , maplev(3,nlev), maplws(3,nlws) double precision realth logical levprt, lwsprt, sumprt ! common /dynchr/ iniset, chrlev(nlev), chrlws(nlws) character*8 iniset, chrlev, chrlws !end dynmap write (6,6100) do 100 k = 1,levdyn write (6,6101) chrlev(k), (maplev(i,k),i=1,3) 100 continue ! write (6,6200) lev = 1 do 200 k = 1,lwsdyn do 180 i = 1,levdyn if ( k.gt.maplev(3,lev) ) lev = min(lev+1,levdyn) 180 continue write (6,6201) chrlws(k), (maplws(i,k),i=1,3), chrlev(lev) 200 continue call remarx ('abtcor: aborting due to dynamic memory error') CALL AbortPanair('abtcor') return ! 6100 format (' ==== summary of active map levels ==== ' & & ,//,' level-id base addr level alloc. cum. array count') 6101 format ( 3x,a, 3x,i9, 6x,i9, 3x,i11,' (d)' ) 6200 format (' ==== summary of active arrays ==== ' & & ,//,' array-id address >address array word count' & & ,' level-id') 6201 format ( 3x,a, 3x,i9, 6x,i9, 3x,i11,' (d)', 6x,a) ! END subroutine abtcor !! subroutine abtdab (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,nseglo,kabut,labut, nfsga & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtdab subroutine abtdab (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,nseglo,kabut,labut, nfsga & ! Added by Martin Hegedus, 4/21/09 & ,nfdseg,kfdseg,kfdkey,kfdpnt,kfdsgn, nabt,nedaba& & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension kabut(9600), labut(9600), nfsga(601) dimension kfdseg(3200), kfdkey(800), kfdpnt(800), kfdsgn(800) & & , nedaba(751) ! dimension z1p(3), z2p(3), zm1(3), zm2(3), ledgid(4) logical abut !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg ! define equivalence classes of ! fundamental segments ! ! initialize pointers and signs do 2050 ifsg = 1,nfdseg kfdpnt(ifsg) = ifsg kfdsgn(ifsg) = 1 2050 continue ! for each subject edge segment in the ! kabut list, find all the fundamental ! segments of which it is the union do 3000 iseglo = 1,nseglo call icopy (4, kabut(4*(iseglo)-3),1, kokseg,1) kedg = kedseg kfsg1 = nfsga(kedg) + 1 kfsg2 = nfsga(kedg+1) ifsg1 = nfdseg + 1 ifsg2 = 0 kmp1 = mxedmp + 1 kmp2 = 0 do 2100 ifsg = kfsg1,kfsg2 call icopy (4, kfdseg(4*ifsg-3),1, lokseg,1) if ( .not.( i1lseg.ge.i1kseg .and. i2lseg.le.i2kseg ) ) & & go to 2100 ! ifsg1 = min ( ifsg1, ifsg) ifsg2 = max ( ifsg2, ifsg) kmp1 = min ( kmp1, i1lseg) kmp2 = max ( kmp2, i2lseg) 2100 continue ! if ( kmp1.eq.i1kseg .and. kmp2.eq.i2kseg ) go to 2200 write (6,'(1x,a10,1x, 6i10)') & & 'x',iseglo,kedg,kfsg1,kfsg2,i1kseg,i2kseg call abtend ('edge segment not the union of f.e.s.*s') 2200 continue call icopy (4, labut(4*(iseglo)-3),1, lokseg,1) ledg = ledseg if ( ledg .le. 0 ) go to 3000 ! call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) call mnmod (ledg,4,lsd,lnet) call edgind (lsd,nm(lnet),nn(lnet) & & ,lzedg,lncedg,lncint,lnedg) lzedg = lzedg + nza(lnet) ! for each fundamental edge segment in ! the given edge segment on edge kedg ! find the corresponding fundamental ! edge segment on edge ledg and enter ! the associated equivalence relation ! into the kfdpnt data structure do 2500 ifsg = ifsg1,ifsg2 call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kz1 = kzedg + (i1kseg-1)*kncedg kz2 = kz1 + kncedg call abtels (z(1,kz1),z(1,kz2), z(1,lzedg),lncedg,lnedg & & ,epsgeo, abut,t1p,tint) kz1 = kzedg + (i2kseg-2)*kncedg kz2 = kz1 + kncedg call abtels (z(1,kz1),z(1,kz2), z(1,lzedg),lncedg,lnedg & & ,epsgeo, abut,tint,t2p) tmid = .5d0*(t1p+t2p) isgn = sign(1.d0,t2p-t1p) call epoint (z(1,lzedg),lncedg,lnedg, t1p, z1p) call epoint (z(1,lzedg),lncedg,lnedg, t2p, z2p) call nrmesh (z1p, z(1,lzedg),lncedg,lnedg, -isgn, tmid & & ,zm1,i1l,d1p) call nrmesh (z2p, z(1,lzedg),lncedg,lnedg, isgn, tmid & & ,zm2,i2l,d2p) ! *** if any trouble develops here, conside ! making these nrmesh calls with: ! ! (1) -isgn1, isgn1 = sgn(tint-t1p) ! tmid1, tmid1 = .5*(tint+t1p) ! (2) isgn2, isgn2 = sgn(t2p-tint) ! tmid2, tmid2 = .5*(tint+t2p) ! ledseg = ledg lokseg = 0 if ( d1p.gt.epsgeo .or. d2p.gt.epsgeo) lokseg = 1 if ( lokseg.ne.0 ) go to 2400 ! *** add error messages for bad object seg i1lseg = min (i1l,i2l) i2lseg = max (i1l,i2l) call icopy (4, lokseg,1, ledgid(1),1) ! look for the object edge segment ! to be fundamental jfsg1 = nfsga(ledg) + 1 jfsg2 = nfsga(ledg+1) if ( jfsg1.gt.jfsg2 ) go to 2310 do 2300 jfsgx = jfsg1,jfsg2 jfsg = jfsgx if ( kfdseg(4*jfsg-3).eq.ledgid(1).and. & & kfdseg(4*jfsg-2).eq.ledgid(2).and. & & kfdseg(4*jfsg-1).eq.ledgid(3).and. & & kfdseg(4*jfsg ).eq.ledgid(4) ) go to 2350 2300 continue 2310 continue lokseg = 1 go to 2400 ! found an equivalence, enter it. 2350 continue call abteqc (kfdpnt,kfdsgn,nfdseg, ifsg,jfsg,isgn) go to 2500 ! bad object edge. issue message and p 2400 continue call abtmsg & & ('abtdab: bad object edge segment found') write (6,6001) knet,ksd,i1kseg,i2kseg & & ,lnet,lsd,i1lseg,i2lseg 2500 continue 3000 continue ! equivalence classes of fundamental ! segments defined. reorganize ! kfdpnt to define abutments init = 1 neqcla = 0 ! 3100 continue do 3150 ifsg = init,nfdseg ifsgx = ifsg if ( kfdpnt(ifsg).gt.0 ) go to 3200 3150 continue ! all equivalence classes processed, ! exit to sorting go to 3300 ! new equivalence class found. 3200 continue init = ifsgx kx = ifsgx neqcla = neqcla + 1 ! 3250 continue kxsv = kx kx = kfdpnt(kx) kfdpnt(kxsv) = -neqcla if ( kx.ne.init ) go to 3250 go to 3100 ! kfdpnt(ifsg) = -(eq. class number) 3300 continue do 3400 ifsg = 1,nfdseg kfdpnt(ifsg) = -kfdpnt(ifsg) 3400 continue ! call jshell (nfdseg,kfdpnt,kfdkey) ! define the pointers nedaba into the ! kfdkey array defining the fundamental ! segments of each abutment. kfdsv = kfdpnt(1) - 1 nabt = 0 do 3500 ifsg = 1,nfdseg if ( kfdpnt(ifsg) .eq. kfdsv ) go to 3500 nabt = nabt + 1 if ( nabt .le. mxnabt ) go to 3450 call abtmsg ('*fatal* abutment limit exceeded') write (6,'(1x,a10,1x, 4i10)') & & 'data',nfdseg,nabt,neqcla,ifsg call abtend ('abtdab: job terminated due to error') 3450 continue nedaba(nabt) = ifsg - 1 kfdsv = kfdpnt(ifsg) 3500 continue nedaba(nabt+1) = nfdseg do 3520 iabt = 1,nabt locabt = nedaba(iabt) + 1 nfdsl = nedaba(iabt+1) - nedaba(iabt) call shlsrt (nfdsl,kfdkey(locabt)) if ( nfdsl .le. mxeiab ) go to 3520 call abtmsg ('*fatal abtdab: to0 many edges in abutmnt') write (6,'(1x,a10,1x, 3i10)') & & 'data' ,iabt,nfdsl,locabt call outvci ('kfdkey/i',nfdsl,kfdkey(locabt)) call outpkv ('kfdseg',nfdseg,kfdseg) 3520 continue return ! ! ! 6001 format (' subject edge segment: nw',i4,' side',i2, & & ' 1-st point',i4,' last point',i4 & & ,/, ' object edge segment: nw',i4,' side',i2, & & ' 1-st point',i4,' last point',i4 & & ) END subroutine abtdab !! subroutine abtdai (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,nfdseg,kfdseg,kfdkey, nabt,nedaba & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtdai subroutine abtdai (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,nfdseg,kfdseg,kfdkey, nabt,nedaba & ! Added by Martin Hegedus, 4/21/09 & ,nedmp,nedmpa & & ,nmpec,nabint,nmpaia,kemkey,kempec,kptemp & & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension kfdseg(3200), kfdkey(800), nedaba(751), nedmpa(601) dimension nmpaia(1001), kempec(1000), kemkey(1000), kptemp(1000) ! dimension iedmpx(2) !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg ! assign indices to the mesh point ! equivalence classes that are also ! abutment intersections. do 4050 iedmp = 1,nedmp kempec(iedmp) = 0 4050 continue nuqemp = 0 ! do 4200 iabt = 1,nabt iedg1 = nedaba(iabt) + 1 iedg2 = nedaba(iabt+1) do 4150 iedg = iedg1,iedg2 ie = iedg - iedg1 + 1 ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) call edgmpi (kedseg,i1kseg,nedmpa, iedmpx(1)) call edgmpi (kedseg,i2kseg,nedmpa, iedmpx(2)) do 4120 ix = 1,2 iedmp = iedmpx(ix) if ( kempec(iedmp) .ne. 0 ) go to 4120 nuqemp = nuqemp + 1 kmp = iedmp ! loop over entries in an equivalence c nloop = 0 4100 continue nloop = nloop + 1 if ( nloop.gt.mxempt ) call abtend & & ('abtdai: infinite loop trapped (1)') kempec(kmp) = nuqemp kmp = kptemp(kmp) if ( kmp .ne. iedmp ) go to 4100 ! 4120 continue 4150 continue 4200 continue ! nabint = nuqemp if ( nabint.gt.mxnai ) then write (6,6001) nabint, mxnai write (7,6001) nabint, mxnai call abtend ('abtdai: too many abutment intersections') endif 6001 format (' number of abutment intersections =',i5 & & ,' exceeds program limit of ',i5) ! assign indices to all remaining ! equivalence classes of edge mesh poin init = 1 ! 4300 continue do 4350 ix = init,nedmp iedmp = ix if ( kempec(ix).eq.0 ) go to 4370 4350 continue ! when you get here, all equivalence ! classes have been marked go to 4500 ! 4370 continue init = iedmp nuqemp = nuqemp + 1 kmp = iedmp nloop = 0 ! 4400 continue nloop = nloop + 1 if ( nloop .gt. mxempt ) call abtend & & ('abtdai: infinite loop trapped (2)') kempec(kmp) = nuqemp kmp = kptemp(kmp) if ( kmp .ne. iedmp ) go to 4400 ! go to 4300 ! sort the equivalence class index arra ! generating a key array. generate a p ! array into the key array for each ! equivalence class. 4500 continue call jshell (nedmp,kempec,kemkey) iempec = kempec(1) - 1 nmpec = 0 do 4520 iedmp = 1,nedmp if ( kempec(iedmp) .eq. iempec ) go to 4520 nmpec = nmpec + 1 nmpaia(nmpec) = iedmp - 1 iempec = kempec(iedmp) if ( iempec .eq. nmpec ) go to 4520 write (6,'(1x,a10,1x, 3i10)') & & 'eq.cl err',iedmp,iempec,nmpec 4520 continue nmpaia(nmpec+1) = nedmp call ukysrt (nedmp,kempec,kemkey) return END subroutine abtdai ! **deck abtdim subroutine abtdim (nnett,nm,nn,z,ntd, diamin,diamax) implicit double precision (a-h,o-z) dimension nm(150), nn(150), z(3,4000), ntd(150) ! compute the smallest and largest panel diameters for the ! whole configuration, excluding type 18 and 20 wake networks. nza = 0 diamin = 1.d38 diamax = 0.d0 do 1000 k = 1,nnett m = nm(k) - 1 n = nn(k) - 1 if ( ntd(k).eq.18 .or. ntd(k).eq.20 ) go to 510 do 500 j = 1,n do 500 i = 1,m l1 = nza + i + (j-1)*nm(k) l2 = l1 + nm(k) l3 = l2 + 1 l4 = l1 + 1 call distnc ( z(1,l1), z(1,l3), d13) call distnc ( z(1,l2), z(1,l4), d24) diam = max ( d13, d24) diamin = min ( diam, diamin) diamax = max ( diam, diamax) 500 continue 510 continue nza = nza + nm(k)*nn(k) 1000 continue return END subroutine abtdim ! **deck abtdnc subroutine abtdnc (nnett,nm,nn,z,q) implicit double precision (a-h,o-z) dimension nm(150), nn(150), z(3,4000), q(3,4000) ! scan the final geometry ( z ) and the initial geometry ( q ) ! looking for panels where the mean panel normal has changed ! by more than 5 degrees. logical header ! l = 1 header = .false. do 100 k = 1,nnett knet = k call dnchek (knet,nm(k),nn(k),z(1,l),q(1,l),header) l = l + nm(k)*nn(k) 100 continue if ( header ) call emark ('pnrmlmov') return END subroutine abtdnc !! subroutine abtdue (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,iedgtp,sdnst, nfdseg,kfdseg,kfdkey,kfdsgn & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtdue subroutine abtdue (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,iedgtp,sdnst, nfdseg,kfdseg,kfdkey,kfdsgn & ! Added by Martin Hegedus, 4/21/09 & ,nabt,nedaba,kposab,mtchab & & ,nedmp,nedmpa,kempec,kptemp,tauemp & & ,nefgst,nefgsa,kptefg & & ,mxvlst,nvlst,kkvlst,wtvlst & & ,neztot,nezaba,keqvel,zpt & & ,nwtrf,nwltrf & & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension iedgtp(600), sdnst(600) dimension kfdseg(3200), kfdkey(800), kfdsgn(800) dimension kposab(mxnabt), nedaba(mxnabt+1), mtchab(4,mxnabt) dimension nedmpa(601), kempec(1000), kptemp(1000), tauemp(1000) dimension nefgsa(600), kptefg(nefgst) dimension kkvlst(2,mxvlst), wtvlst(2,mxvlst) dimension nezaba(mxnabt+1), keqvel(2,mxfdsg) dimension nwltrf(nnett) ! --- dimension zpt(3,mxnpec) dimension zpt(3,*) ! dimension dz(3) dimension zavg(3), iwfds(mxeiab) dimension zcom(3,mxedmp), dzcom(mxedmp), dzsum(mxedmp) dimension iedcom(mxedmp), zmid(3), tg(3), zx(3), zy(3) dimension tgnet(3,mxeiab), isgnet(mxeiab), phnet(mxeiab) & & , kphnet(mxeiab), knwnet(mxeiab) & & , kednet(mxeiab) !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp !call nwlst common /cnwlst/ nwname(mxnett) character*10 nwname common /anwlst/ nnwlst !end nwlst !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg !call symcnd ! /symcnd/ common /symcnd/ isympa !end symcnd !call nwkrgn ! /nwkrgn/ region information for the upper/lower nw surfaces ! zctrgn(3,k) zctr for each network ! ntrgn total number of regions ! kinrgn(i) starting pointer in kptrgn for region i ! nsfrgn(i) number of surfaces bounding region i ! isfrgn(nlop) gives surface on which bc nlop is applied (1=u ! indrgn(1:2,k) region index for nw surfaces (1=u,2=l; k=nw-in ! kptrgn(2*nnett) equivalence class pointer structure for nw sur ! kbcrgn(k) error counter for 4/9 b.c.'s on nw k common /nwkrgn/ zctrgn(3,2,150) & & , ntrgn, kinrgn(100), nsfrgn(100), isfrgn(0:25) & & , indrgn(2,150), kptrgn(2*150) & & , kbcrgn(150) !end nwkrgn dimension zctr(3), kkrgn(300) character*5 csurf character*10 cmatrl !call kutflg ! /kutflg/ common /kutflg/ kutta(150), kttype(150) !end kutflg !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !call cp2aul ! /cp2aul/ = index for abutments having a cp(2nd order) ! matching condition. common /cp2aul/ ncp2ab, idcp2(3,50) & & , ablcp2(50), keycp2(50) integer ablcp2 !end cp2aul !call lndblx ! /lndblx/ common /lndblx/ genwak(3,mxnett), slndbl(mxnett) & & , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett) !end lndblx dimension tgs(3,3), etan(3,3), isgnie(3), tgswk(3), etanwk(3) & & , enwk(3), knwie(3), awk(3,3), tgsloc(3) dimension en1(3), en2(3) dimension indsym(4) logical frwkte logical wakenw logical badabt character*35 badmsg character*10 nwknet, nwknpv character*10 cdbtyp(0:4) character*1 charul(2), chulpv, chul character*1 chboth data cdbtyp /'no-doublet','analysis ','nt=18 wake','nt=20 wake' & & ,'dsgn-wake '/ data indsym / 3, 2, 0, 1 / ! plane of symmetry normals data en1 / 0.d0, 1.d0, 0.d0/ data en2 / 0.d0, 0.d0, 1.d0/ data charul / '+', '-' / ! nwtrf = 0 ! initialize the pointer structure used ! to find the independent regions by ! examining equivalence classes of ! surfaces. nnett2 = nnett*2 do 100 k = 1,nnett do 90 ii = 1,2 kk = ii + 2*(k-1) indrgn(ii,k) = 1 kptrgn(kk) = kk 90 continue 100 continue ! for each abutment, define the meshpoi ! of the universal edge and adjust all ! meshpoints of the abutment to lie on ! that universal edge ncp2ab = 0 neztot = 0 do 5000 iabt = 1,nabt nzcom = 0 iedgbs = nedaba(iabt) ne = nedaba(iabt+1) - nedaba(iabt) nezaba(iabt) = neztot ! determine if the abutment involves ! only a single trailing edge of a wake ! if it does, and if (iwkfil.ne.0), set ! the filament flag for the network ! and do some error checking. frwkte = .false. if ( ne.gt.1 ) goto 400 ! iedg = iedgbs + 1 ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kedg = kedseg knet = (kedg-1)/4 + 1 ksd = kedg - (knet-1)*4 if ( ksd.ne.3 ) goto 400 ntdk = ntd(knet) if ( ntdk.ne.18.and.ntdk.ne.20.and.ntdk.ne.6 ) goto 400 frwkte = .true. nwtrf = nwtrf + 1 nwltrf(nwtrf) = knet if ( iwkfil.eq.0 ) goto 400 idsvfw(knet) = iabt if ( i1kseg.eq.1 .and. i2kseg.eq.nn(knet) ) goto 400 call abtmsg ('abtdue: partial abutment on wake t.e. ') write (6,6002) knet,iabt,i1kseg,i2kseg,nm(knet),nn(knet) 400 continue do 4800 ie = 1,ne iedg = iedgbs+ie ifsg = kfdkey(iedg) isgn = kfdsgn(ifsg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kedg = kedseg do 4700 impx = i1kseg,i2kseg imp = impx if ( isgn.lt.0 ) imp = i1kseg + i2kseg - impx call edgmpi (kedseg,imp,nedmpa, iedmp) ! count and collect the points in this kmp = iedmp npt = 0 ! 4550 continue npt = npt + 1 call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz) call xfera (z(1,kz),zpt(1,npt),3) if ( npt.gt.mxnpec ) & & call abtend ('zpt buffer exceeded') kmp = kptemp(kmp) if ( kmp.ne.iedmp ) go to 4550 ! counting and collecting done, ! check for error conditions if ( ie.gt.1 ) go to 4570 if ( impx.ne.i1kseg .and. impx.ne.i2kseg ) & & go to 4560 ! ! first edge, end points ! if ( npt.lt.ne ) call abtend & & ('end point class not full') if (impx.eq.i1kseg) kec1=iabs(kempec(iedmp)) if (impx.eq.i2kseg) kec2=iabs(kempec(iedmp)) go to 4600 ! ! first edge, interior ! 4560 continue if ( npt.gt.ne ) call abtend & & ('interior equivalence class too big') if (npt.lt.ne) go to 4700 go to 4600 ! ! subsequent edges ! 4570 continue if ( impx.ne.i1kseg .and. impx.ne.i2kseg ) & & go to 4580 ! ! subsequent edge, end points ! if ( impx.eq.i1kseg .and. & & iabs(kempec(iedmp)).ne.iabs(kec1)) & & call abtend & & ('end mesh pt in wrong eq. class /1') if ( impx.eq.i2kseg .and. & & iabs(kempec(iedmp)).ne.iabs(kec2)) & & call abtend & & ('end mesh pt in wrong eq. class /2') if ( kempec(iedmp).gt.0 ) call abtend & & ('end mesh pt not already processed') go to 4700 ! ! subsequent edge, interior point ! 4580 continue if ( npt.gt.ne ) call abtend & & ('excessive eq. class detected') if ( npt.eq.ne .and. kempec(iedmp).gt.0 ) & & call abtend & & ('unprocessed interior eq. class') if ( npt.lt.ne .and. kempec(iedmp).lt.0 ) & & call abtend & & ('falsely processed interior point') go to 4700 ! ! first edge, merge points and save ! 4600 continue call zmerge (npt,zpt,zavg) nzcom = nzcom + 1 call xfera (zavg,zcom(1,nzcom),3) iedcom(nzcom) = iedmp kmp = iedmp ! nloop = 0 4610 continue nloop = nloop + 1 if ( nloop .gt. mxempt ) call abtend & & ('abtdue: infinite loop trapped (1)') call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz) call xfera (zavg,z(1,kz),3) kempec(kmp) = -iabs(kempec(kmp)) kmp = kptemp(kmp) if ( kmp.ne.iedmp ) go to 4610 ! 4700 continue 4800 continue ! compute individual and cumulative ! segment lengths for the common edge dzsum(1)= 0.d0 nzcseg = nzcom - 1 do 4810 izcom = 1,nzcseg call distnc (zcom(1,izcom),zcom(1,izcom+1),dzcom(izcom)) dzsum(izcom+1) = dzsum(izcom) + dzcom(izcom) 4810 continue ! # call outlin ("cm edge",1,iabt) ! # call outmat ("zcom",3,3,nzcom,zcom) ! # call outvec ("dzcom",nzcom,dzcom) ! # call outvec ("dzsum",nzcom,dzsum) ! universal edge defined, adjust the ! remaining points of the abutment ! up to it. ! while doing this, perform the matchin ! assignments for the current abutment. izmid = nzcom/2 call vadd (zcom(1,izmid+1), -1.d0, zcom(1,izmid), dz, 3) call cpip (dz,dz,dzsq) isonic = +1 if ( dzsq .le. 0.d0 ) isonic = -1 call jzero ( iwfds, ne) jevmax = 0 jfsgmx = 0 kwfsg = 0 idcpm = 0 do 4900 ie = 1,ne iedg = ie + iedgbs ifsg = kfdkey(iedg) isgn = kfdsgn(ifsg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kedg = kedseg izcom = 0 ! update the best guess at a matching ! fundamental segment (jfsgmx) while ! determining if the current segment ! is on edge 1 of a type 18 nw. call mnmod (kedg,4,ksd,knet) npps = i2kseg - i1kseg + 1 jupdwn = .5d0 * ( sdnst(kedg)+1.d0 ) * 99999.d0 jupdwn = max ( 0, min ( 99999, jupdwn) ) if ( isonic .gt. 0 ) & & jevalu = jupdwn + 100000*( npps+1000*iedgtp(kedg) ) if ( isonic .le. 0 ) & & jevalu = npps + 1000*( jupdwn+100000*iedgtp(kedg) ) if ( jevalu.le.jevmax .and. ie.gt.1 ) go to 4815 jevmax = jevalu jfsgmx = ifsg 4815 continue iwfds(ie) = jevalu if ( kutta(knet).ne.0 .and. ksd.eq.1 ) kwfsg = ifsg if ( kutta(knet).eq.1 .and. ksd.eq.1 ) idcpm = 1 if ( kutta(knet).eq.2 .and. ksd.eq.1 ) idcpm = 2 if ( kutta(knet).eq.3 .and. ksd.eq.1 ) idcpm = 3 ! do 4880 impx = i1kseg,i2kseg imp = impx if ( isgn.lt.0 ) imp = i1kseg + i2kseg - impx call edgmpi (kedseg,imp,nedmpa, iedmp) ! kmp = iedmp npt = 0 nloop = 0 4820 continue nloop = nloop + 1 if ( nloop .gt. mxempt ) call abtend & & ('abtdue: infinite loop trapped (2)') npt = npt + 1 call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz) call xfera (z(1,kz),zpt(1,npt),3) kmp = kptemp (kmp) if ( kmp .ne. iedmp ) go to 4820 ! ! count the common mesh points of ! all edges in the abutment if ( npt.ge.ne ) izcom = izcom+1 ! define the tauedg values for the ! common mesh points when processing ! the first edge. if ( .not. ( npt.ge.ne .and. ie.eq.1 ) ) go to 4835 tauedg = dzsum(izcom)/dzsum(nzcom) kmp = iedmp nloop = 0 4830 continue nloop = nloop + 1 if ( nloop .gt. mxempt ) call abtend & & ('abtdue: infinite loop trapped (3)') tauemp(kmp) = tauedg kmp = kptemp(kmp) if ( kmp .ne. iedmp ) go to 4830 go to 4880 ! ! define tau values and adjust coordi ! of points that are not common mesh po 4835 continue if ( kempec(iedmp).lt.0 ) go to 4880 call zmerge (npt,zpt,zavg) if ( izcom.lt.1 .or. izcom.ge.nzcom ) call abtend & & ('izcom out of bounds') call zmproj (zcom(1,izcom),zcom(1,izcom+1),zavg & & ,tauz) tauedg = ( dzsum(izcom) + tauz*dzcom(izcom) ) / & & dzsum(nzcom) if ( tauz.lt.0.d0 .or. tauz.gt.1.d0 ) call abtend & & ('tauz out of range') ! ! change points kmp = iedmp nloop = 0 4840 continue nloop = nloop + 1 if ( nloop .gt. mxempt ) call abtend & & ('abtdue: infinite loop trapped (4)') call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz) call xfera (zavg,z(1,kz),3) tauemp(kmp) = tauedg kempec(kmp) = -iabs(kempec(kmp)) kmp = kptemp(kmp) if ( kmp.ne.iedmp ) go to 4840 4880 continue 4900 continue ! check that the material properties ! have been properly specified ! ! evaluate the position and the tangent ! to the common edge at the logical mid call dcopy (3, zcom(1,izmid), 1, zmid,1) call daxpy (3, 1.d0, zcom(1,izmid+1),1, zmid,1) call dscal (3, .5d0, zmid,1) call dcopy (3, zcom(1,izmid+1),1, tg,1) call daxpy (3,-1.d0, zcom(1,izmid), 1, tg,1) call uvect (tg) ! iedmp = iedcom(izmid) kbad = 0 ! evaluate tangents pointing into each ! at the point zmid do 2100 ie = 1,ne ! standard loop setup (save isgn, knet) iedg = iedgbs + ie ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*(ifsg)-3),1, kokseg,1) kedg = kedseg call mnmod (kedg,4,ksd,knet) isgn = isign( 1, kfdsgn(ifsg) ) isgnet(ie) = isgn knwnet(ie) = knet kednet(ie) = kedseg call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = nza(knet) + kzedg kzfsg = kzedg + (i1kseg-1)*kncedg knfsg = i2kseg - i1kseg + 1 ! find point on edge close to zmid call nredge (zmid, z(1,kzfsg),kncedg,knfsg & & ,1,0.d0, zx,tx,dx) tx = tx + i1kseg - 1 ! perform various error checks ibad = 0 itx = tx + .5d0 if ( itx.lt.i1kseg .or. itx.gt.i2kseg ) ibad = ibad + 1 if ( dx.gt.epsgeo ) ibad = ibad + 2 call nredge (zcom(1,izmid), z(1,kzfsg),kncedg,knfsg & & ,1,0.d0, zy,ty,dy) ty = ty + i1kseg - 1 ity = ty + .5d0 kmpy = nedmpa(kedg) + ity if ( kmpy.gt.nedmpa(4*knet+1) ) kmpy = nedmpa(4*knet-3)+1 nloop = 0 kmp = iedmp 2050 continue nloop = nloop + 1 if ( nloop.gt.mxempt ) call abtend & & ('abtdue: infinite loop trap (6)') if ( kmp.eq.kmpy ) goto 2080 kmp = kptemp(kmp) if ( kmp.ne.iedmp ) goto 2050 ! ibad = ibad + 4 2080 continue kbad = kbad + ibad if ( ibad.ne.0 ) then call abtmsg ('abtdue: midpt search error') write (6,'(1x,a10,1x,3i6,6e16.8)') & & 'ibad', 9,ibad,iabt,ie,tx,dx,itx & & ,ty,dy,ity write (6,'(1x,a10,1x, 9e12.4)') & & 'zmid',zmid(1),zmid(2),zmid(3) & & ,zx(1),zx(2),zx(3),zy(1),zy(2),zy(3) goto 2100 endif ! get a tangent vector pointing into ! nw knet at the point zmid it1 = tx it2 = it1 + 1 tau = tx - it1 tauc = 1.d0-tau le1 = (it1-1)*kncedg+kzedg le2 = (it2-1)*kncedg+kzedg li1 = le1 + kncint li2 = le2 + kncint do 2090 i = 1,3 tgnet(i,ie) = tauc*(z(i,li1)-z(i,le1)) & & +tau *(z(i,li2)-z(i,le2)) 2090 continue 2100 continue if ( kbad.ne.0 ) goto 2310 kposx = kposab(iabt) nex = ne if ( mod(kposx,2).ne.1 ) goto 2130 ! on 1st pos, add in a fake vector, set ! knet = -1. a negative value of knet ! will signal special calculation and ! handling of material properties. nex = nex + 1 call cross (en1,tg,tgnet(1,nex)) knwnet(nex) = -1 isgnet(nex) = 1 nex = nex + 1 call cross (tg,en1,tgnet(1,nex)) knwnet(nex) = -1 isgnet(nex) = 1 2130 continue if ( kposx.lt.2 ) goto 2140 ! on 2nd pos, add in a fake vector, set ! knet = -2 nex = nex + 1 call cross (en2,tg,tgnet(1,nex)) knwnet(nex) = -2 isgnet(nex) = 1 nex = nex + 1 call cross (tg,en2,tgnet(1,nex)) !! NOTES by Martin Hegedus, 4/21/09 !! I believe that changing knwnet(nex) to -2 only effects the output below (1st p-o-s and 2nd p-o-s identifier) !! 1) knwnet is a local array !! 2) nothing significant is done if knwnet is negative !! 3) keqvel is set to this value !! A) keqvel comes from the parent routine abtidn !! B) keqvel is stored in the parent's abtcom common block, however this common block is not used anywhere !! C) keqvel is store with ixtrns(66) but isn't read in anywhere by xtrns(66) !! 4) the results from simple test which were run with and without changes to this value are identical !! knwnet(nex) = -1 ! Removed by Martin Hegedus, 4/21/09 knwnet(nex) = -2 ! Added by Martin Hegedus, 4/21/09 isgnet(nex) = 1 2140 continue ! calculate phase angles relative to ! the tangent on the first network do 2200 ie = 1,nex call vip (tg,1, tgnet(1,ie),1, 3, fac) fac = -fac call daxpy (3, fac, tg,1, tgnet(1,ie),1) call uvect (tgnet(1,ie)) call vip (tgnet(1,ie),1, tgnet(1,1),1, 3, cphi) sphi = det (tgnet(1,1), tg, tgnet(1,ie)) phnet(ie) = 0.d0 if ( cphi.eq.0.d0 .and. sphi.eq.0.d0 ) & & write (6,'(1x,a10,1x, 3i10,3f12.6)') & & 'atan2-err',ie,knwnet(ie),isgnet(ie) & & ,tgnet(1,ie),tgnet(2,ie),tgnet(3,ie) if ( cphi.eq.0.d0 .and. sphi.eq.0.d0 ) & & goto 2200 phnet(ie) = atan2( sphi, cphi) 2200 continue ! validation printout goto 2210 write (6,'(1x,a10,1x, i12)') & & 'mat prp co',iabt call outvec ('phnet',nex,phnet) call outvec ('tg-abt',3,tg) call outvec ('zmid',3,zmid) call outvci ('isgnet',nex,isgnet) call outvci ('knwnet',nex,knwnet) call outmat ('tgnet',3,3,nex,tgnet) 2210 continue ! sort the angles and make the check call dshell (nex,phnet,kphnet) ie = kphnet(nex) knet = knwnet(ie) kprv = knet isgn = isgnet(ie) iulm = (3+isgn)/2 matprv = knet if ( knet.gt.0 ) matprv = matnet(iulm,knet) kprv = knet kedgpv = 0 if ( knet.gt.0 ) kedgpv = kednet(ie) iulprv = iulm iepv = ie ! do 2300 iex = 1,nex ie = kphnet(iex) knet = knwnet(ie) kedg = 0 if ( knet.gt.0 ) kedg = kednet(ie) isgn = isgnet(ie) iulp = (3-isgn)/2 iulm = (3+isgn)/2 matnew = knet if ( knet.gt.0 ) matnew = matnet(iulp,knet) ! accumulate the lists of opposing ! surfaces associated with each ! abutment if ( kprv.gt.0 .or. knet.gt.0 ) then neztot = neztot + 1 kkfsgp = kprv if ( kprv.gt.0 ) then if ( iepv.gt.ne ) call abtmsg ('abtdue 2300-1') kfsgpv = kfdkey(iepv+iedgbs) kkfsgp = iulprv + (kfsgpv-1)*2 endif ! kkfsg = knet if ( knet.gt.0 ) then if ( ie.gt.ne ) call abtmsg ('abtdue 2300-2') kfsg = kfdkey(ie+iedgbs) kkfsg = iulp + (kfsg -1)*2 endif keqvel(1,neztot) = kkfsgp keqvel(2,neztot) = kkfsg endif if ( frwkte ) goto 2250 ! if both facing surfaces are real surf ! and the abutment is not along a free ! trailing edge of a wake (see frwkte ! test above), enter the equivalence re ! of surfaces into kptrgn if ( kprv.gt.0 .and. knet.gt.0 ) then isrfpv = iulprv + 2*(kprv-1) isrf = iulp + 2*(knet-1) call abteqc (kptrgn,indrgn,nnett2, isrfpv,isrf,1) call abtefg (iabt,iulprv,kedgpv, iulp,kedg & & ,nefgst,nefgsa,kptefg, mxvlst,nvlst,kkvlst,wtvlst& & ,nedaba,kfdkey,kfdseg,kfdsgn & & ,nm,nn,nza,z,epsgeo & & ) endif ! if either surface is on a plane of sy ! (signalled by matnew or matprv .lt.0) ! material properties are consistent by ! definition. if ( matprv.lt.0 .or. matnew.lt.0 ) goto 2250 if ( matprv.eq.matnet(iulp,knet) ) goto 2250 ! error detected, complain write (6,6003) iabt,kprv,nwname(kprv) & & ,knet,nwname(knet) call abtmsg & & ('abtdue: inconsistent material properties') 2250 continue matprv = knet iepv = ie if ( knet.gt.0 ) matprv = matnet(iulm,knet) kprv = knet kedgpv = kedg iulprv = iulm 2300 continue ! transfer point for error detection 2310 continue 6003 format (' ** fatal error ** on abutment',i4,'. inconsistent' & & ,' material properties were given for nw-s' & & ,1x,i3,'=',a10,', ',i3,'=',a10) ! fundamental segment jfsgmx is the b ! matching segment, while kwfsg is th ! leading edge of a type 6 or 18 nw (if n ! record this information and find a ! suitable edge for vorticity matching ! necessary. kpos = iandfn( kposab(iabt), indsym(isympa)) mtchab(1,iabt) = 0 call icopy (4, kfdseg(4*(jfsgmx)-3),1, kokseg,1) if ( kpos.eq.0 .and. iedgtp(kedseg).ge.4 ) & & mtchab(1,iabt) = jfsgmx mtchab(2,iabt) = kwfsg mtchab(3,iabt) = 0 mtchab(4,iabt) = idcpm if ( kpos.ne.0 .or. kwfsg.eq.0 ) go to 4960 do 4950 ie = 1,ne iedg = ie + iedgbs ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) if ( ifsg .eq. jfsgmx ) go to 4950 if ( iedgtp(kedseg) .lt. 4 ) go to 4950 mtchab(3,iabt) = ifsg go to 4960 4950 continue call abtmsg ('abtdue: vorticity matching not assigned') write (6,6001) iabt 6001 format ('0 vorticity matching unassigned for abutment',i5) 4960 continue ! *** if ( idcpm.lt.1 .or. idcpm.gt.3 ) go to 5000 if ( idcpm.ne.2 .and. idcpm.ne.3 ) go to 5000 ncp2ab = ncp2ab + 1 idcp2(1,ncp2ab) = iabt if ( ne.gt.3 ) call a502ms('abtdue' & & ,'delta(cp2) matching on more than 3 edges') if ( ne.gt.3 ) go to 5000 iewake = 0 do 4980 ie = 1,ne iedg = ie + iedgbs ifsg = kfdkey(iedg) isgn = kfdsgn(ifsg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) call mnmod (kedseg,4,ksd,knet) knwie(ie) = kedseg isgnie(ie)= isign(1,isgn) i1 = i1kseg if ( isgn.lt.0 ) i1 = i2kseg i2 = i1kseg + 1 if ( isgn.lt.0 ) i2 = i2kseg - 1 call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) kz1 = kzedg + (i1-1)*kncedg kz2 = kzedg + (i2-1)*kncedg kzint1 = kz1 + kncint kzint2 = kz2 + kncint call vadd (z(1,kz2),-1.d0,z(1,kz1),etan(1,ie),3) call vadd (z(1,kzint1), -1.d0, z(1,kz1), tgs(1,ie), 3) call vadd (z(1,kzint2), -1.d0, z(1,kz2), tgsloc , 3) call vadd (tgs(1,ie), 1.d0, tgsloc, tgs(1,ie), 3) call uvect (etan(1,ie)) call uvect ( tgs(1,ie)) if ( ifsg.eq.kwfsg ) iewake = ie 4980 continue if ( iewake.eq.0 ) call a502ms ('abtdue' & & ,'wake nw expected but not found ') if ( iewake.eq.0 ) go to 5000 call dcopy (3, tgs(1,iewake),1, tgswk,1) call dcopy (3, etan(1,iewake),1, etanwk,1) call cross (etanwk,tgswk,enwk) call uvect (enwk) if ( isgnie(iewake).lt.0 ) call vmul (enwk,-1.d0,enwk,3) call vip (etanwk,1, tgswk,1, 3, fac) call vadd (tgswk, -fac, etanwk, tgswk, 3) call uvect (tgswk) call dcopy (3, tgswk,1, awk(1,1),3) call dcopy (3, enwk,1, awk(2,1),3) call dcopy (3, etanwk,1, awk(3,1),3) ! ieup = 0 phiup = 20.d0 do 4990 ie = 1,ne if ( ie.eq.iewake ) go to 4990 call mxm (awk,3,tgs(1,ie),3,tgsloc,1) ph = atan2( tgsloc(2), tgsloc(1)) ddd = abs(tgsloc(1)) + abs(tgsloc(2)) if ( ddd.le.0.d0 ) write (6,'(1x,a10,1x, 3i12,6f12.6)') & & '++++++++',ie,ne,ph & & ,tgs(1,ie),tgs(2,ie),tgs(3,ie) & & ,tgsloc(1),tgsloc(2),tgsloc(3) if ( ph.lt.0.d0 ) ph = ph + 2.d0*pi if ( ph.gt.phiup ) go to 4990 ieup = ie phiup = ph 4990 continue ! ielo = ieup do 4995 ie = 1,ne if ( ie.ne.iewake .and. ie.ne.ieup ) ielo = ie 4995 continue kup = knwie(ieup) klo = knwie(ielo) kwake = knwie(iewake) idcp2(2,ncp2ab) = -isgnie(iewake)*isgnie(ieup)*kup idcp2(3,ncp2ab) = +isgnie(iewake)*isgnie(ielo)*klo ! check ipot consistency call abtipc (iabt,ncp2ab,ne) go to 5000 9001 format (' abut',i3,' mtchab',3i4,' prior',/, (10x,10i12) ) 5000 continue if ( ncp2ab.le.0 ) go to 6000 do 5100 ind = 1,ncp2ab iabt = idcp2(1,ind) kup = idcp2(2,ind) klo = idcp2(3,ind) kup = (kup+3)/4 klo = (klo+3)/4 kwfsg = mtchab(2,iabt) call icopy (4, kfdseg(4*(kwfsg)-3),1, kokseg,1) call mnmod (kedseg,4,ksd,kwake) write (6,5200) ind,iabt,kwake,kup,klo 5100 continue 5200 format (' cp2 abutment # ',i4,'. abutment =',i4 & &,' wake nw index =',i3,' upper surface nw index =',i3 & & ,' lower surface nw index =',i3 ) 6000 continue 6002 format (' *** error *** partial edge abutment on trailing' & &, ' free edge of type 18 or 20 wake nw ' & & ,/,' nw:',i3,' abutment:',i4,' initial pt:',i4,' final pt:' & & ,i4,' network size:',i3,' x ',i3) nezaba(nabt+1) = neztot ! print out pairing of surfaces ! associated with each abutment write (6,5253) do 5250 iabt = 1,nabt nez = nezaba(iabt+1) - nezaba(iabt) iezbas = nezaba(iabt) do 5240 iez = 1,nez kkfsgp = keqvel(1,iez+iezbas) kkfsg = keqvel(2,iez+iezbas) ! knetpv = kkfsgp ksdpv = 0 chulpv = ' ' if ( kkfsgp.gt.0 ) then call mnmod (kkfsgp,2,iulprv,kfsgpv) kedgpv = kfdseg(4*kfsgpv-2) call mnmod (kedgpv,4,ksdpv,knetpv) chulpv = charul(iulprv) endif ! knet = kkfsg ksd = 0 chul = ' ' if ( kkfsg.gt.0 ) then call mnmod (kkfsg,2,iulp,kfsg) kedg = kfdseg(4*kfsg -2) call mnmod (kedg,4,ksd,knet) chul = charul(iulp) endif ! ! set doublet types for facing nw's ntdkpv = 0 ntdk = 0 if ( knetpv.gt.0 ) ntdkpv = ntd(knetpv) if ( knet .gt.0 ) ntdk = ntd(knet) ! ktdk = index into cdbtyp for knet ktdk = 0 if ( ntdk.eq.12 ) ktdk = 1 if ( ntdk.eq.18 ) ktdk = 2 if ( ntdk.eq.20 ) ktdk = 3 if ( ntdk.eq. 6 ) ktdk = 4 if ( knet.gt.0 ) ktk = kttype(knet) wakenw = (ktdk.ge.2) ! kt = kt type for nw knet ktk = 0 ! determine if abutment looks bad badabt = .false. if ( knet.eq.knetpv .and. chul.ne.chulpv .and. & & ktk.ne.2 .and. ktk.ne.12 ) then if ( .not.wakenw ) badabt = .true. endif badmsg = ' ' if ( badabt ) badmsg = & & 'probable error: unabutted free edge' ! 12345678901234567890123456789012345 ! get netwk names for facing surfaces nwknet = ' ' if ( knet .eq.(-1) ) nwknet = '1st p-o-s' if ( knet .eq.(-2) ) nwknet = '2nd p-o-s' if ( knet .gt.0 ) nwknet = nwname(knet) nwknpv = ' ' if ( knetpv.eq.(-1) ) nwknpv = '1st p-o-s' if ( knetpv.eq.(-2) ) nwknpv = '2nd p-o-s' if ( knetpv.gt.0 ) nwknpv = nwname(knetpv) if ( iez.eq.1 ) write (6,5251) & & iabt, nwknpv, ntdkpv, knetpv, ksdpv,chulpv & & , nwknet, ntdk, knet, ksd, chul, badmsg if ( iez.ne.1 ) write (6,5252) & & nwknpv, ntdkpv, knetpv, ksdpv,chulpv & & , nwknet, ntdk, knet, ksd, chul, badmsg 5240 continue 5250 continue 5251 format (3x,i6,3x & & ,a10,i3,3x,i3,'.',i1,a1,6x & & ,a10,i3,3x,i3,'.',i1,a1,6x,a) 5252 format (3x,6x,3x & & ,a10,i3,3x,i3,'.',i1,a1,6x & & ,a10,i3,3x,i3,'.',i1,a1,6x,a) 5253 format (//,15x,'SUMMARY OF FACING SURFACES (+:upper, -:lower)' & & ,/, 1x,'abutment',3x & & ,'nw-ident ntd knet.edge',4x & & ,'nw-ident ntd knet.edge',4x,a) ! put out a header for the region defin write (6,6004) ! initialize zctrgn(*,1:2,k) to the log ! center of network k do 5300 k = 1,nnett ictr = (nm(k)+1)/2 jctr = (nn(k)+1)/2 lz = ictr + (jctr-1)*nm(k) + nza(k) call dcopy (3, z(1,lz),1, zctrgn(1,1,k),1) call dcopy (3, z(1,lz),1, zctrgn(1,2,k),1) 5300 continue ! identify the disjoint regions init = 1 ntrgn = 0 5310 continue do 5320 kk = init,nnett2 initnw = kk if ( kptrgn(kk).gt.0 ) goto 5340 5320 continue ! all cycles processed, reset pointers, do 5330 kk = 1,nnett2 kptrgn(kk) = iabs( kptrgn(kk) ) 5330 continue goto 5400 ! 5340 continue init = initnw ntrgn = ntrgn + 1 if ( ntrgn.gt.100 ) CALL AbortPanair('abtdue') kinrgn(ntrgn) = init nloop = 0 kk = init call dcopy (3, 0.d0,0, zctr,1) nctr = 0 kctr = 0 ! loop over the current cycle. ! as we go, we sum the logical centers ! of all non-wake networks into zctr ! for subsequent averaging. 5350 continue k = (kk-1)/2 + 1 iul = kk - 2*(k-1) ntdk = ntd(k) if ( ntdk.ne.6 .and. ntdk.ne.18 .and. ntdk.ne.20 ) then call daxpy (3, 1.d0, zctrgn(1,iul,k),1, zctr,1) kctr = kctr + 1 endif nctr = nctr + 1 kkrgn(nctr) = kk nloop = nloop + 1 if ( nloop.gt.nnett2+1 ) call abtend & & ('abtdue: region definition inf. loop (1) ') kk = kptrgn(kk) if ( kk.ne.init ) goto 5350 ! nsfrgn(ntrgn) = nctr xctr = kctr if ( kctr.eq.0 ) then call a502ms ('abtdue','a group of wakes is fully detached ') else xctr = 1./xctr endif call dscal (3, xctr, zctr,1) call shlsrt (nctr,kkrgn) ! copy zctr into zctrgn kk = init nloop = 0 5360 continue k = (kk-1)/2 + 1 iul = kk - 2*(k-1) call dcopy (3, zctr,1, zctrgn(1,iul,k),1) indrgn(iul,k) = ntrgn nloop = nloop + 1 if ( nloop.gt.nnett2+1 ) call abtend & & ('abtdue: region definition inf. loop (2) ') kknw = iabs( kptrgn(kk) ) kptrgn(kk) = -kknw kk = kknw if ( kk.ne.init ) goto 5360 ! generate a report on the region kprv = 0 nboth = 0 do 5370 ictr = 1,nctr kk = kkrgn(ictr) k = (kk-1)/2 + 1 iul = kk - 2*(k-1) csurf = 'upper' if ( iul.eq.2 ) csurf = 'lower' mat = matnet(iul,k) cmatrl = qratio(mat) ntdk = ntd(k) ktdk = 0 if ( ntdk.eq.12 ) ktdk = 1 if ( ntdk.eq.18 ) ktdk = 2 if ( ntdk.eq.20 ) ktdk = 3 if ( ntdk.eq. 6 ) ktdk = 4 chboth = ' ' ktnw = kttype(k) wakenw = .false. if ( ntdk.eq.6 .or. ntdk.eq.18 .or. ntdk.eq.20 ) wakenw=.true. if ( k.eq.kprv .and. ktnw.ne.2 .and. (.not.wakenw) ) then chboth = '*' nboth = nboth + 1 endif if ( ictr.eq.1 ) write (6,6005) ntrgn, k, chboth, nwname(k) & & ,cdbtyp(ktdk), csurf, cmatrl & & , (zctrgn(i,iul,k),i=1,3) if ( ictr.gt.1 ) write (6,6006) k, chboth, nwname(k) & & ,cdbtyp(ktdk), csurf, cmatrl kprv = k 5370 continue chboth = ' ' if ( nboth.gt.1 ) chboth = 's' if ( nboth.gt.0 ) write (6,6008) nboth, chboth 6008 format (' *** probable error *** both surfaces of ',i3 & & ,' non-wake network',a1,' noted above by *, bound this region ') write (6,6007) 6004 format (//, & & ' surfaces associated with various regions of the ' & & , 'configuration ' & & ,/, 2x,'region',' nw-id',' nw-name',' dblt-type',' surface'& & ,4x,'material',20x,'r/ctr' & & ) 6005 format (3x,i3,2x, i5,2x, a1,a10, 1x,a10, 4x,a5, 4x,a10, 3f12.6) 6006 format (3x,3x,2x, i5,2x, a1,a10, 1x,a10, 4x,a5, 4x,a10 ) 6007 format (1h ) ! goto 5310 ! ! ! 5400 continue return END subroutine abtdue ! **deck abtdzo subroutine abtdzo (nnett,nm,nn,z,epsgeo,nza,zsv) implicit double precision (a-h,o-z) dimension nm(150), nn(150), z(3,4000), nza(151), zsv(3,4000) ! logical header ! header = .false. do 100 k = 1,nnett l = nza(k) + 1 call dzbchk (k,nm(k),nn(k),epsgeo, z(1,l),zsv(1,l),header) 100 continue if ( header ) call emark ('nwedgmov') if ( .not. header ) write (6,6001) 6001 format (//,' ***** no points were moved by the liberalized geome& &try processor (controlled by $eat) ***** ',//) return END subroutine abtdzo !! subroutine abtecd (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,iedgtp,sdnst,smach,ztedg,dstedg, icrntp & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtecd subroutine abtecd (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym, & ! Added by Martin Hegedus, 4/21/09 & nza,iedgtp,sdnst,smach,ztedg,dstedg, icrntp & ! Added by Martin Hegedus, 4/21/09 & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension iedgtp(600), sdnst(600), smach(600), icrntp(600) & & , ztedg(6,600), dstedg(600) ! dimension dz(3), enint(3) & & , zp(3), qpqp(3,3), tvec(3), qmid(3) logical epsequ, badedg, abut, connec !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg ! ! do NOT exclude source alone nw's ! from the abutment search by ! setting xsrcab = .false. The ! value .true. is to be used for ! conventional processing. xsrcab = .true. nedgt = 4*nnett call zero (sdnst,nedgt) call zero (smach,nedgt) do 200 knet = 1,nnett do 200 ksd = 1,4 call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) kedg = ksd + 4*(knet-1) iedgtp(kedg) = 0 if ( ntd(knet).eq.0 .and. xsrcab ) goto 200 ! check for collapsed edge ncolps = 0 do 10 ij = 2,knedg kz1 = kzedg + (ij-2)*kncedg kz2 = kz1 + kncedg call idngeo (z(1,kz1),z(1,kz2),epsgeo, epsequ) if ( epsequ ) ncolps = ncolps + 1 10 continue badedg = .false. if ( ncolps.ne.0 .and. ncolps.ne.knedg-1 ) badedg = .true. if ( .not.badedg ) go to 20 call abtmsg ('*fatal* partially collapsed edge found') write (6,6001) knet,ksd do 12 ij = 2,knedg kz1 = kzedg + (ij-2)*kncedg kz2 = kz1 + kncedg call idngeo (z(1,kz1),z(1,kz2),epsgeo,epsequ) if ( .not. epsequ ) go to 12 write (6,6002) (ij-1),(z(i,kz1),i=1,3) & & ,ij ,(z(i,kz2),i=1,3) 12 continue 20 continue ! check that edge does not have ! to many meshpoints if ( knedg .le. mxedmp ) go to 30 call abtmsg ('*fatal* too many points in nw edge') write (6,'(1x,a10,1x, 2i12)') & & 'net,edge',knet,ksd 30 continue ! set edge type iedgtp(kedg) = 0 if ( ntd(knet).eq.0 .and. xsrcab ) goto 200 iedgtp(kedg) = 1 if ( ncolps.ne.0 ) go to 200 iedgtp(kedg) = 2 ! if ( ntd(knet) .eq. 0 ) goto 100 if ( ntd(knet) .eq. 4 ) go to 104 if ( ntd(knet) .eq. 6 ) go to 106 if ( ntd(knet) .eq. 12 ) go to 112 if ( ntd(knet) .eq. 18 ) go to 118 if ( ntd(knet) .eq. 20 ) go to 120 call abtend ('200 loop, abtidn') ! doublet type = 0, no doublet at all 100 continue goto 150 ! doublet type = 4 104 continue if ( ksd.eq.1 .or. ksd.eq.4 ) iedgtp(kedg) = 5 go to 150 ! doublet type = 6, design wake (lev):m 106 continue if ( ksd.eq.1 ) iedgtp(kedg) = 5 if ( ksd.eq.2 ) iedgtp(kedg) = 4 if ( ksd.eq.4 ) iedgtp(kedg) = 4 go to 150 ! doublet type = 12, doublet analysis 112 continue iedgtp(kedg) = 4 go to 150 ! doublet type = 18, doublet wake 1 118 continue if ( ksd.eq.1 ) iedgtp(kedg) = 5 go to 150 ! doublet type = 20, doublet wake 2 120 continue go to 150 ! ! characterize the middle elementary ! edge segment 150 continue ij = knedg/2 + 1 kz1 = kzedg + (ij-2)*kncedg kz2 = kz1 + kncedg kw1 = kz1 + kncint kw2 = kz2 + kncint call intnrm ( z(1,kz1),z(1,kz2) & & ,z(1,kw1),z(1,kw2), enint) call vip (enint,1, comprs,1, 3, sdnst(kedg) ) call vadd (z(1,kz2),-1.d0,z(1,kz1),dz,3) call uvect (dz) call cpip (dz,dz,smach(kedg)) 200 continue if ( ierabt.gt.0 ) call abtend ('abtecd: stopped, due to errors') ! characterize corners do 400 knet = 1,nnett do 400 kcn = 1,4 kcorn = kcn + 4*(knet-1) icrntp(kcorn) = 0 if ( ntd(knet).eq.0 .and. xsrcab ) goto 400 if ( iedgtp(kcorn).eq.1 ) icrntp(kcorn) = 1 if ( iedgtp(kcorn).eq.1 ) go to 400 kcnp = mod(kcn+2,4) + 1 kcornp = kcnp + 4*(knet-1) if ( iedgtp(kcornp).eq.1 ) kcnp = mod(kcn+1,4) + 1 kcornp = kcnp + 4*(knet-1) icrntp(kcorn) = 2 ! set corner type if ( ntd(knet) .eq. 0 ) go to 300 if ( ntd(knet) .eq. 4 ) go to 304 if ( ntd(knet) .eq. 6 ) go to 306 if ( ntd(knet) .eq. 12 ) go to 312 if ( ntd(knet) .eq. 18 ) go to 318 if ( ntd(knet) .eq. 20 ) go to 320 call abtend ('400 loop, abtidn') ! ntd(knet) = 0 300 continue goto 350 ! ntd(knet) = 4 304 continue if ( kcn.eq.1 .or. kcnp.eq.4 ) icrntp(kcorn) = 5 if ( kcn.eq.2 .or. kcnp.eq.1 ) icrntp(kcorn) = 4 if ( kcn.eq.4 .or. kcnp.eq.3 ) icrntp(kcorn) = 4 go to 350 ! ntd(knet) = 6 306 continue if ( kcn.eq.1 .or. kcnp.eq.4 ) icrntp(kcorn) = 5 if ( kcn.eq.2 .or. kcnp.eq.1 ) icrntp(kcorn) = 5 go to 350 ! ntd(knet) = 12 312 continue icrntp(kcorn) = 4 go to 350 ! ntd(knet) = 18 318 continue if ( kcn.eq.1 .or. kcnp.eq.4 ) icrntp(kcorn) = 5 if ( kcn.eq.2 .or. kcnp.eq.1 ) icrntp(kcorn) = 5 go to 350 ! ntd(knet) = 20 320 continue if ( kcn.eq.1 .or. kcnp.eq.4 ) icrntp(kcorn) = 5 go to 350 ! ! ! 350 continue 400 continue ! compute quantities (ztedg,dstedg) fo ! use in a fast abutment test. call zero (ztedg,6*nedgt) call zero (dstedg,nedgt) do 650 knet = 1,nnett do 600 ksd = 1,4 kedg = ksd + 4*(knet-1) if ( iedgtp(kedg) .le. 1 ) go to 600 call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) call zero (zp,3) dedge = 0.d0 do 440 ij = 2,knedg kz1 = kzedg + (ij-2)*kncedg kz2 = kz1 + kncedg call distnc ( z(1,kz1), z(1,kz2), dseg) call vadd ( zp, .5d0*dseg, z(1,kz1), zp, 3) call vadd ( zp, .5d0*dseg, z(1,kz2), zp, 3) dedge = dedge + dseg 440 continue call vmul ( zp, 1.d0/dedge, zp, 3) call zero (qpqp,9) do 470 ij = 2,knedg kz1 = kzedg + (ij-2)*kncedg kz2 = kz1 + kncedg call distnc ( z(1,kz1), z(1,kz2), dseg) do 450 i = 1,3 qmid(i) = .5d0*( z(i,kz1) + z(i,kz2) ) - zp(i) dz(i) = z(i,kz2) - z(i,kz1) 450 continue fdz = 1.d0/12.d0 do 460 i = 1,3 do 460 j = 1,3 qpqp(i,j) = qpqp(i,j) + & & dseg*( qmid(i)*qmid(j)+fdz*dz(i)*dz(j) ) 460 continue 470 continue call domvec (qpqp,tvec) ! dmax = 0.d0 taumin = 0.d0 taumax = 0.d0 do 480 ij = 1,knedg kz1 = kzedg + (ij-1)*kncedg call vadd ( z(1,kz1), -1.d0, zp, dz, 3) call vip (dz,1, tvec,1, 3, tau) taumin = min ( taumin, tau) taumax = max ( taumax, tau) call vadd ( zp, tau, tvec, dz, 3) call distnc (dz, z(1,kz1), dist) dmax = max ( dmax, dist) 480 continue call vadd ( zp, taumin, tvec, ztedg(1,kedg), 3) call vmul ( tvec, (taumax-taumin), ztedg(4,kedg), 3) dstedg(kedg) = dmax 600 continue 650 continue return 6001 format (' network no.',i5,' edge no.',i5 & & ,/,' list of collapsed edge segments follows ') 6002 format ( /,' from edge pt # ',i3,4x,3f12.6 & & ,/,' to edge pt # ',i3,4x,3f12.6 ) END subroutine abtecd ! **deck abtefg subroutine abtefg (iabt,iul,kedg,jul,ledg & & ,nefgst,nefgsa,kptefg, ipmx,iptr,kkvlst,wtvlst & & ,nedaba,kfdkey,kfdseg,kfdsgn & & ,nm,nn,nza,z,epsgeo & & ) implicit double precision (a-h,o-z) dimension nefgsa(600), kptefg(1:nefgst) & & , kkvlst(2,1:*), wtvlst(2,1:*) dimension nedaba(1:*), kfdkey(1:*), kfdseg(4,1:*), kfdsgn(1:*) dimension nm(1:*), nn(1:*), nza(1:*), z(3,1:*) ! ! update the kptefg array (the fine grid edge meshpoint pointer ! data structure), adding in the equivalence relations found ! along abutment iabt. If a fine grid point interior to an ! abutment does not participate in any equivalence relation, ! set a negative pointer in kptefg and add entries to the ! (kkvlst,wtvlst) data structure. ! ! iabt in int abutment index ! iul in int surface index, 1st edge (1=u,2=l) ! kedg in int edge index, 1st edge ! jul in int surface index, 2nd edge ! ledg in int edge index, 2nd edge ! nefgst in int total number of fine grid edge meshpoints, u+l ! nefgsa in int cum counts of fine grid edge meshpoints, u+l ! kptefg i/o int pointer data structure for fine grid equiv. ! classes; if <0, a pointer into (kkvlst,wtvlst). ! iptr i/o int current count of entries in (kkvlst,wtvlst) ! kkvlst i/o int pairs of fine grid indices pointed to by ! ptr < iptr ! wtvlst i/o int weights corresponding to the kkvlst pairs ! nedaba in int pointer array into kfdkey describing abutments ! kfdkey in int contains fundamental segment lists for abutments ! kfdseg in int fundamental segment descriptions ! kfdsgn in int kfdsgn(kfsg) = sgn(kfsg) * IABT(kfsg) ! nm in int mesh point row counts for nw's ! nn in int mesh point col counts for nw's ! nza in int cum mesh pt counts for nw's, pointers into z ! z in r*8 configuration mesh points ! epsgeo in r*8 global geometric tolerance ! dimension imp(2), jmp(2) !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg ! ! ! find iek, iel, where kedg and ledg ! appear in iabt's sublist and get ! full information about the 2 edges ! that oppose on another iedgbs = nedaba(iabt) ne = nedaba(iabt+1) - nedaba(iabt) iek = 0 iel = 0 do 100 ie = 1,ne ifsg = kfdkey(iedgbs+ie) if ( kfdseg(2,ifsg) .eq. kedg ) iek = ie if ( kfdseg(2,ifsg) .eq. ledg ) iel = ie 100 continue if ( (iek.eq.0 .or. iel.eq.0) .or. & & (iek.eq.iel .and. iul.eq.jul) ) then write (6,6100) iabt,iul,kedg,iek, jul,ledg,iel call abtend ('abtefg: invalid edge membership in abutment') endif 6100 format (' iabt, iul,kedg,iek, jul,ledg,iel',i5,3x,3i5,3x,3i5) kfsg = kfdkey(iedgbs+iek) lfsg = kfdkey(iedgbs+iel) ksgn = isign(1,kfdsgn(kfsg)) lsgn = isign(1,kfdsgn(lfsg)) call icopy (4, kfdseg(1,kfsg),1, kokseg,1) call icopy (4, kfdseg(1,lfsg),1, lokseg,1) call mnmod (kedg,4,ksd,knet) call mnmod (ledg,4,lsd,lnet) call edgind (ksd,nm(knet),nn(knet), kzedg,kncedg,kncint,knedg) call edgind (lsd,nm(lnet),nn(lnet), lzedg,lncedg,lncint,lnedg) knfsg = i2kseg - i1kseg + 1 lnfsg = i2lseg - i1lseg + 1 kzedg = kzedg + nza(knet) lzedg = lzedg + nza(lnet) kzfsg = kzedg + (i1kseg-1) lzfsg = lzedg + (i1lseg-1) ! define the endpoints of the ! opposing segments, respecting sign if ( ksgn.gt.0 ) then imp(1) = i1kseg imp(2) = i2kseg else imp(1) = i2kseg imp(2) = i1kseg endif ! if ( lsgn.gt.0 ) then jmp(1) = i1lseg jmp(2) = i2lseg else jmp(1) = i2lseg jmp(2) = i1lseg endif ! enter the equivalence relations ass- ! ociated with the abutment ends, ! which always occur at abutment ! intersections do 200 iend = 1,2 impx = 2*imp(iend) - 1 jmpx = 2*jmp(iend) - 1 call edgfgi (iul,kedg,impx, nm,nn,nefgsa, kkmp) call edgfgi (jul,ledg,jmpx, nm,nn,nefgsa, llmp) call mpteqc (kptefg,nefgst, kkmp,llmp) 200 continue ! loop over the interior of each of ! the two edge segments, entering ! equivalence relations or generating ! pointers into (kkvlst,wtvlst) call abt2fg (iul,kedg,i1kseg,i2kseg,kzedg,kncedg,knfsg & & ,jul,ledg,i1lseg,i2lseg,lzedg,lncedg,lnfsg & & ,nefgst,nefgsa,kptefg, ipmx,iptr,kkvlst,wtvlst & & ,nm,nn,z,nnett,epsgeo & & ) ! call abt2fg (jul,ledg,i1lseg,i2lseg,lzedg,lncedg,lnfsg & & ,iul,kedg,i1kseg,i2kseg,kzedg,kncedg,knfsg & & ,nefgst,nefgsa,kptefg, ipmx,iptr,kkvlst,wtvlst & & ,nm,nn,z,nnett,epsgeo & & ) ! return END subroutine abtefg ! **deck abtels subroutine abtels (p1,p2, ze,ince,ne, epsgeo, abut,te1,te2) implicit double precision (a-h,o-z) dimension p1(3), p2(3), ze(3) logical abut ! determine if the elementary segment (p1,p2) lies near ! (within epsgeo) to the edge (ze,ince,ne) ! dimension z13(3), z23(3), z1(3), z2(3), dp(3), p13(3), p23(3) data p333/ .333333333333333d0/, p666/ .666666666666666d0/ abut = .false. call nredge (p1, ze,ince,ne, 1,0.d0, z1,t1,d1) call nredge (p2, ze,ince,ne, 1,0.d0, z2,t2,d2) if ( d1.gt.epsgeo .or. d2.gt.epsgeo ) go to 950 ! dp(1) = p2(1) - p1(1) dp(2) = p2(2) - p1(2) dp(3) = p2(3) - p1(3) ! p13(1) = p1(1) + p333*dp(1) p13(2) = p1(2) + p333*dp(2) p13(3) = p1(3) + p333*dp(3) ! p23(1) = p1(1) + p666*dp(1) p23(2) = p1(2) + p666*dp(2) p23(3) = p1(3) + p666*dp(3) ! call nredge (p13, ze,ince,ne, 1,0.d0, z13,t13,d13) call nredge (p23, ze,ince,ne, 1,0.d0, z23,t23,d23) if ( d13.gt.epsgeo .or. d23.gt.epsgeo ) go to 950 isgn = 1 if ( t13 .gt. t23 ) isgn = -1 call nredge (p1, ze,ince,ne, -isgn,t13, z1,t1,d1) call nredge (p2, ze,ince,ne, isgn,t23, z2,t2,d2) if ( d1.gt.epsgeo .or. d2.gt.epsgeo ) go to 950 ! all tests passed, set abut = .true. abut = .true. te1 = t1 te2 = t2 ! 950 continue return END subroutine abtels ! **deck abtemp subroutine abtemp (ne,kfds,ksgn, z,nza,nm,nn,nedmpa, epsgeo & & ,kptemp,nedmp) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! dimension kfds(4*ne),ksgn(ne),z(3,4000),nza(151),nm(150),nn(150) & & , nedmpa(601), kptemp(nedmp) ! include all point to point equivalence relations associated ! with an abutment into the kptemp circulant pointer data ! structure for network edge mesh points dimension dzedg(mxeiab), zk(3), zl(3) dimension indocc(mxeiab) ! integer pqemp(6*mxedmp), pqmap(6*mxedmp), keyemp(6*mxedmp) dimension dpqemp(3*mxedmp), kpntpq(6*mxedmp) ! integer pqsv !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg ! if ( ne.le.1 ) return if ( ne.gt.mxeiab ) goto 8000 ! compute all edge lengths and the mini ! and maximum values of edge length. do 100 ie = 1,ne call icopy (4, kfds(4*ie-3),1, kokseg,1) imp1 = i1kseg imp2 = i2kseg call mnmod (kedseg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) dzedg(ie) = 0.d0 imp2m1 = imp2 - 1 do 50 imp = imp1,imp2m1 kz1 = kzedg + (imp-1)*kncedg kz2 = kz1 + kncedg call distnc (z(1,kz1),z(1,kz2),dz) dzedg(ie) = dzedg(ie) + dz 50 continue if ( ie.ne.1 ) go to 60 dzmin = dzedg(ie) dzmax = dzedg(ie) 60 continue dzmin = min ( dzmin, dzedg(ie) ) dzmax = max ( dzmax, dzedg(ie) ) 100 continue ! # call outvec ("dzedg",ne,dzedg) if ( dzmin .lt. .9d0*dzmax ) go to 8100 epstau = epsgeo/dzmin ! define the equivalence relations for ! the abutment endpoints and collect ca ! equivalence relations for the abutmen ! interior nemp = 0 do 500 ie = 1,ne call icopy (4, kfds(4*ie-3),1, kokseg,1) kedg = kedseg call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet),kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) if ( ksgn(ie) .gt. 0 ) go to 120 i1ksgn = i2kseg i2ksgn = i1kseg go to 140 120 continue i1ksgn = i1kseg i2ksgn = i2kseg 140 continue call edgmpi (kedg,i1ksgn,nedmpa, kedmp1) call edgmpi (kedg,i2ksgn,nedmpa, kedmp2) if ( ie .gt. 1 ) go to 160 k1s = kedmp1 k2s = kedmp2 go to 180 160 continue call mpteqc (kptemp,nedmp, kedmp2,k2s) call mpteqc (kptemp,nedmp, kedmp1,k1s) 180 continue ! done with the end points, now examine ! the interior points for candidate eq. kmp1 = i1kseg + 1 kmp2 = i2kseg - 1 kzseg = kzedg + (i1kseg-1)*kncedg knseg = i2kseg - i1kseg + 1 if ( kmp1 .gt. kmp2 ) go to 410 do 400 kmp = kmp1,kmp2 tkmp = kmp - i1kseg + 1 call edgtau (z(1,kzseg),kncedg,knseg,dzedg(ie), tkmp & & ,taukmp) if ( ksgn(ie) .lt. 0 ) taukmp = 1.d0-taukmp call epoint (z(1,kzseg),kncedg,knseg, tkmp, zk) do 350 je = ie,ne if ( je.eq.ie ) go to 350 call icopy (4, kfds(4*(je)-3),1, lokseg,1) ledg = ledseg call mnmod (ledg,4,lsd,lnet) call edgind (lsd,nm(lnet),nn(lnet) & & ,lzedg,lncedg,lncint,lnedg) lzedg = lzedg + nza(lnet) lmp1 = i1lseg + 1 lmp2 = i2lseg - 1 lzseg = lzedg + (i1lseg-1)*lncedg lnseg = i2lseg - i1lseg + 1 if ( lmp1 .gt. lmp2 ) go to 310 do 300 lmp = lmp1,lmp2 tlmp = lmp -i1lseg + 1 call edgtau (z(1,lzseg),lncedg,lnseg,dzedg(je) & & ,tlmp, taulmp) if ( ksgn(je) .lt. 0 ) taulmp = 1.d0-taulmp call epoint (z(1,lzseg),lncedg,lnseg, tlmp, zl) call distnc (zk,zl,dzkl) if ( dzkl .gt. epsgeo ) goto 300 nemp = nemp + 1 if ( nemp.gt.(3*mxedmp) ) goto 8200 pqemp(2*nemp-1) = 100000*kedg +kmp*100 + ie pqemp(2*nemp ) = 100000*ledg +lmp*100 + je dpqemp(nemp) = dzkl 300 continue 310 continue 350 continue 400 continue 410 continue 500 continue if ( nemp.le.0 ) go to 950 ! ! # call outmat ("pqemp",2,2,nemp,pqemp) ! # call outvec ("dpqemp",nemp,dpqemp) ! all candidate equivalence relations f ! give sequential names to the entries ! pqemp, saving their full names in pqm call jshell (2*nemp,pqemp,keyemp) pqsv = 0 npq = 0 nemp2 = 2*nemp do 600 j = 1,nemp2 if ( pqemp(j) .eq. pqsv ) go to 550 ! pqsv = pqemp(j) npq = npq + 1 pqmap(npq) = pqsv 550 continue pqemp(j) = npq 600 continue ! call ukysrt (2*nemp,pqemp,keyemp) mxx = 2 nxx = nemp call mtrxtp (pqemp,mxx,nxx,1) call dshell (nemp,dpqemp,keyemp) call keysrt (nemp,pqemp(1),keyemp) call keysrt (nemp,pqemp(nemp+1),keyemp) ! ! # call outmat ("pqemp",nemp,nemp,2,pqemp) ! # call outvec ("dpqemp",nemp,dpqemp) ! # call outvec ("pqmap",npq,pqmap) do 650 ipq = 1,npq kpntpq(ipq) = ipq 650 continue ! now carefully examine all the candida ! equivalence relations, in order, for ! ible inclusion do 700 iemp = 1,nemp ip = pqemp(iemp) iq = pqemp(iemp+nemp) ipglo = pqmap(ip) iqglo = pqmap(iq) call jzero (indocc,ne) ! kpq = ip 660 continue ipqglo = pqmap(kpq) iepq = mod(ipqglo,100) indocc(iepq) = indocc(iepq) + 1 kpq = kpntpq(kpq) if ( kpq .ne. ip ) go to 660 ! kpq = iq 670 continue ipqglo = pqmap(kpq) iepq = mod(ipqglo,100) indocc(iepq) = indocc(iepq) + 1 kpq = kpntpq(kpq) if ( kpq .ne. iq ) go to 670 ! do 680 ie = 1,ne if ( indocc(ie) .gt. 1 ) go to 700 680 continue call mpteqc (kpntpq,npq, ip,iq) kedg = ipglo/100000 ledg = iqglo/100000 kmp = (ipglo-kedg*100000)/100 lmp = (iqglo-ledg*100000)/100 call edgmpi (kedg,kmp,nedmpa, kedmpx) call edgmpi (ledg,lmp,nedmpa, ledmpx) call mpteqc (kptemp,nedmp, kedmpx,ledmpx) dpq = dpqemp( iemp ) if ( dpq.le.epsgeo ) go to 700 ! equivalenced points further apart tha ! epsgeo, the geometric tolerance call mnmod (kedg,4,ksd,knet) call mnmod (ledg,4,lsd,lnet) write (6,6400) knet,ksd,kmp, lnet,lsd,lmp, dpq,epsgeo 6400 format ('0 *** warning *** (abtemp)' ,/, & & 15x,' point at (nw,side,edge pt) = ', & & 1h(, i3, 1h,, i1, 1h,, i3, 1h) & & ,' equivalenced to ',/, & & 15x,' point at (nw,side,edge pt) = ', & & 1h(, i3, 1h,, i1, 1h,, i3, 1h) & & ,/,15x,' separation of points was ',e12.4,', tolerance =' & & ,e12.4) 700 continue 950 continue ! # call outvec ("kpntpq",npq,kpntpq) return ! 8000 continue call abtend ('abtemp: too many edges in an abutment') 8100 continue call abtend ('abtemp: more than 10% variation in edge lengths') 8200 continue call abtend ('abtemp: internal data buffer overflow') END subroutine abtemp ! **deck abtend subroutine abtend (msg) implicit double precision (a-h,o-z) character*(*) msg character*50 xmsg ! print an error message from the abutment analyzer !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg ierabt = ierabt + 1 write (6,6000) msg 6000 format ('0 error in abutment processor',1x,a40) xmsg(1:10) = 'abtend ' xmsg(11:50)= msg call remarx (xmsg) CALL AbortPanair('abtend') return END subroutine abtend ! **deck abteqc subroutine abteqc (kpt,ksgn,npt, ix,jx,ijsgn) implicit double precision (a-h,o-z) dimension kpt(npt), ksgn(npt) ! enter the equivalence relation ix .=. jx into the circulan ! pointer array, kpt . if ( ix.lt.1 .or. ix.gt.npt .or. jx.lt.1 .or. jx.gt.npt ) & & call abtend ('fatal error in abteqc, 1') ! if ( ix.eq.jx ) go to 950 if ( kpt(ix).ne.ix ) go to 50 if ( kpt(jx).ne.jx ) go to 200 go to 100 50 continue if ( kpt(jx).ne.jx ) go to 400 go to 300 ! kpt(ix) = ix, kpt(jx) = jx 100 continue kpt(ix) = jx kpt(jx) = ix ksgn(jx)= ijsgn go to 950 ! kpt(ix) = ix, kpt(jx) $ jx 200 continue kpt(ix) = kpt(jx) kpt(jx) = ix ksgn(ix)= ijsgn*ksgn(jx) go to 950 ! kpt(ix) $ ix, kpt(jx) = jx 300 continue kpt(jx) = kpt(ix) kpt(ix) = jx ksgn(jx)= ijsgn*ksgn(ix) ! kpt(ix) $ ix, kpt(jx) $ jx 400 continue nloop = 0 kx = ix ! 420 continue nloop = nloop+1 if ( kx.lt.1 .or. kx.gt.npt .or. nloop.gt.npt+2 ) go to 1200 kx = kpt(kx) if ( kx.eq.jx ) go to 950 if ( kx.ne.ix ) go to 420 ! nloop = 0 lx = jx lsgn = ksgn(ix) * ijsgn ! 440 continue nloop = nloop+1 if ( lx.lt.1 .or. lx.gt.npt .or. nloop.gt.npt+2 ) go to 1200 ksgn(lx)= lsgn*ksgn(lx) lx = kpt(lx) if ( lx.ne.jx ) go to 440 ! kptsv = kpt(jx) kpt(jx) = kpt(ix) kpt(ix) = kptsv ! 950 continue return ! 1200 continue call abtend ('looping error in abteqc') return END subroutine abteqc ! **deck abtfor subroutine abtfor(k,isd,l,jsd,nok) implicit double precision (a-h,o-z) ! ! abtfor is identical to abtchk except that we set nforc=1 in ! abtfor, whereas nforc=0 in abtchk. ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts dimension z(3,200) data nzsk /200/ ! ! ! nforc=1 neq=0 nok=0 call mnmod(isd,2,misd,nisd) izmax=nn(k)*(2-misd)+nm(k)*(misd-1) if(izmax.gt.nzsk) go to 910 iz1=1 iz2=izmax call mnmod(jsd,2,mjsd,njsd) jzmax=nn(l)*(2-mjsd)+nm(l)*(mjsd-1) nza(1)=0 netmax=max (k,l) do 100 i=1,netmax 100 nza(i+1)=nza(i)+nm(i)*nn(i) nzak=nza(k) call mshind(isd,1,1,nm(k),nn(k),kp1) kp1=nzak+kp1 call cpetp(l,jsd,1,jzmax,zm(1,kp1),jz1) call mshind(isd,izmax,1,nm(k),nn(k),kp2) kp2=nzak+kp2 call cpetp(l,jsd,1,jzmax,zm(1,kp2),jz2) if(jz1.ne.jz2) go to 175 if((jz1.ne.1).and.(jz1.ne.jzmax)) go to 900 jz1=1 jz2=jzmax 175 continue nj=iabs(jz2-jz1)+1 if(nj.eq.2) go to 200 jsin=1 if(jz2.lt.jz1) jsin=-1 call cpetp(l,jsd,jz1+jsin,jz2,zm(1,kp1),jzm) if(jzm.eq.jz2) neq=1 200 continue call edgabt(k,isd,iz1,iz2,l,jsd,jz1,jz2,z,nok,nch) if(nok.ne.0) go to 350 if(nforc.eq.1) go to 900 if(nj.gt.nzsk) go to 910 jzmn=min (jz1,jz2) jzmx=max (jz1,jz2) iz=iz1 if(jz2.lt.jz1) iz1=iz2 if(jz2.lt.jz1) iz2=iz call edgabt(l,jsd,jzmn,jzmx,k,isd,iz1,iz2,z,nok,nch) 350 if((nforc.eq.0).and.(nch.eq.0)) nok=0 if(nforc.eq.0) go to 900 do 500 iz=1,izmax call mshind(isd,iz,1,nm(k),nn(k),kp) kp=nzak+kp zm(1,kp)=z(1,iz) zm(2,kp)=z(2,iz) zm(3,kp)=z(3,iz) 500 continue 900 continue if((nok.ne.0).or.(neq.eq.0)) go to 905 neq=0 jz=jz1 jz1=jz2 jz2=jz iz1=1 iz2=izmax go to 200 905 return 910 continue write(6,9100) 9100 format(//1x,44hscratch point array z in abtfor is too small,//) stop END subroutine abtfor !! subroutine abtfsd (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,nseglo,kabut,labut,t1abut,t2abut,klabut & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtfsd subroutine abtfsd (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,nseglo,kabut,labut,t1abut,t2abut,klabut & ! Added by Martin Hegedus, 4/21/09 & ,ztedg,dstedg & & ,iedgtp,nfsga,nfdseg,kfdseg & & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension kabut(9600), labut(9600), t1abut(2400), t2abut(2400) & & , klabut(19200) dimension iedgtp(600), nfsga(601), kfdseg(3200) & & , ztedg(6,600), dstedg(600) ! dimension z1p(3), z2p(3), zm1(3), zm2(3) dimension t1pseg(mxedmp), t2pseg(mxedmp), i1seg(mxedmp) & & , i2seg(mxedmp), imesh(mxedmp) logical epsequ, abut, connec !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg !call abtprt common /abtprt/ igeoin, igeout, nwxref, nwprop, iabutd & & , iabsum !end abtprt ! nedgt = 4*nnett ! define abutments nlsegf = 0 nseglo = 0 ncall = 0 kerr = 0 ! loop on subject edges, kedg do 1000 kedg = 1,nedgt if ( iedgtp(kedg).le.1 ) go to 1000 call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet), kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) nsegk = 0 ! loop on object edges, ledg do 900 ledg = 1,nedgt if ( iedgtp(ledg).le.1 .or. kedg.eq.ledg ) go to 900 call mnmod (ledg,4,lsd,lnet) call edgind (lsd,nm(lnet),nn(lnet), lzedg,lncedg,lncint,lnedg) lzedg = lzedg + nza(lnet) ! perform the rapid abutment test call d2line (ztedg(1,kedg),ztedg(1,ledg),dist) ncall = ncall + 1 nobutt = 0 if ( dist .gt. dstedg(kedg)+dstedg(ledg)+3.d0*epsgeo ) nobutt=1 if ( nobutt.eq.1 ) go to 900 ! examine each elementary edge segment ! of edge kedg for abutment to edge ! ledg. kelseg = 0 do 500 kmp = 2,knedg kz1 = kzedg + (kmp-2)*kncedg kz2 = kz1 + kncedg call abtels (z(1,kz1),z(1,kz2), z(1,lzedg),lncedg,lnedg & & ,epsgeo, abut,t1p,t2p) if ( .not. abut ) go to 500 ! kelseg = kelseg + 1 t1pseg(kelseg) = t1p t2pseg(kelseg) = t2p i1seg(kelseg) = kmp-1 i2seg(kelseg) = kmp ! 500 continue if ( kelseg.le.0 ) go to 900 ! aggregate elementary segments into ! connected segments iseg1 = 1 iseg2 = 1 kagseg = 0 if ( 2.gt.kelseg ) go to 610 do 600 iseg = 2,kelseg connec = .true. sgnchg = (t2pseg(iseg-1) - t1pseg(iseg-1)) * & & (t2pseg(iseg ) - t1pseg(iseg )) if ( sgnchg.le.0.d0 .or. i2seg(iseg-1).ne.i1seg(iseg) ) & & connec = .false. if ( .not. connec ) go to 550 ! t2p = t2pseg(iseg-1) t1p = t1pseg(iseg) call epoint (z(1,lzedg),lncedg,lnedg, t1p, z1p) call epoint (z(1,lzedg),lncedg,lnedg, t2p, z2p) call idngeo (z1p,z2p,epsgeo, epsequ) if ( .not. epsequ ) connec = .false. ! 550 continue if ( connec ) go to 590 ! (iseg1.iseg2) kagseg = kagseg + 1 indseg = nseglo + nsegk + kagseg if(indseg.gt.mxiabt) call abtend('abtidn: mxiabt overflow, 1') kokseg = 0 kedseg = kedg i1kseg = i1seg( iseg1 ) i2kseg = i2seg( iseg2 ) call icopy (4, kokseg,1, kabut(4*(indseg)-3),1) t1abut(indseg) = t1pseg(iseg1) t2abut(indseg) = t2pseg(iseg2) ! iseg1 = iseg ! 590 continue iseg2 = iseg 600 continue 610 continue ! kagseg = kagseg + 1 indseg = nseglo + nsegk + kagseg if(indseg.gt.mxiabt) call abtend ('abtidn: mxiabt overflow, 2') kokseg = 0 kedseg = kedg i1kseg = i1seg(iseg1) i2kseg = i2seg(iseg2) call icopy (4, kokseg,1, kabut(4*(indseg)-3),1) t1abut(indseg) = t1pseg(iseg1) t2abut(indseg) = t2pseg(iseg2) if ( kagseg.gt.1 ) write (6,6002) knet,ksd, lnet,lsd ! generate object segment descriptions do 700 iagseg = 1,kagseg indseg = nseglo + nsegk + iagseg t1p = t1abut(indseg) t2p = t2abut(indseg) tmid = .5d0*(t1p+t2p) isgn = sign( 1.d0, t2p-t1p) call epoint (z(1,lzedg),lncedg,lnedg, t1p, z1p) call epoint (z(1,lzedg),lncedg,lnedg, t2p, z2p) call nrmesh (z1p, z(1,lzedg),lncedg,lnedg, -isgn,tmid & & ,zm1,i1l,d1p) call nrmesh (z2p, z(1,lzedg),lncedg,lnedg, isgn,tmid & & ,zm2,i2l,d2p) ledseg = ledg lokseg = 0 i1lseg = min ( i1l, i2l) i2lseg = max ( i1l, i2l) if ( d1p.gt.epsgeo .or. d2p.gt.epsgeo ) lokseg = 1 call icopy (4, lokseg,1, labut(4*(indseg)-3),1) ! if ( lokseg.ne.0 ) nlsegf = nlsegf + 1 call icopy (4, kabut(4*(indseg)-3),1, kokseg,1) if ( lokseg .eq. 0 ) go to 700 call abtmsg ('abtfsd: bad object edge segment found') write (6,6001) knet,ksd,i1kseg,i2kseg & & ,lnet,lsd,i1lseg,i2lseg 700 continue ! include the count of new segments if ( nobutt.eq.1 .and.kagseg.gt.0 .and.ncall.lt.500 ) & & write (6,'(1x,a10,1x, 4i12)') & & '==abut err',ncall,ledg,kedg,dist if ( nobutt.eq.1 .and. kagseg.gt.0 ) & & kerr = kerr + 1 nsegk = nsegk + kagseg ! end, loop on candidate object edges 900 continue ! done with examining all candidate ! object segments, if no segments were ! found for edge kedg, enter the ! whole edge. if ( nsegk .gt. 0 ) go to 950 ! indseg = nseglo + nsegk + 1 if(indseg.gt.mxiabt) call abtend('abtidn: mxiabt overflow, 3') kokseg = 0 kedseg = kedg i1kseg = 1 i2kseg = knedg call icopy (4, kokseg,1, kabut(4*(indseg)-3),1) lokseg = 1 ledseg = 0 i1lseg = 0 i2lseg = 0 call icopy (4, lokseg,1, labut(4*(indseg)-3),1) nlsegf = nlsegf + 1 nsegk = 1 ! 950 continue nseglo = nseglo + nsegk ! 1000 continue if ( iabsum.gt.2 ) write (6,'(1x,a10,1x, i12)') & & 'fsd kerr',kerr ! if ( iabutd.eq.0 ) go to 1030 write (6,'(1x,a10,1x, 1i12)') & & 'klabut,ti',nseglo do 1020 i = 1,nseglo call icopy (4, kabut(4*i-3),1, kokseg,1) call icopy (4, labut(4*i-3),1, lokseg,1) write (6,1005) i,kedseg,i1kseg,i2kseg & & ,ledseg,i1lseg,i2lseg & & ,t1abut(i),t2abut(i) 1005 format (1x,i4,1h., ' kedg',3i5,' ledg',3i5,2f12.6) 1020 continue 1030 continue ! ! identify the fundamental edge ! segments nfdseg = 0 call icopy (4*nseglo, kabut,1, klabut, 1) call icopy (4*nseglo, labut,1, klabut(4*nseglo+1),1) call shlsr2 (2*nseglo,klabut) nsegud = 2*nseglo - nlsegf iseg2 = 0 ! do 2000 kedg = 1,nedgt nfsga(kedg) = nfdseg if ( iedgtp(kedg) .le. 1 ) go to 2000 call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet), kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) iseg1 = iseg2 + 1 call jzero (imesh,knedg) if ( iseg1 .gt. nsegud ) go to 1060 do 1050 iseg = iseg1,nsegud call icopy (4, klabut(4*(iseg)-3),1, kokseg,1) if ( kedseg .ne. kedg ) go to 1060 iseg2 = iseg imesh(i1kseg) = 1 imesh(i2kseg) = 1 1050 continue 1060 continue if ( iseg1 .le. iseg2 ) go to 1070 write (6,'(1x,a10,1x, 3i12)') & & 'kedg,iseg ',kedg,iseg1,iseg2 call outpkv ('klabut',nsegud,klabut) call abtend ('missing edge in klabut array') 1070 continue imesh(1) = 1 imesh(knedg) = 1 ! add fundamental segments associated ! with p-o-s abutment ends if ( 3.gt.knedg ) go to 1110 !! call abtpos (z(1,kzedg ),epsgeo,nsymm, ksym1) ! Removed by Martin Hegedus, 4/21/09 !! call abtpos (z(1,kzedg+kncedg),epsgeo,nsymm, ksym2) ! Removed by Martin Hegedus, 4/21/09 call abtpos (z(1,kzedg ),epsgeo,nisym,njsym, ksym1) ! Added by Martin Hegedus, 4/21/09 call abtpos (z(1,kzedg+kncedg),epsgeo,nisym,njsym, ksym2) ! Added by Martin Hegedus, 4/21/09 kpos1 = iandfn( ksym1, ksym2) ksym1 = ksym2 do 1100 kmp = 3,knedg kz2 = kzedg + (kmp-1)*kncedg !! call abtpos (z(1,kz2),epsgeo,nsymm, ksym2) ! Removed by Martin Hegedus, 4/21/09 call abtpos (z(1,kz2),epsgeo,nisym,njsym, ksym2) ! Added by Martin Hegedus, 4/21/09 kpos2 = iandfn( ksym1, ksym2) if ( kpos2 .eq. kpos1 ) go to 1080 iset = kmp - 1 imesh(iset) = -1 1080 continue kpos1 = kpos2 ksym1 = ksym2 1100 continue 1110 continue ! get the end points of the fundamental ! segments kseg = 0 kokseg = 0 kedseg = kedg i1kseg = 1 do 1200 kmp = 2,knedg if ( imesh(kmp).eq.0 ) go to 1200 kseg = kseg + 1 i2kseg = kmp if ( nfdseg+kseg .le. mxfdsg ) go to 1150 call abtmsg ('*fatal abtfsd: too many fundamental segs') write (6,'(1x,a10,1x, 2i12)') & & 'net,edge',knet,ksd call abtend ('too many fundamental segments, job stop') 1150 continue call icopy (4, kokseg,1, kfdseg(4*(nfdseg+kseg)-3),1) i1kseg = kmp 1200 continue nfdseg = nfdseg + kseg 2000 continue nfsga(nedgt+1) = nfdseg return ! ! ! 6001 format (' subject edge segment: nw',i4,' side',i2, & & ' 1-st point',i4,' last point',i4 & & ,/, ' object edge segment: nw',i4,' side',i2, & & ' 1-st point',i4,' last point',i4 & & ) 6002 format (' *** multiple abumtent *** ' & & ,2x,' nw',i3,', edge ',i1,' may abut to' & & ,' nw',i3,', edge ',i1,' along more than one abutment') END subroutine abtfsd !! subroutine abtidn (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,jsympa & ! Removed by Martin Hegedus, 4/21/09 !! & ,mapn2f,mapb2n,mapn2b,mapb2f,keyb2f & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtidn subroutine abtidn (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,jsympa,mapn2f,mapb2n,mapn2b,mapb2f,keyb2f & ! Added by Martin Hegedus, 4/21/09 & ,zsv & & ,kpteqc,kmpeqc,wgteqc,nefgsa,kptefg & & ,kempec,kptemp,kemkey,tauemp,nmpaia & & ) implicit double precision (a-h,o-z) ! identify abutments and abutment intersections dimension z(3, 1:*), nm(1:*), nn(1:*), ntd(1:*), nza(151) & & , comprs(3) dimension zsv(3, 1:*) ! === dimension kpteqc(mxempt), kmpeqc(mxempt), wgteqc(mxempt) dimension kpteqc(1:*), kmpeqc(1:*), wgteqc(1:*) ! === dimension nefgsa(4*mxnett+1), kptefg(4*mxempt) dimension nefgsa(1:*), kptefg(1:*) ! === dimension kempec(mxempt), kptemp(mxempt), kemkey(mxempt) ! ===x , tauemp(mxempt), nmpaia(mxempt+1) dimension kempec(*), kptemp(*), kemkey(*), tauemp(*), nmpaia(*) ! ! ! ! declare local arrays ! ! !call skrch1 common /skrch1/ w(9000000) !end skrch1 !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt dimension kabut(4*mxiabt), labut(4*mxiabt), t1abut(mxiabt) & & , t2abut(mxiabt), klabut(4*2*mxiabt) dimension kkvlst(2,mxempt), wtvlst(2,mxempt) dimension nezaba(mxnabt+1), keqvel(2,mxfdsg) parameter (mxndep=500) parameter (mxldep=1000) parameter (mxcns=2000) dimension iptdep(mxndep), wgtdep(mxldep), infdep(mxldep) dimension nga(mxnett+1), mapn2f(2*maxcp), mapb2n(2*maxcp) & & , mapn2b(2*maxcp), mapb2f(2*maxcp), keyb2f(2*maxcp) & & , iptcns(mxcns+1), ibxcns(3*mxcns), wgtcns(3*mxcns) ! nga should probably go in /index/ dimension kposab(mxnabt), nedaba(mxnabt+1), mtchab(4,mxnabt) dimension iedgtp(4*mxnett), icrntp(4*mxnett), smach(4*mxnett) & & , sdnst(4*mxnett) & & , ztedg(6,4*mxnett), dstedg(4*mxnett) & & , nfsga(4*mxnett+1), nedmpa(4*mxnett+1) dimension kfdpnt(mxfdsg), kfdkey(mxfdsg), kfdsgn(mxfdsg) & & , kfdseg(4*mxfdsg) dimension nbraia(mxnai), ifsgai(2,mxfdsg), mcmpai(mxfdsg) dimension kfds(4*mxeiab), ksgn(mxeiab) ! ! local variables for original mammoth version ! ! ! *** dimension dz(3), enint(3), z1p(3), z2p(3), zm1(3), zm2(3) ! *** dimension iedmpx(2) ! *** dimension zpt(3,20), zavg(3), kfds(20), ksgn(20), iwfds(20) ! *** dimension zcom(3,201), dzcom(201), dzsum(201), taulst(201) ! ***x , keclst(201), kecedg(201), keytau(201) ! *** dimension ipqbr(2,40), cbr(40), kbr(40), lbr(40), nwkbr(40) ! ***x , nodbr(40), kfsgpk(40), ndmbr(40) ! *** dimension ipnod(80), lnod(80), knod(80) ! *** dimension encrn(3), emcrn(3), ux(3), vx(3) ! *** dimension labten(21) ! *** logical epsequ, badedg, abut, connec ! ! ! !ca abtprm ! /abtprm/ ! nabt number of abutments ! nabint number of abutment intersections ! nfdseg number of fundamental segments ! nedmp number of edge mesh points ! nmpec number of edge mesh point equivalence classes ! npteqc number of entries in [kmpeqc,wgteqc] d.s. describing ! dependent edge meshpoints, pointed into by negative ! values in kpteqc(impec) ! nvpnf number of v-parms, naive ! nvpbsc number of v-parms, basic ! nvpfin number of v-parms, final ! nvpcns number of v-parm constraints ! nvpibx number of v-parm ibasic entries in ibxcns ! nvlst number of entries in [kkvlst,wtvlst] d.s. ! common /abtprm/ nabt, nabint, nfdseg, nedmp, npteqc & & , nvpnf, nvpbsc, nvpfin, nvpcns, nvpibx & & , nvlst !end abtprm !call cp2aul ! /cp2aul/ = index for abutments having a cp(2nd order) ! matching condition. common /cp2aul/ ncp2ab, idcp2(3,50) & & , ablcp2(50), keycp2(50) integer ablcp2 !end cp2aul !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser !call abtprt common /abtprt/ igeoin, igeout, nwxref, nwprop, iabutd & & , iabsum !end abtprt !call symcnd ! /symcnd/ common /symcnd/ isympa !end symcnd !call lfqprm ! /lfqprm/ ! major flags for controlling the low-frequency features ! mlofrq = 0, normal run ! = 1, ph/0 run, low frequency theory ! = 2, (d/dt) ph/0 run, low frequency theory ! = 3, ph/1,h run, low frequency theory ! adjgeo = .true., include ztz corrections in geometry ! (full low frequency theory) ! = .false., do not include ztz corrections in geometry, ! (linearized low frequency theory) ! adjwak = .true., adjust wake zeta's, fixing trailing edges ! .false., accept user's values of wake zeta's as given ! inczex = .true., include zeta terms for nropt =4,9 (exhaust bc's) ! = .false., exclude zeta terms for nropt =4,9 ! lfqind controls the type of processing done and implies that ! mlofrq will take on certain values ! lfqind = 0, standard a502 run; mlofrq = 0 [bconcl] ! = 1, low frequency theory with current geometry ! mlofrq = 1 [bconcl]; 2,3 [lfqg23] ! = 2, low frequency theory with linearized solution ! mlofrq = 0 [bconcl]; 1,2,3 [lfq123] common /lfqprm/ mlofrq, adjgeo, adjwak, inczex & & , lfqind logical adjgeo, adjwak, inczex ! !end lfqprm !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt logical tmark !call lndblx ! /lndblx/ common /lndblx/ genwak(3,mxnett), slndbl(mxnett) & & , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett) !end lndblx !ca locinf ! /locinf/ common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i double precision rlocdm !end locinf !ca trfdat ! /trfdat/ ! /trfdat/ contains the list of wake networks with free trailing ! edges (edge 3). these networks are determined during ! the abutment analysis and used during the trefftz plane ! analysis performed by output ! nwtrf = the number of wake networks in the trefftz ! plane analysis ! nwltrf = the list of wake networks for trefftz plane analysis common /trfdat/ nwtrf, nwltrf(150) !end trfdat common /abtcom/ t1abut, t2abut, wtvlst, wgtdep, wgtcns & & , smach, sdnst, ztedg, dstedg & & , nza, kabut, labut, klabut, kkvlst, nezaba, keqvel & & , iptdep, infdep, iptcns, ibxcns, kposab, nedaba & & , mtchab, iedgtp, icrntp, nfsga, nedmpa, kfdpnt & & , kfdkey, kfdsgn, kfdseg, nbraia, ifsgai, mcmpai & & , kfds, ksgn dimension indsym(4) data indsym / 3, 2, 0, 1 / ! ierabt = 0 isympa = jsympa tmark = iextrp.ne.0 ncns = 0 nnaive = 0 nbasic = 0 nfinal = 0 nvpcns = 0 iptr = 0 ! define cumulative mesh point counts nza(1) = 0 if ( nnett .gt. mxnett ) call abtend('abtidn: too many networks') do 5 k = 1,nnett nza(k+1) = nza(k) + nm(k)*nn(k) 5 continue nzmesh = nza(nnett+1) if ( nzmesh.gt.maxpts ) call a502er ('abtidn' & & ,' number of mesh points exceeds the program limit') call xfera (z,zsv,3*nzmesh) ! characterize edges call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====setup',ta !! call abtecd (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtecd (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,iedgtp,sdnst,smach,ztedg,dstedg, icrntp & & ) nedgt = 4*nnett if ( nwprop .eq. 0 ) go to 20 write (6,9101) (k, (iedgtp(4*(k-1)+i),i=1,4), k=1,nnett) write (6,9102) (k, (sdnst( 4*(k-1)+i ),i=1,4), k=1,nnett) write (6,9103) (k, (smach( 4*(k-1)+i ),i=1,4), k=1,nnett) write (6,9104) (k, (icrntp(4*(k-1)+i),i=1,4), k=1,nnett) call outvci ('nm',nnett,nm) call outvci ('nn',nnett,nn) call outvci ('nza',nnett+1,nza) 20 continue if ( igeoin .eq. 0 ) go to 430 call bmark ('geobfadj') write (6,9105) l = 0 do 420 k = 1,nnett write (6,6070) k, iduser(k) 6070 format (2x,'network index =',i5,' identifier = ',a) if ( iabutd .eq. 0 ) go to 410 call outvec ('distances',4, dstedg( 4*k-3 ) ) call outmat ('avg pts ',6,3,4,ztedg(1,4*k-3) ) call outmat ('del(z) ',6,3,4,ztedg(4,4*k-3) ) 410 continue write (6,9109) call outmvc (' ',nm(k),nm(k),nn(k),z(1,l+1)) l = l + nm(k)*nn(k) write (6,9301) 420 continue call emark ('geobfadj') 430 continue ! perform the definition of the ! fundamental edge segments call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtecd',ta !! call abtfsd (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtfsd (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,nseglo,kabut,labut,t1abut,t2abut,klabut & & ,ztedg,dstedg & & ,iedgtp,nfsga,nfdseg,kfdseg & & ) if ( iabutd .eq. 0 ) go to 510 call outpkv ('kabut',nseglo,kabut) call outpkv ('labut',nseglo,labut) call outvci ('nfsga',nedgt+1,nfsga) call outpkv ('kfdseg',nfdseg,kfdseg) 510 continue ! fundamental segments defined in ! kfdseg(1:nfdseg) ! ! given these fundamental segments, ! define the abutments as equivalence ! classes of fundamental edge segments call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtfsd',ta !! call abtdab (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtdab (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,nseglo,kabut,labut, nfsga & & ,nfdseg,kfdseg,kfdkey,kfdpnt,kfdsgn, nabt,nedaba& & ) if ( iabutd .eq. 0 ) go to 610 call outvci ('nedaba',nabt+1,nedaba) call outvci ('kfdkey',nfdseg,kfdkey) call outvci ('kfdpnt',nfdseg,kfdpnt) 610 continue ! for each abutment, define a plane of ! symmetry indicator for that abutment. call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtdab',ta !! call abtsym (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtsym (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,nfdseg,kfdseg,kfdsgn,kfdkey, kposab & & ,nabt,nedaba & & ) call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtsym',ta if ( iabutd .eq. 0 ) go to 710 call outvci ('kfdsgn',nfdseg,kfdsgn) call outvci ('kposab',nabt,kposab) 710 continue ! count edge mesh points and establish ! the edge mesh point pointer array nedmp = 0 nefgst = 0 nvlst = 0 mxvlst = mxempt do 3800 kedg = 1,nedgt nedmpa(kedg) = nedmp nefgsa(kedg) = nefgst call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) nedmp = nedmp + knedg - 1 ! fine-grid x [u,l] nefgst = nefgst + (2*knedg-2)*2 3800 continue nedmpa(nedgt+1) = nedmp nefgsa(nedgt+1) = nefgst if ( iabutd .eq. 0 ) go to 3820 call outvci ('nedmpa',nedgt+1,nedmpa) 3820 continue if ( nedmp .gt. mxempt ) call abtend & & ('abtidn: edge mesh point buffer exceeded ') ! define pointers for mesh points do 3850 iedmp = 1,nedmp kptemp(iedmp) = iedmp 3850 continue if ( nefgst .gt. 4*mxempt ) then call a502ms ('abtidn','overflow of kptefg f.g. ptr array') endif do 3860 i = 1,nefgst kptefg(i) = i 3860 continue ! include effect of equivalence ! relations due to collapsed edges do 3900 kedg = 1,nedgt if ( iedgtp(kedg).ne.1 ) go to 3900 call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) call edgmpi (kedg,1,nedmpa, iedmp1) do 3870 imp = 2,knedg call edgmpi (kedg,imp,nedmpa, iedmp2) call mpteqc (kptemp,nedmp, iedmp1,iedmp2) iedmp1 = iedmp2 3870 continue ! enter equivalence relations for a ! collapsed edge into the fine grid ! (surface) pointer array, kptefg do 3885 iul = 1,2 call edgfgi (iul,kedg,1, nm,nn,nefgsa, kkmp1) knfg = 2*knedg - 1 do 3880 ifg = 2,knfg call edgfgi (iul,kedg,ifg, nm,nn,nefgsa, kkmp2) call mpteqc (kptefg,nefgst, kkmp1,kkmp2) 3880 continue 3885 continue 3900 continue ! now include the effect of all ! abutments into the edge mesh point ! pointer array ! for each abutment, identify equivalen ! classes of points do 4000 iabt = 1,nabt iedg1 = nedaba(iabt) + 1 iedg2 = nedaba(iabt+1) do 3950 iedg = iedg1,iedg2 ie = iedg - iedg1 + 1 ifsg = kfdkey(iedg) kfds(4*ie-3)= kfdseg(4*ifsg-3) kfds(4*ie-2)= kfdseg(4*ifsg-2) kfds(4*ie-1)= kfdseg(4*ifsg-1) kfds(4*ie )= kfdseg(4*ifsg ) ksgn(ie)= kfdsgn(ifsg) 3950 continue ne = nedaba(iabt+1) - nedaba(iabt) ! # call outlin ("abut no.",1,iabt) ! # call outpkv ("kfds",ne,kfds) ! # call outvec ("ksgn",ne,ksgn) call abtemp (ne,kfds,ksgn, z,nza,nm,nn,nedmpa, epsgeo & & ,kptemp,nedmp) 4000 continue if ( iabutd .eq. 0 ) go to 4100 call outvci ('kptemp',nedmp,kptemp) 4100 continue ! the pointer array kptemp(1:nedmp) ! that defines the equivalence classes ! of edge mesh points (the cycles of ! kptemp) is now defined. number ! these equivalence classes, giving ! the lowest index values to those ! equivalence classes that are also ! abutment intersections. for each ! edge mesh point, kmp, ! iabs( kempec( kmp ) ) is the index ! of its equivalence class. call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtemp',ta !! call abtdai (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtdai (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,nfdseg,kfdseg,kfdkey, nabt,nedaba & & ,nedmp,nedmpa & & ,nmpec,nabint,nmpaia,kemkey,kempec,kptemp & & ) if ( iabutd .eq. 0 ) go to 4150 call outvci ('kemkey',nedmp,kemkey) call outvci ('kempec-u',nedmp,kempec) call outvci ('nmpaia',nmpec+1,nmpaia) 4150 continue ! for each abutment, define the univers ! edge associated with that abutment an ! adjust all mesh points involved in th ! abutment up to that universal edge. ! also, define the tau values for each ! edge mesh point interior to an abutme ! relative to the abutment's universal ! abtdue also assigns edge matching con ! which are then save in mtchab(1:3,1: call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtdai',ta call setcor ('abtdue') call getcor ('zpt',llzpt,3*mxnpec) !! call abtdue (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtdue (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,iedgtp,sdnst, nfdseg,kfdseg,kfdkey,kfdsgn & & ,nabt,nedaba,kposab,mtchab & & ,nedmp,nedmpa,kempec,kptemp,tauemp & & ,nefgst,nefgsa,kptefg & & ,mxvlst,nvlst,kkvlst,wtvlst & & ,neztot,nezaba,keqvel,w(llzpt) & & ,nwtrf,nwltrf & & ) call frecor ('abtdue') if ( iabutd .eq. 0 ) go to 4200 call outmti ('mtchab',4,4,nabt,mtchab) 4200 continue call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtdue',ta ! check that all edge mesh points have ! been processed. nsrchk = 0 do 5050 iedmp = 1,nedmp ksav = kempec(iedmp) kempec(iedmp) = iabs( ksav ) if ( ksav.lt.0 ) go to 5050 call ibsrch (nedmpa, nedgt+1, iedmp, kedg) if ( iedmp.ge.nedmpa(kedg)+1 .and. iedmp.le.nedmpa(kedg+1) ) & & go to 5020 ! error condition : iedmp not found write (6,'(1x,a10,1x, 3i12)') & & 'kedg,iedmp',kedg,iedmp,ksav if ( nsrchk.eq.0 ) call outvci ('nedmpa',nedgt+1,nedmpa) nsrchk = 1 call abtmsg ('abtidn/5050 loop. ibsrch error') go to 5050 ! 5020 continue call mnmod (kedg,4,ksd,knet) if ( ksav.gt.0 .and. ntd(knet).eq.0 ) go to 5050 write (6,'(1x,a10,1x, 2i12)') & & 'kempec err',iedmp,ksav ierabt = ierabt + 1 5050 continue ! print out tau values upon request if ( iabutd .eq. 0 ) go to 5070 call outvec ('tauemp',nedmp,tauemp) 5070 continue ! if ( igeout .eq. 0 ) go to 5110 call bmark ('geoafadj') write (6,9106) do 5100 k = 1,nnett write (6,6070) k, iduser(k) write (6,9110) call outmvc (' ',nm(k),nm(k),nn(k),z(1,nza(k)+1)) write (6,9301) 5100 continue call emark ('geoafadj') 5110 continue ! generate the (nbraia,ifsgai) data str ! defining the abutment intersections ! together with the array mcmpai defi ! the matching conditions for the corne ! points involved in each abutment ! intersection. ! here also, a description of each abut ! intersection is printed if ( iabsum.ge.2 ) call bmark ('abut int') !! call abtaio (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtaio (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,iedgtp,icrntp, nedmpa, kposab & & ,nfsga, nfdseg,kfdseg,kfdkey,kfdsgn & & ,nabint,nmpaia,kemkey,nbraia,ifsgai,mcmpai & & ) if ( iabsum.ge.2 ) call emark ('abut int') call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtaio',ta if ( iabutd .eq. 0 ) go to 5200 call outvci ('nbraia',nabint+1,nbraia) call outmti ('ifsgai',2,2,nbraia(nabint+1),ifsgai) call outvci ('mcmpai',nbraia(nabint+1),mcmpai) 5200 continue ! print a full description of each abut ntabo = 1 call bmark ('abutment') write (6,9107) do 6000 iabt = 1,nabt !! call abtabo (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtabo (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,zsv & & ,iedgtp, nedmpa, kposab & & ,nfdseg,kfdseg,kfdkey,kfdsgn & & ,iabt,nedaba,mtchab & & ,nedmp,kempec,tauemp,kptemp,nbraia,ifsgai & & ) 6000 continue call emark ('abutment') 6010 continue ! print a description of the abutments ! and abutment intersections of each ! network. if ( nwxref .eq. 0 ) go to 6060 call bmark ('abnwxref') write (6,9108) knprev = 0 ntabo = 2 do 6050 ifsg = 1,nfdseg call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) call edgmpi (kedseg,i1kseg,nedmpa, kmp1) impec1 = iabs( kempec( kmp1 ) ) call edgmpi (kedseg,i2kseg,nedmpa, kmp2) impec2 = iabs( kempec( kmp2 ) ) kedg = kedseg call mnmod (kedg,4,ksd,knet) if ( knet .eq. knprev ) go to 6020 ! this is the first abutment of a new ! network. print a header and describe ! the first abutment intersection. knprev = knet write (6,9201) knet 9201 format (//,'0 abutments and abutment intersections for network' & & , i4, 5x, 12( 4h / * ) ) !! call abtaip (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtaip (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,iedgtp,icrntp, nfdseg,kfdseg,kfdsgn,kposab & & ,impec1,nbraia,ifsgai,mcmpai) 6020 continue iabtx = -iabs( kfdsgn( ifsg ) ) !! call abtabo (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtabo (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,zsv & & , iedgtp, nedmpa, kposab & & ,nfdseg,kfdseg,kfdkey,kfdsgn & & ,iabtx,nedaba,mtchab & & ,nedmp,kempec,tauemp,kptemp,nbraia,ifsgai & & ) !! call abtaip (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 call abtaip (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym,nza & ! Added by Martin Hegedus, 4/21/09 & ,iedgtp,icrntp, nfdseg,kfdseg,kfdsgn,kposab & & ,impec2,nbraia,ifsgai,mcmpai) 6050 continue call emark ('abnwxref') 6060 continue call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtprt',ta ! do a scan of the geometry to determin ! which mesh points have moved. call abtdzo (nnett,nm,nn,z,epsgeo,nza,zsv) call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtdzo',ta ! do a scan to determine motion of ! mean plane panel normals. call abtdnc (nnett,nm,nn,z,zsv) call CPU_TIME (ta) if ( tmark ) write (6,'(1x,a10,1x, f12.6)') & & '====abtdnc',ta naicp = nbraia(nabint+1) write (6,9111) do 6030 k = 1,nnett if ( idsvfw(k).eq.0 ) goto 6030 iabt = iabs(idsvfw(k)) write (6,9112) k, iduser(k), iabt 6030 continue write (6,9301) ! sort the trefftz nw list, squeeze ! out duplicates, apply user overides, ! and print a summary call shlsrt (nwtrf,nwltrf) kwtrf = 0 nwlprv = -1 call outvci ('nwltrf/in',nwtrf,nwltrf) do 6080 kk = 1,nwtrf if ( nwltrf(kk).eq.nwlprv ) goto 6080 kwtrf = kwtrf + 1 nwltrf(kwtrf) = nwltrf(kk) nwlprv = nwltrf(kk) 6080 continue nwtrf = kwtrf write (6,9113) call outvci ('nwltrf/out',nwtrf,nwltrf) do 6090 kk = 1,nwtrf knet = nwltrf(kk) write (6,9114) knet, iduser(knet) 6090 continue write (6,9301) ! iptrmx = mxempt npteqc = iptr nvpnf = nnaive nvpbsc = nbasic nvpfin = nfinal nvpcns = ncns ! save the abutment tables call ixtrns (1,nbraia,nmpec+1) call ixtrns (2,ifsgai,2*naicp) call ixtrns (3,mcmpai,naicp) ! call ixtrns (4,kfdpnt,nfdseg) call ixtrns (5,kfdkey,nfdseg) call ixtrns (6,kfdsgn,nfdseg) call ixtrns (7,kfdseg,4*nfdseg) ! call ixtrns (8,nfsga,4*nnett+1) call ixtrns (9,nedmpa,4*nnett+1) ! call ixtrns (10,kempec,nedmp) call ixtrns (11,kptemp,nedmp) call ixtrns (12,kemkey,nedmp) call ixtrns (13,tauemp,kklr2i*nedmp) call ixtrns (14,nmpaia,nmpec+1) ! call ixtrns (15,kposab,nabt) call ixtrns (16,nedaba,nabt+1) call ixtrns (17,mtchab,4*nabt) call ixtrns (18,iedgtp,4*nnett) call ixtrns (19,icrntp,4*nnett) call ixtrns (20,ncp2ab,3*ncp2ab+1) call ixtrns (61,nefgsa,4*nnett+1) call ixtrns (62,kptefg,nefgst) call ixtrns (63,kkvlst,2*nvlst) call ixtrns (64,wtvlst,2*kklr2i*nvlst) call ixtrns (65,nezaba,nabt+1) call ixtrns (66,keqvel,2*neztot) call ixtrns (67,kpteqc,nedmp) ! check for fatal errors having occurre if ( ierabt.gt.0 ) call a502ms ('abtidn' & & ,' errors in abmt identification') return 9104 format (' corner types',/,(1x,i4,1h.,4i5)) 9103 format (' edge smach parameters',/,(1x,i4,1h.,4f12.6) ) 9102 format (' downstream parameters',/,(1x,i4,1h.,4f12.6)) 9101 format (' edge types',/, (1x,i4,1h., 4i5) ) 9105 format (1h1,10x,'***** geometry before liberalized geometry adjus& &tment (controlled by $eat) *****') 9106 format (1h1,10x,'***** geometry after liberalized geometry adjust& &ment (controlled by $eat) *****') 9107 format (1h1,34x,'abutment summary',//) 9108 format (1h1,5x,'network by network abutment cross reference') 9109 format (' row col',14x,'nrow ncol',5x & & ,'------- columns -------> ' & & ,12x,'before adjustment of edge points by $eat') 9110 format (' row col',14x,'nrow ncol',5x & & ,'------- columns -------> ' & & ,12x,' after adjustment of edge points by $eat') 9111 format ( // & & ' ===== summary of free wake trailing edges ===== ' & & ,/, ' (semi-infinite filaments to be attached) ' & & ,//, & & ' nw', 3x, 'network-id',3x, 'abmt' & & ,/, ' ---', 3x, '----------',3x, '----' & & ) 9112 format (2x,i3,3x,a10,3x,i4) 9113 format ( // & & ' ===== summary of networks for trefftz plane analysis =====' & & ,//, & & ' nw', 3x, 'network-id' & & ,/,' ---', 3x, '----------' & & ) 9114 format (2x,i3,3x,a10) 9301 format (1h ) END subroutine abtidn ! **deck abtint subroutine abtint (isym,labt & & ,nseg,ipqseg,cseg,kseg,lseg,ndmseg,nwkseg & & ,nnod,ipnod,lnod,knod & & ,nodseg,nodpos,nfail & & ) implicit double precision (a-h,o-z) ! generate matching condition assignments for the control points ! in an abutment intersection. !. !. integer ipqseg(2,nseg), kseg(nseg), lseg(nseg), ndmseg(nseg) integer nwkseg(nseg) dimension cseg(nseg) integer ipnod(nnod), lnod(nnod), knod(nnod) integer nodseg(nseg) dimension amatch(40,40) ! ! nsegmx integer pqseg(2,100), key(100), nbtra(101), point(200) integer pq(100,2), p(100), q(100), brnm(100), kb(100) equivalence (pq,p), (pq(1,2),q) dimension w(100) ! max( nsegmx, nnodmx) integer netwk(100) ! nnodmx integer mnod(100), head(100), count(100), pnod(100) ! logical lsym(2), grnded, gdasgn integer pabt ! integer prclas(3,3) data prclas / 5,3,1, 2,4,7, 6,0,0 / data nsegmx / 100 /, nnodmx / 100 / data infil /5/, iutfil/6/ ! ! ! ! check input dimensions ier = 1 if ( nseg.gt.nsegmx .or. nnod.gt.nnodmx ) go to 6000 ! initialize iwarn = 0 ! *************** ! decode (1,9981, w(74b-loc(w)) ) ch !9981 format (a1) ! if ( ch .eq. 1hx ) iwarn = -1 ! iwarn = -1 ! *************** call ifera (ipqseg,pqseg,2*nseg) call ifera (ipnod,pnod,nnod) call jzero (knod,nnod) call jzero (mnod,nnod) call zero (amatch,nseg**2) call jzero (nodseg,nseg) nodpos = 0 nfail = 0 if ( nseg.le.0 ) return ! put local node numbers into pq ier = 2 nnodx = nnod do 20 iseg = 1,nseg do 20 i = 1,2 do 10 inod = 1,nnod if ( pnod(inod) .ne. pqseg(i,iseg) ) go to 10 if ( ndmseg(iseg).lt.3 .and. ndmseg(iseg).ne.i ) go to 5 nnodx = nnodx + 1 if ( nnodx .gt. nnodmx ) go to 6000 pnod(nnodx) = pqseg(i,iseg) mnod(nnodx) = -1 pq(iseg,i) = nnodx go to 20 5 continue pq(iseg,i) = inod go to 20 10 continue go to 6000 20 continue ! ! put local node numbers into pqseg do 30 iseg = 1,nseg do 30 i = 1,2 pqseg(i,iseg) = pq(iseg,i) 30 continue ! set flags for active planes of symmet lsym(1) = ( isym.eq.1 .or. isym.eq.4 ) .and. & & ( labt.eq.1 .or. labt.eq.3 ) lsym(2) = ( isym.eq.1 .or. isym.eq.2 ) .and. & & ( labt.eq.2 .or. labt.eq.3 ) ! construct graph of all branches/ ! corner points that have a doublet ! distribution and do not lie in an ! active plane of symmetry. ! also, set nodseg for control points ! lying in an active p-o-s nb = 0 do 100 iseg = 1,nseg nodseg(iseg) = 0 if ( kseg(iseg) .le. 2 ) go to 100 nodseg(iseg) = -1 if ( lsym(1) .and. iabs(lseg(iseg)).eq.1 ) go to 100 if ( lsym(2) .and. iabs(lseg(iseg)).eq.2 ) go to 100 nodseg(iseg) = 0 nb = nb + 1 p(nb) = pqseg(1,iseg) q(nb) = pqseg(2,iseg) brnm(nb)= iseg w(nb) = kseg(iseg) if ( kseg(iseg) .eq. 4 ) w(nb) = w(nb) + .5d0*cseg(iseg) kb(nb) = 0 if ( kseg(iseg) .eq. 5 ) kb(nb) = 1 if ( kseg(iseg) .eq. 2 ) kb(nb) = -1 ! if ( kseg(iseg) .lt. 3 ) go to 100 if ( p(nb).le.nnod ) knod(p(nb)) = knod(p(nb)) + 1 if ( q(nb).le.nnod ) knod(q(nb)) = knod(q(nb)) + 1 100 continue if ( nb .le. 0 ) go to 1000 ! set mnod to prevent assignment of ! matching conditions associated with ! with abutments lying in active planes ! of symmetry nreqd = 0 nmtchd = 0 do 200 inod = 1,nnod if ( knod(inod) .eq. 0 ) mnod(inod) = 1 if ( lsym(1) .and. ( lnod(inod).eq.1 .or. lnod(inod).eq.3 ) ) & & mnod(inod) = -1 if ( lsym(2) .and. ( lnod(inod).eq.2 .or. lnod(inod).eq.3 ) ) & & mnod(inod) = -1 if ( mnod(inod) .ge. 0 ) nreqd = nreqd + 1 if ( mnod(inod) .gt. 0 ) nmtchd= nmtchd + 1 200 continue nreqd = min ( nnod-1, nreqd) ! scan the tree and determine spanning ! trees for each disjoint subgraph ier = 3 call gphscn(nb,nnodx,p,q,brnm,w,kb,netwk,ntr,nbtra,key,iprnt,ierr) if ( ierr .ne. 0 ) go to 6000 if ( labt.eq.0 .and. ntr.gt.1 ) iwarn = max (1,iwarn) ! check for matching wake branches ! missing from the spanning tree. l1 = nbtra(ntr+1) + 1 l2 = nb if ( l1 .gt. l2 ) go to 211 do 210 l = l1,l2 if ( kb(l) .eq. 1 ) iwarn = max (20000,iwarn) 210 continue 211 continue ! defoliate subgraphs and perform ! assignment of nodes/abutments to ! branches/corner points if ( ntr.le.0 ) go to 510 do 500 itr = 1,ntr nbtr = nbtra(itr+1) - nbtra(itr) lpq = nbtra(itr) + 1 ier = 4 call gphplk(nbtr,nnodx,mnod,p(lpq),q(lpq),brnm(lpq),w(lpq), & & kb(lpq),head,point,count,key,iprnt,ierr) if ( ierr .lt. 0 ) go to 6000 l1 = nbtra(itr) + 1 l2 = nbtra(itr+1) igrd = q(l2) ! check for bad assignments ngrasn = 0 grnded = mnod(igrd) .ne. 0 gdasgn = .true. do 220 l = l1,l2 if ( mnod(p(l)) .lt. 0 ) ngrasn = ngrasn + 1 ityp = prclas( kb(l)+2, mnod(p(l))+2 ) if ( ityp .gt. 2 ) go to 220 gdasgn = .false. iwarn = max (3,iwarn) write (iutfil,6800) itr, ityp, igrd 220 continue if ( ngrasn.gt.0 .and. .not.grnded ) gdasgn = .false. if ( gdasgn ) go to 280 ! assignment scheme did not work. ! try all possible ground nodes. iwarn = max (3,iwarn) write (iutfil,7001) itr, nnodx do 250 igrdx = 1,nnodx do 230 l = l1,l2 if ( p(l).eq.igrdx .or. q(l).eq.igrdx ) go to 235 230 continue go to 250 ! 235 continue call gpluck(nbtr,nnodx,mnod,igrdx,p(l1),q(l1),brnm(l1), & & w(l1),kb(l1),head,point,count,key,iprnt,ierr) write (iutfil,7002) igrdx, ierr if ( ierr .lt. 0 ) go to 6000 if ( ierr .ne. 0 ) go to 250 igrd = igrdx go to 260 250 continue call gpluck(nbtr,nnodx,mnod,igrd,p(l1),q(l1),brnm(l1),w(l1), & & kb(l1),head,point,count,key,iprnt,ierr) if ( ierr .lt. 0 ) go to 6000 iwarn = max (10000,iwarn) 260 continue ! 280 continue ier = 5 do 300 l = l1,l2 iseg = brnm(l) if ( mnod(p(l)).ne.0 .or. p(l).eq.igrd ) go to 300 if ( nodseg(iseg) .ne. 0 ) go to 6000 nodseg(iseg) = p(l) nodpos = nodpos + 1 300 continue 500 continue 510 continue ier = 6 nmtchd = nmtchd + nodpos if ( nmtchd .gt. nreqd ) iwarn = max ( 4, iwarn) if ( nmtchd .lt. nreqd ) go to 6000 ! define matching coefficients do 600 iseg = 1,nseg do 600 jseg = 1,nseg amatch(iseg,jseg) = 0.d0 600 continue do 800 jseg = 1,nseg if ( nodseg(jseg) .eq. 0 ) go to 800 pabt = nodseg(jseg) do 700 iseg = 1,nseg do 700 i = 1,2 if ( pqseg(i,iseg) .ne. pabt ) go to 700 amatch(iseg,jseg) = amatch(iseg,jseg) + (-1)**i 700 continue 800 continue ! exit 1000 continue ier = 0 if ( ntr.eq.0 ) iwarn = 0 if ( iwarn .eq. 0 ) return ! error exit 6000 continue write (iutfil,6050) 6050 format ('1 abtint execution summary (see above for possible mess& &ages)' ) write (iutfil,6100) ier, iwarn, nb, ntr, itr, igrd, igrdx nfail = ier + ( 10000 * (iwarn/10000) ) 6100 format (15h0******** error,/ & & ,11x,52herror in abutment intersection processing (abtint). & & ,/,11x,'ier =',i6,' iwarn =',i6,' nb =',i3,' ntr =',i3 & & ,' itr =',i3,' igrd =',i4,' igrdx =',i4 & & ,/,11x,30hdiagnostic information follows) write (iutfil,6115) nreqd, nmtchd, nodpos, ngrasn 6115 format ('0 nreqd =',i3,' nmtchd =',i3,' nodpos =',i3 & & ,' ngrasn =',i3) write (iutfil,6200) labt, isym, nnod, nnodx 6200 format (11x,'plane-of-symmetry incidence =',i5 & & ,3i5 & & ,//,16x,' pnod lnod knod mnod') write (iutfil,6300) (i,pnod(i),lnod(i),knod(i),mnod(i),i=1,nnodx) 6300 format (11x,i3,1h.,4i8) write (iutfil,6400) 6400 format (//,16x,' pseg qseg cseg kseg lseg ndmseg & &nwkseg nodseg') write (iutfil,6500) (i,pqseg(1,i),pqseg(2,i),cseg(i),kseg(i) & & ,lseg(i),ndmseg(i),nwkseg(i),nodseg(i) & & ,i=1,nseg) 6500 format (11x,i3,1h.,2i8,f8.4,3i8,i10,i6) if ( nb .gt. 0 ) & & write (iutfil,6600) (i,brnm(i),p(i),q(i),kb(i),w(i),i=1,nb) 6600 format (//,16x,' brnm p q kb w' & & ,/,(11x,i3,1h.,4i8,f8.4) ) 6800 format (' **** warning (abtint) in tree ',i2,',a type ',i2,' bran& &ch was encountered in defoliation. ground node =',i3) call outvci ('ipnod',nnod,ipnod) call outmti ('ipqseg',2,2,nseg,ipqseg) call outvci ('nbtra',10,nbtra) call outmat ('amatch',40,nseg,nseg,amatch) return 7001 format ('0******** warning (abtint)',/, & & 11x,'exhaustive search for a suitable ground node started for t& &ree no.',i3,' nnodx =',i3) 7002 format (11x,'node =',i4,' ierr =',i5) END subroutine abtint ! **deck abtipc subroutine abtipc (iabt,icp2ab,npnmtc) implicit double precision (a-h,o-z) ! ! check that the ipot values for the networks involved in a ! kutta condition will not cause errors in aical. this is ! done by applying the same error checks as those implemented ! in aical to data provided for abutment iabt. the main ! thing that is checked is that the appropriate stagnation ! condtions are applied on the various networks of a nonlinear ! c/p matching abutment so that when we get into sinver/fhybrj, ! the pressure jump residuals can be correctly evaluated. ! ! iabt i int the index of the abutment to be checked ! icp2ab i int the position in the idcp2 data structure ! containing info about abutment iabt. ! npnmtc i int the number panels involved in a matching ! condition along the abutment ! ! idcp2(1:3,icp2ab) /cp2aul/ ! (1) abutment number for pos'n icp2ab in idcp2 ! (2) upper surface designator ! (3) lower surface designator ! surface designators have the form: ! (+-1) ( ksd + 4*(knet-1) ) ! ! michael epton, 30 november 1988 ! ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call cp2aul ! /cp2aul/ = index for abutments having a cp(2nd order) ! matching condition. common /cp2aul/ ncp2ab, idcp2(3,50) & & , ablcp2(50), keycp2(50) integer ablcp2 !end cp2aul !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp ! dimension rul(2), isgnul(2), ipotul(2), ipotx(2) ! ! ! iptabt = -2 iermsg = 0 rul(1) = 1.d0 rul(2) = 1.d0 ! define iptabt and perform some error do 2000 iul = 1,2 kedgsg = idcp2(iul+1,icp2ab) isgnsf = isign(1,kedgsg) kedg = iabs( kedgsg ) knet = (kedg+3)/4 indsf = (3-isgnsf)/2 kmatsf = matnet(indsf,knet) rul(iul)= rcnmat(kmatsf) ksd = kedg - 4*(knet-1) ipotnw = ipot(knet) ipotx(iul) = ipotnw isgnul(iul) = isgnsf if ( ipotnw.eq.0 ) goto 1800 ! ipotnw # 0, 2 nw case if ( mod(iabs(ipotnw),2) .eq. 1 ) & & ipotnw = ipotnw + isign( 1, ipotnw) ! if ( isgnsf*ipotnw .le. 0 ) then write (6,9001) iabt,knet,isgnsf,ipot(knet) iermsg = iermsg + 1 endif ! goto 1900 ! ipotnw = 0, 1 nw case 1800 continue ! if ( npnmtc.gt.2 ) then write (6,9002) iabt,knet,npnmtc iermsg = iermsg + 1 endif ! goto 1900 ! 1900 continue ipotul(iul) = ipotnw 2000 continue ! if ( iabs(ipotul(1)) .ne. iabs(ipotul(2)) ) then write (6,9003) iabt,ipotx(1),ipotx(2) iermsg = iermsg + 1 endif ! iptabt = iabs(ipotul(1)) ! if ( iptabt.eq.0 .and. npnmtc.ne.2 ) then write (6,9004) iabt, npnmtc iermsg = iermsg + 1 endif ! ! if ( iptabt.eq.2 .and. npnmtc.ne.3 ) then write( 6,9005) iabt,npnmtc iermsg = iermsg + 1 endif ! ! if ( iptabt.eq.4 .and. npnmtc.ne.3 ) then iermsg = iermsg + 1 write (6,9006) iabt,npnmtc endif ! ravg = .5d0*( rul(1) + rul(2) ) delr = rul(1) - rul(2) if ( iermsg.ne.0 ) call abtmsg ('ipot errors detected. see above') return ! 9001 format(' abutment #',i3,' nw:',i4,' wetted surface (+1=u,-1=l):'& & ,i3,' ipot:',i3,' is not consistent') 9002 format(' abutment #',i3,' nw:',i4,' number of edges =',i3 & & ,' exceeds the limit (2) for an ipot=0 network/kutta condition') 9003 format(' abutment #',i3,' nonwake ipot values:',2i4,' imply' & &,' different types of stagnation ') 9004 format(' abutment #',i3,' with no stagnation on the nonwake ' & &,'network has ',i2,' nw edges (value should be 2)' ) 9005 format(' abutment #',i3,' with pert. stagnation on the nonwake ' & &,'networks has ',i2,' nw edges (value should be 3)' ) 9006 format(' abutment #',i3,' with total stagnation on the nonwake ' & &,'networks has ',i2,' nw edges (value should be 3)' ) END subroutine abtipc ! **deck abtjob subroutine abtjob (label,msg) implicit double precision (a-h,o-z) character*(*) label,msg write (6,1001) label,msg 1001 format ('0***** a502 terminating in module : ',a8,/,1x,a40) return END subroutine abtjob ! **deck abtmsg subroutine abtmsg (msg) implicit double precision (a-h,o-z) character*(*) msg character*50 xmsg ! print an error message from the abutment analyzer !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg ierabt = ierabt + 1 write (6,6000) msg 6000 format (' error in abutment processor ',1x,a) xmsg(1:10) = 'abtmsg ' xmsg(11:50)= msg call remarx (xmsg) return END subroutine abtmsg !! subroutine abtpos (z,epsgeo,nsymm, kpos) ! Removed by Martin Hegedus, 4/21/09 ! **deck abtpos subroutine abtpos (z,epsgeo,nisym,njsym, kpos) ! Added by Martin Hegedus, 4/21/09 implicit double precision (a-h,o-z) dimension z(3) ! determine if the point z lies near one or the other ! or both planes of symmetry kpos = 0 !! if ( nsymm.ge.1 .and. abs(z(2)).le.epsgeo ) kpos = kpos+1 ! Removed by Martin Hegedus, 4/21/09 !! if ( nsymm.ge.2 .and. abs(z(3)).le.epsgeo ) kpos = kpos+2 ! Removed by Martin Hegedus, 4/21/09 if ( nisym.ge.2 .and. abs(z(2)).le.epsgeo ) kpos = kpos+1 ! Added by Martin Hegedus, 4/21/09 if ( njsym.ge.2 .and. abs(z(3)).le.epsgeo ) kpos = kpos+2 ! Added by Martin Hegedus, 4/21/09 return END subroutine abtpos !! subroutine abtsym (nnett,nm,nn,z,ntd,comprs,epsgeo,nsymm,nza & ! Removed by Martin Hegedus, 4/21/09 !! & ,nfdseg,kfdseg,kfdsgn,kfdkey, kposab & ! Removed by Martin Hegedus, 4/21/09 ! **deck abtsym subroutine abtsym (nnett,nm,nn,z,ntd,comprs,epsgeo,nisym,njsym & ! Added by Martin Hegedus, 4/21/09 & ,nza,nfdseg,kfdseg,kfdsgn,kfdkey, kposab & ! Added by Martin Hegedus, 4/21/09 & ,nabt,nedaba & & ) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! dimension z(3,4000), nm(151), nn(151), ntd(150), nza(151) & & , comprs(3) dimension kfdseg(3200), kfdsgn(800), kfdkey(800), kposab(800) dimension nedaba(751) ! !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call abtflg ! /abtflg/ ! fatal error flag posted during abutment processing common /abtflg/ ierabt, xsrcab logical xsrcab !end abtflg dimension indsym(4) data indsym / 3, 2, 0, 1 / ! generate symmetry information for ! each abutment. also store the ! abutment index in kfdsgn along ! with the orientation. do 3700 iabt = 1,nabt iedg1 = nedaba(iabt) + 1 iedg2 = nedaba(iabt+1) kpos = 0 do 3600 iedg = iedg1,iedg2 ifsg = kfdkey(iedg) kfdsgn(ifsg) = isign( iabt, kfdsgn(ifsg) ) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kedg = kedseg call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) ipos = 3 do 3550 imp = i1kseg,i2kseg kz1 = kzedg + (imp-1)*kncedg !! call abtpos (z(1,kz1),epsgeo,nsymm, iposx) ! Removed by Martin Hegedus, 4/21/09 call abtpos (z(1,kz1),epsgeo,nisym,njsym, iposx) ! Added by Martin Hegedus, 4/21/09 ipos = iandfn( ipos, iposx) 3550 continue kpos = iorfn( kpos, ipos) 3600 continue ! kposab(iabt) = kpos ! now, check that all points lie ! on the apparent planes of symmetry do 3650 iedg = iedg1,iedg2 ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, kokseg,1) kedg = kedseg call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet) & & ,kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) do 3630 imp = i1kseg,i2kseg kz1 = kzedg + (imp-1)*kncedg !! call abtpos (z(1,kz1),epsgeo,nsymm, ipos) ! Removed by Martin Hegedus, 4/21/09 call abtpos (z(1,kz1),epsgeo,nisym,njsym, ipos) ! Added by Martin Hegedus, 4/21/09 iposx = iandfn( ipos, kpos) if ( iposx .eq. kpos ) go to 3630 ! error -- issue warning write (6,9001) iabt,knet,ksd,imp,ipos,kpos call abtmsg ('abtsym: bad abutment on p-o-s') 3630 continue 3650 continue 3700 continue return 9001 format ('0 ** warning ** plane of symmetry abutment inaccuracy. & &abutment',i4,' nw',i3,' edge',i2,' point',i3,/,' point symmetr& &y indicator =',i2,' abutment symmetry indicator =',i2) END subroutine abtsym ! **deck abvblw subroutine abvblw(p1,p2,p3,cq, intf) implicit double precision (a-h,o-z) ! ! purpose: determine whether all points lie above ! or below plane ! ! inputs: p1,p2,p3 points of triangle ! cq coefficients of plane ! ! outputs: intf flag to indicate whether intersection ! is possible ! dimension p1(3), p2(3), p3(3), cq(4) ! logical intf ! dis(pt1,pt2,pt3,cf1,cf2,cf3,cf4) = & & pt1*cf1 + pt2*cf2 + pt3*cf3 - cf4 ! ! ! initialize flags ! intf = .false. ! dis1 = dis(p1(1),p1(2),p1(3),cq(1),cq(2),cq(3),cq(4)) dis2 = dis(p2(1),p2(2),p2(3),cq(1),cq(2),cq(3),cq(4)) dis3 = dis(p3(1),p3(2),p3(3),cq(1),cq(2),cq(3),cq(4)) ! if( (dis1 .gt. 0.d0) .and. & & (dis2 .gt. 0.d0) .and. & & (dis3 .gt. 0.d0) ) go to 999 ! if( (-dis1 .gt. 0.d0) .and. & & (-dis2 .gt. 0.d0) .and. & & (-dis3 .gt. 0.d0) ) go to 999 ! intf = .true. ! 999 return END subroutine abvblw ! **deck addin2 subroutine addin2 (n,ia, iax) implicit double precision (a-h,o-z) dimension ia(n+1) ! add the entry iax into the ordered list ia(1:n) of ! unique entries. n.b.: addin2 is not very efficient ! for accumulation of long lists if ( n.le.0 ) go to 200 call ibsrch (ia,n,iax,l) if ( l.ge.n ) go to 60 ! l .lt. n, thus iax .le. ia(n) if ( iax.eq.ia(l+1) ) return lp1 = l + 1 do 50 ibk = lp1,n i = lp1 + n - ibk ia(i+1)= ia(i) 50 continue 60 continue ia(l+1) = iax n = n + 1 return ! 200 continue n = 1 ia(1) = iax return END subroutine addin2 ! **deck addpan subroutine addpan (where,ipanno,iend & & ,iother,sginfo,ips & & ,numpan,nout) implicit double precision (a-h,o-z) ! ! --------------------- purpose of routine ------------------------ ! ! this subroutine takes the list of panels that make up a ! a trace and adds a new panel to the list. if required, ! the routine will flip the head and tail of the line segment ! across this panel to connect the head of the segment to the ! tail of the trace, or the tail of the segment to the head ! of the trace. ! ! definitions: ! trace - sequence of panels on a single network that ! the cutting plane goes through and make a ! logically continuous line ! string - list of traces in a group of networks that ! the cutting plane goes through and make up a ! locigally continuous line ! end no - 1 - head of line segment ! 2 - tail of line segment ! ! formal parameters: ! ! iend integer in/out input - end of the segment to ! connect to the current string ! 1 - connect trace start to string ! 2 - connect trace end to string ! output - connected end number ! iother integer output free end of the segment after ! the segment is added to trace ! ipanno integer input panel number to add to trace ! ips vector in/out list containing the panel numbers ! in current trace ! nout integer input standard output unit ! numpan integer in/out panel counter for this string ! array vector in/out contains panel segment information ! such as the x,y,z location of ! where the segment enters and ! exits the panel ! where char. input string telling where to put new ! trace in cut ! 'new' - this is the first entry ! in a new string ! 'top' - add trace to top of str ! 'bottom' - add trace to bottom of ! string ! ! ! --------------------- formal parameter list --------------------- ! integer ips(numpan+1) dimension sginfo(21) character*(*) where ! ! --------------------- labelled common blocks -------------------- ! ! ! --------------------- local array declarations ------------------ ! logical flip ! ! --------------------- executable code --------------------------- ! flip = .false. ! ! this is a new trace ! if (where .eq. 'new') then ips(1) = ipanno numpan = 1 if (iend .eq. 2) flip = .true. ! ! add to bottom of list ! elseif (where .eq. 'bottom') then numpan = numpan + 1 ips(numpan) = ipanno if (iend .eq. 2) flip = .true. ! ! add to top of list ! elseif (where .eq. 'top') then numpan = numpan + 1 do 100 i = numpan,2,-1 ips(i) = ips(i-1) 100 continue ips(1) = ipanno if (iend .eq. 1) flip = .true. ! ! unknown option ! else write(nout,6000)where CALL AbortPanair('addpan') endif ! ! if required, flip the ends of the segment ! if (flip) then tmpx = sginfo(2) tmpy = sginfo(3) tmpz = sginfo(4) tmpeta = sginfo(8) tmpcsi = sginfo(9) sginfo(2) = sginfo(5) sginfo(3) = sginfo(6) sginfo(4) = sginfo(7) sginfo(8) = sginfo(10) sginfo(9) = sginfo(11) sginfo(5) = tmpx sginfo(6) = tmpy sginfo(7) = tmpz sginfo(10) = tmpeta sginfo(11) = tmpcsi itmp = iother iother = iend iend = itmp endif ! ! formats ! 6000 format(/,/,' **** error - subroutine addtra: unknown option - ', & & a,/,/) ! ! subroutine end ! return END subroutine addpan ! **deck addtra subroutine addtra (where,itra,iend,itcsa & & ,isinfo,numtra,nout) implicit double precision (a-h,o-z) ! ! --------------------- purpose of routine ------------------------ ! ! this subroutine takes the list of traces that make up a ! a string and adds a new trace to the list. ! definitions: ! trace - sequence of panels on a single network that ! the cutting plane goes through and make a ! logically continuous line ! string - list of traces in a group of networks that ! the cutting plane goes through and make up a ! locigally continuous line ! ! formal parameters: ! ! isinfo matrix in/out - list containing the information ! about the current string ! col 1 - trace number ! col 2 - beginning index in the ! ips (panel stack) vector ! col 3 - end index in the ips vector ! col 4 - increment for loop along ! individual trace ! (if beg > end; incr=-1) ! iend integer input end of the trace to connect to ! the current string ! 1 - connect trace start to string ! 2 - connect trace end to string ! itcsa vector input trace stack accumulator ! this vector contains the accum. ! sum of the number of panels in ! each trace. ! itcsa(itra) + 1 = beginning index ! in ips for trace ! itcsa(itra+1) = end index in ips ! for trace ! itra integer input current trace number ! nout integer input standard output unit ! numtra integer in/out trace counter for this string ! where char. input string telling where to put new ! trace in cut ! 'new' - this is the first entry ! in a new string ! 'top' - add trace to top of str ! 'bottom' - add trace to bottom of ! string ! ! ! --------------------- formal parameter list --------------------- ! integer itcsa(*),isinfo(4,numtra+1) character*(*) where ! ! --------------------- labelled common blocks -------------------- ! ! ! --------------------- local array declarations ------------------ ! ! ! --------------------- executable code --------------------------- ! ! calculate beginning and ending indicies in ips for this trace ! ienter = itcsa(itra) + 1 iexit = itcsa(itra+1) if (iend .eq. 1) then istart = ienter istop = iexit incr = 1 else istart = iexit istop = ienter incr = -1 endif ! ! this is a new trace ! if (where .eq. 'new') then isinfo(1,1) = itra isinfo(2,1) = istart isinfo(3,1) = istop isinfo(4,1) = incr numtra = 1 ! ! add to bottom of list ! elseif (where .eq. 'bottom') then numtra = numtra + 1 isinfo(1,numtra) = itra isinfo(2,numtra) = istart isinfo(3,numtra) = istop isinfo(4,numtra) = incr ! ! add to top of list ! elseif (where .eq. 'top') then numtra = numtra + 1 do 100 i = numtra,2,-1 call icopy(4,isinfo(1,i-1),1,isinfo(1,i),1) 100 continue isinfo(1,1) = itra isinfo(2,1) = istop isinfo(3,1) = istart isinfo(4,1) = -incr ! ! unknown option ! else write(nout,6000)where CALL AbortPanair('addtra') endif ! ! formats ! 6000 format(/,/,' **** error - subroutine addtra: unknown option - ', & & a,/,/) ! ! subroutine end ! return END subroutine addtra ! **deck agpsfl subroutine agpsfl (nacase, zk,nmk,nnk,npa,netwrk & & ,npanfp,agpspc,pandat) implicit double precision (a-h,o-z) dimension zk(3,nmk,nnk) dimension agpspc(3,4,npanfp), pandat(4,4, (nmk-1)*(nnk-1) ) ! author: ! engineering: gary saaris ! programming: james weber ! ! dates: ! original - april 1985 ! revisions - ! ! purpose: ! create a file for agps to plot panel pressures at corners ! ! description of calling arguments: ! nacase input number of simultaneous solutions ! zk input geometry of grid points ! nmk input number of rows in network ! nnk input number of columns in network ! npa input accumulated number of grid points ! netwrk input network number ! iagpsf output a ggp-type file is created as output ! agpspc input 3x4 array of panel pressures ! pandat scratch 4x4 arrays of panel data for each panel ! ! performance limitations and restrictions: none ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call agps ! common /agps/ jacase,iagpsf ! agpspc - all 3 components of the pressure coefficients on ! every panel for every case ! jacase - particular case being dealt with ! iagpsf - name of file having pressure data for agps plotting ! !end agps ! dimension cpval(4), q(3,4), ptg(3), ptl(3) ! ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! ! loop on panels for all pressures at all corners for each solution do 300 jcol = 1, nnk-1 do 250 irow = 1, nmk-1 ! ! find panel corner points do 100 i = 1,3 q(i,1) = zk( i, irow , jcol ) q(i,2) = zk( i, irow , jcol+1 ) q(i,3) = zk( i, irow+1, jcol+1 ) q(i,4) = zk( i, irow+1, jcol ) 100 continue ! ! find local panel number, lip lip = irow + (nmk-1)*(jcol-1) ! ! find global panel number, ip ip = lip + npa ! ! fill common block /pandq/ call strns(ip, cp) call psddqg ! do 160 j = 1,4 ! do 150 i = 1,3 ptg(i) = q(i,j) 150 continue ! call unipan( ar(1,5), cp(1,9), ptg, ptl ) ! do 155 ic = 1,nacase pandat( j, ic, lip ) = agpspc( 1, ic, ip ) & & + agpspc( 2, ic, ip )*ptl(1) & & + agpspc( 3, ic, ip )*ptl(2) 155 continue ! 160 continue ! 250 continue ! 300 continue ! ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! ! compute pressures at all corners of the panels in the network ! write the data out to the ggp file by columns in the format - ! irow x y z cp1 cp2 ... cpn ! do 600 jcol = 1, nnk ! ! write run-id based on case letter, network number, and col.no. ! write(.) 'n'//netwrk//'c'//jcol or ! write(.) 'm'//nettmp//'c'//jcol where nettmp=netwrk-99 if(netwrk.le.99) write(iagpsf,5001) netwrk, jcol 5001 format('n',i2.2,'c',i3.3) if(netwrk.gt.99) nettmp = netwrk - 99 if(netwrk.gt.99) write(iagpsf,5002) nettmp, jcol 5002 format('m',i2.2,'c',i3.3) ! do 550 irow = 1, nmk ! put out header on nw 1, row 1, col 1 if ( netwrk.eq.1 .and. irow.eq.1 .and. jcol.eq.1 ) & & write (iagpsf,6001) (ia,ia=1,nacase) 6001 format (' irow' ,12x,'x' ,12x,'y' ,12x,'z', 4(10x,'cp',i1,:)) ! ! define indices of adjacent panels ipxmm = irow-1+(nmk-1)*(jcol-2) ipxpm = irow +(nmk-1)*(jcol-2) ipxmp = irow-1+(nmk-1)*(jcol-1) ipxpp = irow +(nmk-1)*(jcol-1) ! do 555 i = 1,3 q(i,1) = zk( i, irow , jcol ) 555 continue ! do 500 j = 1,nacase ! compute cpval( j ) = computed average of neighboring panels ! ! case 1: irow=1 and jcol=1 if( .not. ((irow.eq.1).and.(jcol.eq.1)) ) go to 450 cpval(j) = pandat(1,j,ipxpp) go to 500 ! ! case 2: irow=1 and jcol=nnk 450 if( .not. ((irow.eq.1).and.(jcol.eq.nnk)) ) go to 452 cpval(j) = pandat(2,j,ipxpm) go to 500 ! ! case 3: irow=nmk and jcol=nnk 452 if( .not. ((irow.eq.nmk).and.(jcol.eq.nnk)) ) go to 454 cpval(j) = pandat(3,j,ipxmm) go to 500 ! ! case 4: irow=nmk and jcol=1 454 if( .not. ((irow.eq.nmk).and.(jcol.eq.1)) ) go to 456 cpval(j) = pandat(4,j,ipxmp) go to 500 ! ! case 5: irow=1 456 if( .not. (irow.eq.1) ) go to 458 cpval(j) = ( pandat(2,j,ipxpm) & & + pandat(1,j,ipxpp) )/2.d0 go to 500 ! ! case 6: jcol=nnk 458 if( .not. (jcol.eq.nnk) ) go to 460 cpval(j) = ( pandat(3,j,ipxmm) & & + pandat(2,j,ipxpm) )/2.d0 go to 500 ! ! case 7: irow=nmk 460 if( .not. (irow.eq.nmk) ) go to 462 cpval(j) = ( pandat(4,j,ipxmp) & & + pandat(3,j,ipxmm) )/2.d0 go to 500 ! ! case 8: jcol=1 462 if( .not. (jcol.eq.1) ) go to 464 cpval(j) = ( pandat(1,j,ipxpp) & & + pandat(4,j,ipxmp) )/2.d0 go to 500 ! ! case 9: all other cases ( 1 .lt. irow .lt. nmk .and. ! 1 .lt. jcol .lt. nnk ) 464 continue cpval(j) = ( pandat(3,j,ipxmm) & & + pandat(4,j,ipxmp) & & + pandat(1,j,ipxpp) & & + pandat(2,j,ipxpm) )/4.d0 go to 500 ! 500 continue ! ! write output record: irow x y z cp1 cp2 ... cpn write(iagpsf,7000) & & irow, (q(ii,1), ii=1,3), (cpval(jj), jj = 1,nacase) 7000 format (i5, 7(1p,e13.5) ) ! 550 continue ! ! write end of file mark write(iagpsf, 8000) 8000 format('*eof') ! 600 continue ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! return END Subroutine agpsfl ! **deck aical subroutine aical (row,rows,rhs,jci,nwrit,irwcum,dvdfs,nrhtyp) implicit double precision (a-h,o-z) dimension row(1),rows(1),rhs(1) ! --- real*8 row, rows, rhs ! --- dimension dvdfs(4,mxsngt) dimension dvdfs(4,1:*) ! --- real*8 dvdfs !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to assemble coefficients and right hand sides of the * ! * influence coefficient equation corresponding to a control * ! * point boundary condition * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * the function of subroutine aical is to generate the row of * ! * the influence coefficient and right hand side matrices * ! * corresponding to a given control point boundary condition * ! * equation, the row of the influence coefficient matrix is * ! * composed of the contributions of each unknown singularity * ! * parameter to the quantity being specified while the * ! * corresponding row of the right hand side matrix contains the * ! * specified values for each case as well as the negative of the* ! * influence of all known singularity parameters on the left * ! * hand side of the boundary condition equation. boundary * ! * condition equation coefficients are input through the common * ! * block /bcond/. aical performs different computations * ! * depending on the value of nct. nct=1 implies that the only * ! * non-zero left hand side coefficients are cu and/or cl while * ! * nct=4 implies that the only non-zero left hand side * ! * coefficients are du and/or dl. advantage is taken of these * ! * situations in order to reduce computation time. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bet /bcond/ input boundary condition (multiple) * ! * right hand side coefficients * ! * * ! * betams /comprs/ input 1.-(freestream mach number)**2* ! * * ! * ca -local- - - - - average normal perturbation * ! * mass flux coefficient * ! * * ! * cd -local- - - - - difference normal perturbation* ! * mass flux coefficient * ! * * ! * cl /bcond/ input boundary condition coefficient* ! * of lower surface perturbation * ! * normal mass flux * ! * * ! * compd /comprs/ input compressibility direction * ! * vector * ! * * ! * cu /bcond/ input boundary condition coefficient* ! * of upper surface perturbation * ! * normal mass flux * ! * * ! * da -local- - - - - average normal perturbation * ! * potential coefficient * ! * * ! * dd -local- - - - - difference normal perturbation* ! * potential coefficient * ! * * ! * dddfs -local- - - - - dependence of doublet strength* ! * and gradient (in global * ! * coordinates) on local * ! * singularity parameters * ! * * ! * dl /bcond/ input boundary condition coefficient* ! * of lower surface perturbation * ! * potential * ! * * ! * * ! * dsdfs -local- - - - - dependence of source strength * ! * at control point on local * ! * singularity parameters * ! * du /bcond/ input boundary condition coefficient* ! * of upper surface perturbation * ! * potential * ! * * ! * iid /pandq/ input index array for panel doublet * ! * singularity parameters * ! * * ! * iis /pandq/ input index array for panel source * ! * singularity parameters * ! * * ! * ind /pandq/ input number of doublet singularity * ! * parameters on which panel * ! * doublet distribution depends * ! * * ! * ins /pandq/ input number of source singularity * ! * parameters on which panel * ! * source distribution depends * ! * * ! * ipc /cntrq/ in/out panel on which control point * ! * lies * ! * its /pandq/ input panel singularity type * ! * =1 source alone * ! * =2 doublet alone * ! * =3 source and doublet * ! * * ! * jc argument input control point at which * ! * boundary condition is to be * ! * applied * ! * * ! * nacase /acase/ input number of freestream cases * ! * for simultaneous solution * ! * * ! * nct /bcond/ input boundary condition left hand * ! * side coefficient descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * nrhtyp argument output rhs type * ! * * ! * nsngu /index/ input total number of unknown * ! * singularity parameters * ! * * ! * nwrit argument output indicates whether boundary * ! * condition is essential to * ! * problem * ! * * ! * rhs argument output row of right hand sides * ! * corresponding to boundary * ! * condition * ! * * ! * row argument output row of problem matrix equation* ! * corresponding to boundary * ! * condition * ! * * ! * ta -local- - - - - average combined perturbation * ! * potential/velocity * ! * coefficient vector * ! * td -local- - - - - difference combined perturba- * ! * tion potential/velocity * ! * coefficient vector * ! * * ! * tl /bcond/ input boundary condition coefficient* ! * vector of lower surface per- * ! * turbation tangential velocity * ! * * ! * tu /bcond/ input boundary condition coefficient* ! * vector of upper surface per- * ! * turbation tangential velocity * ! * * ! * varhs -local- - - - - average potential and * ! * velocity at control point * ! * induced by known singularity * ! * parameters for each freestream* ! * case * ! * * ! * vdrhs -local- - - - - difference potential and * ! * velocity at control point * ! * induced by known singularity * ! * parameters for each freestream* ! * case * ! * * ! * zc /cntrq/ in/out global coordinates of * ! * control point * ! * * ! * zdc /cntrq/ input control point function flag * ! * =0. panel center control * ! * point with specified * ! * boundary conditions * ! * =-1. network edge control * ! * point with specified * ! * boundary conditions * ! * =1. to 4. * ! * network edge control * ! * point used to match * ! * doublet strength across * ! * respective network edge * ! * 1. to 4. * ! * * ! * znc /cntrq/ in/out normal to surface * ! * (global coordinate system) * ! * at zc * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call bcond common /bcond/ & & cu,cl,tu(3),tl(3),du,dl,bet(4),nct,nlopt,nropt,necpt & & ,klopt,kldum,betin(4) & & ,nbin !end bcond !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call singq common /singq/ insq, indq, sgq(16), amuq(25) !end singq !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call cp2aul ! /cp2aul/ = index for abutments having a cp(2nd order) ! matching condition. common /cp2aul/ ncp2ab, idcp2(3,50) & & , ablcp2(50), keycp2(50) integer ablcp2 !end cp2aul !call cp2mcd ! /cp2mcd/: common region for list of all cp(second order) b.c.' ! jcncp2 = list of control points ! irwcp2 = list of aic rows ! inacp2 = list of corresponding entries in idcp2(1:3 parameter (maxcp2=1000) common /cp2mcd/ nbccp2, jcncp2(maxcp2), irwcp2(maxcp2) & & , inacp2(maxcp2) !end cp2mcd !call cp2flg ! /cp2flg/: newton iteration, lambda print and cp2 print flags common /cp2flg/ istcp2, iexcp2, nitcp2 !end cp2flg !call enrchx common /enrchx/ senrch !end enrchx !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp !call cvtrns ! /cvtrns/ common /cvtrns/ nejc !end cvtrns common /skrchy/ scry(200,28) !call compsp ! /compsp/ ! contains info relating mu on edges 2 or 4 of ntdk=6 nw's ! to panel interior values common /compsp/ bpsp(6,200,2) & & , kntpsp, npsp(200,2), kkpsp(200,2), iipsp(6,200,2) !end compsp logical setpsp dimension zch(3), zk(3), phi(9), phis(9), phit(9), zncsgn(3) & & , dvsrc(3,3), dvdbl(3,9), dvs(3), dvd(9), dvsa(9) dimension dvda(25) ! --- real*8 dvda dimension vfsul(3,4,2) logical ident, wkanal, wknw dimension rhss(4) ! --- real*8 rhss dimension tn(4),ta(4),td(4),vd(4),dsdfs(16) dimension dddfs(4,25) ! --- real*8 dddfs, cfac !c ! * no computations are performed for null boundary condition * ! * or for previously applied boundary conditions specifying * ! * source or doublet values at control point * dimension tg(3), rul(2), isgnul(2), ipotul(2) ! nwrit = 0 call ctrns (jci,zc) wkanal = .false. ntdk = ntd(kc) if ( ntdk.eq.18 .or. ntdk.eq.20 ) wkanal = .true. ! determine if the boundary condition s ! be replaced by setting a provisional ! to a value defined by an extrapolatio ! spline setpsp = .false. if ( ntd(kc).ne.6 ) goto 30 call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) if ( jfn.ne.1 .and. jfn.ne.(2*nn(kc)-1) ) goto 30 if ( nlopt.eq.0 .or. nbin.eq.nbinmc ) goto 30 ! set flag to generate a specified mu b setpsp = .true. 30 continue if ( nbin.eq.nbinmc ) go to 1000 if ( nlopt.eq.0 ) go to 970 if ( setpsp ) goto 1700 ipass=0 jc=jci 50 continue !c ! * retrieve control point defining quantities * ! call ctrns(jc,zc) !c ! * retrieve panel defining quantities * ! call strns(ipc,cp) !c ! * calculate singularity distribution coefficients * ! call sinfcc(zc,icc,dsdfs,dddfs) insq = ins indq = ind call dcopy (ins, dsdfs,1, sgq,1) do 70 j = 1,ind amuq(j) = dddfs(1,j) 70 continue !c ! * retrieve average potential and velocity influence * ! * coefficients * ! !c ! * compute contribution to average and difference potential * ! * and velocity at control point due to known singularity * ! * parameters * ! !c ! * compute co-normal vector * ! call cmpscl(betams,compd,znc,tn(2)) tn(1)=0.d0 !c ! * branch according to boundary condition type * ! ! * call outlin ("aical,jc",5,jc,nct,nlopt,du,dl) ! * call outmat ("dvdfs",4,1,nsngt,dvdfs) nrhtyp = nct go to(300,400,475,500),nct 300 continue !c ! * specification of normal mass flux only * ! ca=cu+cl cd=.5d0*(cu-cl) !c ! * loop ranges over the number of simultaneous solutions to * ! * generate the right hand side * ! do 130 iacase=1,nacase 130 rhs(iacase)=bet(iacase) !c ! * zero right hand side for doublet matching boundary condition * ! call mxm (tn,1,dvdfs,4,row,nsngt) !c ! * loop ranges over total number of unknown singularity * ! * parameters to generate left hand side coefficients * ! do 150 is=1,nsngt 150 row(is)=ca*row(is) if(its.eq.2) go to 900 !c ! * add in difference normal mass flux due to local source * ! * distribution * ! do 165 ic=1,ins is=iis(ic) row(is)=row(is)+cd*dsdfs(ic) 165 continue go to 900 400 continue !c ! * arbitrary boundary condition coefficients * ! do 410 i=1,3 ta(i+1)=tu(i)+tl(i) 410 td(i+1)=.5d0*(tu(i)-tl(i)) ta(1)=du+dl td(1)=.5d0*(du-dl) !c ! * project vectors onto tangent plane * ! call mxm (ta(2),1,ta(2),3,tas,1) call mxm (td(2),1,td(2),3,tds,1) call mxm (znc,1,ta(2),3,tan,1) call mxm (znc,1,td(2),3,tdn,1) facta=0.d0 if(tas.gt.tan*tan) facta=1.d0/sqrt(1.d0-tan*tan/tas) factd=0.d0 if(tds.gt.tdn*tdn) factd=1.d0/sqrt(1.d0-tdn*tdn/tds) do 420 i=1,3 ta(i+1)=facta*(ta(i+1)-tan*znc(i))+(cu+cl)*tn(i+1) 420 td(i+1)=factd*(td(i+1)-tdn*znc(i))+.5d0*(cu-cl)*tn(i+1) !c ! * loop ranges over the number of simultaneous solutions to * ! * generate one row of the left hand side * ! do 430 iacase=1,nacase 430 rhs(iacase)=bet(iacase) !c ! * compute average influence coefficients * ! call mxm (ta,1,dvdfs,4,row,nsngt) if(its.eq.2) go to 450 !c ! * add in difference potential and velocity due to local * ! * doublet distrubution * ! do 445 ic=1,ins is=iis(ic) call zero(vd,4) call mxm (tn(2),1,znc,3,factor,1) call vadd(vd(2),dsdfs(ic)/factor,znc,vd(2),3) !== call mxmca (vd,1,td,4,row(is),1) call hsmmp2 (1,4,1, vd,1,1, td,1,4, row(is),1,1) 445 continue 450 continue if ( its.eq.1 ) go to 470 !c ! * add in difference normal mass flux due to local source * ! * distribution * ! do 465 ic=1,ind is=iid(ic) !== call mxmca (dddfs(1,ic),1,td,4,row(is),1) call hsmmp2 (1,4,1, dddfs(1,ic),1,1, td,1,4, row(is),1,1) 465 continue 470 continue if ( nlopt.lt.18 .or. nlopt.gt.20 ) go to 473 ! if ( nlopt.eq.18 ) goto 473 if ( nbccp2.ge.maxcp2 ) call a502ms ('aical' & & ,'nbccp2 buffer overflow: too many nl bc-s') if ( nbccp2.ge.maxcp2 ) go to 473 nbccp2 = nbccp2 + 1 jcncp2(nbccp2) = jc irwcp2(nbccp2) = irwcum+1 inacp2(nbccp2) = 0 if ( mod(nbccp2,50).eq.1 ) write (6,6005) write (6,6002) nbccp2,(irwcum+1),jc,(rhs(ia),ia=1,nacase) 6002 format (2x,i5,2x,i5,2x,i5,4x,4f12.6) 6005 format (1h1,20x,'nonlinear b.c. summary' & & ,//, 1h ,' index',3x,'iaic',5x,'jc',22x,'rhs terms') 473 continue go to 900 475 continue ca=cu+cl cd=.5d0*(cu-cl) do 480 iacase=1,nacase 480 rhs(iacase)=bet(iacase) call zero(row,nsngt) nrow=nm(kc)-1 do 490 m=1,nrow ic=jc+m call ctrns(ic,zc) call strns(ipc,cp) call vtrns(ic,dvdfs) call sinfcc(zc,icc,dsdfs,dddfs) area=c(1,1)*aj(5) call cmpscl(betams,compd,znc,tn(2)) do 482 i=2,4 482 tn(i)=ca*area*tn(i) do 483 iacase=1,nacase call mxm (fsv(1,iacase),1,znc,3,wna,1) 483 rhs(iacase)=rhs(iacase)-ca*area*wna call hsmmp2 (nsngt,4,1 ,dvdfs,4,1 ,tn,1,4 ,row,1,nsngt) if(its.eq.2) go to 490 do 485 ic=1,ins is=iis(ic) 485 row(is)=row(is)+cd*area*dsdfs(ic) 490 continue call vtrns(jc,dvdfs) go to 900 500 continue !c ! * specification of potential * ! da=du+dl dd=.5d0*(du-dl) if((zdc.gt.0.d0).and.(necpt.eq.0)) dd=0.d0 !c ! * loop ranges over the number of simultaneous solutions to * ! * generate one row of the right hand side * ! do 530 iacase=1,nacase 530 rhs(iacase)=bet(iacase) !c ! * zero right hand side for doublet matching boundary condition * ! if((zdc.gt.0.d0).and.(necpt.eq.0)) call zero(rhs,nacase) if((zdc.gt.0.d0).and.(necpt.eq.0)) nrhtyp = 5 !c ! * loop ranges over total number of unknown singularity * ! * parameters to generate left hand side coefficients * ! do 550 is=1,nsngt 550 row(is)=da*dvdfs(1,is) if(its.eq.1) go to 900 !c ! * add in difference potential due to local doublet distribution* ! do 565 ic=1,ind is=iid(ic) row(is)=row(is)+dd*dddfs(1,ic) 565 continue go to 900 ! 900 continue if(necpt.eq.0) go to 950 if(ipass.ne.0) go to 925 ipass=1 call dcopy(ityprc*nsngt,row,1,rows,1) call dcopy(ityprc*nacase,rhs,1,rhss,1) jc=necpt call vtrns(jc,dvdfs) go to 50 925 call vadd(rhs,-1.d0,rhss,rhs,ityprc*nacase) call vadd(row,-1.d0,rows,row,ityprc*nsngt) if(nbin.eq.1) call vtrns(jci,dvdfs) 950 continue !c ! * boundary condition equation should be added as row of problem* ! * matrix equation * ! nwrit=1 970 continue if ( jcn.eq.ipraic ) then write (6,'('' da/d,du/l:'',6f12.6,i4)' ) da,dd,du,dl,cu,cl,nct call outvci ('iid',ind,iid) call outmtx ('dddfs',4*ityprc,4*ityprc,ind,dddfs) call outmtx ('dvdfs',4*ityprc,4*ityprc,nsngt,dvdfs) write (6,'('' jcn,nbin,nl,nropt'',4i6)') jcn,nbin,nlopt,nropt call outmtx ('aic row',ityprc,ityprc,nsngt,row) endif return ! matching conditions 1000 continue nrhtyp = 6 ! calculate hypothetical c.p. location jc = jci nwrit = 1 call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) call enrchg (kc,ifn,jfn,zch) sclzch = senrch ! determine if the abutment is a cp2 ! matching abutment. icp2ab = 0 if ( idcpmc.eq.0 ) go to 1160 kabt = iabs(kabmtc) call srchol (ablcp2,ncp2ab,kabt,loc) if ( loc.ne.0 ) icp2ab = keycp2(loc) if ( loc.ne.0 ) go to 1100 if ( idcpmc.eq.1 ) goto 1160 write (6,6001) jc, kabt, idcpmc 6001 format ('0 aical at control pt',i5,' abutment ',i5 & & ,' not found in ablcp2 abutment list. idcpmc = ',i5) call a502er ('aical' & & ,'for idcmpc = 2,3, ablcp2 must have abmt entry') 1100 continue nbccp2 = nbccp2 + 1 if ( nbccp2.gt.maxcp2 ) call a502ms ('aical' & & ,'nbccp2 buffer overflow: too much cp2 match') if ( nbccp2.gt.maxcp2 ) go to 1160 jcncp2(nbccp2) = jc irwcp2(nbccp2) = irwcum + 1 inacp2(nbccp2) = icp2ab if ( iexcp2.lt.1 ) go to 1160 write (6,'(1x,a10,1x, 6i12)') & & 'aical/cp2',nbccp2,jc,irwcum+1,icp2ab,kabt,loc 1160 continue iptabt = -2 rul(1) = 1.d0 rul(2) = 1.d0 if ( idcpmc.ne.2 .and. idcpmc.ne.3 ) goto 1176 ! define iptabt and perform some error if ( icp2ab.eq.0 ) CALL AbortPanair('aical-1') do 1155 iul = 1,2 kedgsg = idcp2( iul+1, icp2ab) isgnsf = isign(1,kedgsg) kedg = iabs( kedgsg ) knet = (kedg+3)/4 indsf = (3-isgnsf)/2 kmatsf = matnet(indsf,knet) rul(iul) = cpfmat(kmatsf) call dcopy (3*nacase, fsv,1, vfsul(1,1,iul),1) ksd = kedg - 4*(knet-1) ipotnw = ipot(knet) isgnul(iul) = isgnsf if ( ipotnw.eq.0 ) goto 1151 ! ipotnw # 0, 2 nw case if ( mod(iabs(ipotnw),2) .eq. 1 ) & & ipotnw = ipotnw + isign( 1, ipotnw) if ( isgnsf*ipotnw .le. 0 ) CALL AbortPanair('aical-2') goto 1154 ! ipotnw = 0, 1 nw case 1151 continue if ( nejc.eq.4 .and. npnmtc.le.2 ) goto 1154 write (6,'(1x,a10,1x, 10i12)') & & 'aical/1151',jc,kc,ijfgc,nejc,npnmtc & & ,ipotnw,iul,kedgsg,nbccp2,knet call outvci ('ipnmtc',npnmtc,ipnmtc) CALL AbortPanair('aical-3') goto 1154 ! 1154 continue ipotul(iul) = ipotnw 1155 continue if ( iabs(ipotul(1)) .ne. iabs(ipotul(2)) ) CALL AbortPanair('aical-4') iptabt = iabs(ipotul(1)) if ( iptabt.eq.0 .and. npnmtc.ne.2 ) CALL AbortPanair('aical-5') if ( iptabt.eq.2 .and. npnmtc.ne.3 ) CALL AbortPanair('aical-6') if ( iptabt.eq.4 .and. npnmtc.ne.3 ) CALL AbortPanair('aical-7') nrhtyp = 6 if ( iptabt.eq.4 ) nrhtyp = 7 ! 1176 continue call zero (row,ityprc*nsngt) do 1500 kpan = 1,npnmtc ipndat = ipnmtc(kpan) lsgn = isign( 1, ipndat) sgn = lsgn call mnmod( iabs(ipndat), 4, lsd, ip) if ( jc.ne.ipraic ) go to 1180 write (6,6003) jc,kpan,ipndat,lsgn,lsd,ip 6003 format (' matching condition, jc =',i5,' term of sum =',i2 & & ,' panel data=',i6,' sgn=',i3,' side=',i2,' ip=',i5) 1180 continue call strns (ip,cp) knedge = lsd + 4*(kp-1) ic1 = lsd ic2 = mod(ic1,4) + 1 call cptls (cp(1,ic1),cp(1,ic2),zch,zk,t) sclpan = 0.d0 do 1200 jsd = 1,4 sclpan = max ( sclpan, ddot(3,cp(1,jsd),1,cp(1,jsd),1) ) 1200 continue sclpan = sqrt(sclpan) scldz = max ( sclpan, sclzch) call distnc (zch,zk,dzpq) ident = dzpq .le. ( 1.d-10 * scldz ) if ( .not. ident ) call a502ms ('aical' & & ,'exact matching not achieved. whats up? ') call stedge (lsd,t,svar,tvar) call zero (dvs,3) call zero (dvd,9) if ( kabmtc.lt.0 ) go to 1300 ! ordinary doublet matching call bqbfun (svar,tvar, phi,phis,phit) call vmul (phi,sgn,dvd,9) go to 1465 1300 continue ! cp matching condition. if idcpmc=1, ! do ordinary vorticity (velocity jump) ! matching. if idcpmc=2 and icp2ab. ! do cp2 matching call dvcalc (zch,svar,tvar, dvsrc,dvdbl) call vmul (znc,sgn,zncsgn,3) if ( icp2ab .eq. 0 ) go to 1400 if ( idcpmc.lt.2 .or. idcpmc.gt.3 ) & & write (6,'(1x,a10,1x, 6i12)') & & 'aical/err',jc,kc,ifn,jfn,idcpmc,icp2ab if ( idcpmc.lt.2 .or. idcpmc.gt.3 ) call a502er ('aical' & & ,'linear bc appears in keycp2 list') knup = iabs(idcp2(2,icp2ab)) sgup = isign( 1, idcp2(2,icp2ab) ) knlo = iabs(idcp2(3,icp2ab)) sglo = isign( 1, idcp2(3,icp2ab) ) sgn = 0.d0 call dcopy (3, 0.d0,0, zncsgn,1) if ( knedge.ne.knlo .and. knedge.ne.knup ) goto 1400 ! if ( iptabt.eq.0 ) goto 1350 ! iptabt = 2,4, 3 nw, thick surface ma if ( knedge.eq.knup ) iul = 1 if ( knedge.eq.knlo ) iul = 2 if ( knedge.eq.knup ) sgn = sgup if ( knedge.eq.knlo ) sgn = -sglo fac = (-2.d0/fsvm(1)**2)*rul(iul)*sgn zncsgn(1) = fac*vfsul(1,1,iul) zncsgn(2) = fac*vfsul(2,1,iul) zncsgn(3) = fac*vfsul(3,1,iul) goto 1400 ! iptabt = 0, 2 nw, thin surface matchi 1350 continue fac = -sgup/fsvm(1)**2 zncsgn(1)= fac *( rul(1)*vfsul(1,1,1) & & + rul(2)*vfsul(1,1,2) ) zncsgn(2)= fac *( rul(1)*vfsul(2,1,1) & & + rul(2)*vfsul(2,1,2) ) zncsgn(3)= fac *( rul(1)*vfsul(3,1,1) & & + rul(2)*vfsul(3,1,2) ) goto 1400 ! 1400 continue call mxma (zncsgn,1,1, dvsrc,1,3, dvs,1,1, 1,3,3) call mxma (zncsgn,1,1, dvdbl,1,3, dvd,1,1, 1,3,9) go to 1450 ! 1450 continue if (jc.eq.ipraic)write (6,'(1x,a10,1x,f12.6,3i12,2f12.6,3i12)')& & 'sgn',sgn,knedge,knup,knlo & & ,sgup,sglo,icp2ab,idcpmc,jc if ( ins.le.0 ) go to 1465 call mxma (dvs,1,1, asts,1,3, dvsa,1,1, 1,3,ins) if ( jc.ne.ipraic ) go to 1457 call outvec ('dvs',3,dvs) call outvci ('iis',ins,iis) call outvec ('dvsa',ins,dvsa) 1457 continue do 1460 k = 1,ins j = iis(k) row(j) = row(j) + dvsa(k) 1460 continue 1465 continue if ( ind.le.0 ) go to 1475 call mxma (dvd,1,1, astd,1,9, dvda,1,1, 1,9,ind) if ( jc.ne.ipraic ) go to 1467 write (6,6004) jc, sgn, (phi(i),i=1,9) 6004 format (' jc',i4,' sg',f5.1,' phi',1p,9e12.4) call outvec ('dvd',9,dvd) call outvci ('iid',ind,iid) call outmat ('dvda',ityprc,ityprc,ind,dvda) 1467 continue do 1470 k = 1,ind j = iid(k) row(j) = row(j) + dvda(k) 1470 continue 1475 continue 1500 continue ! skip if vfsul data undefined if ( iptabt.ne.0 ) goto 1510 ia = 1 tg(1) = rul(1)*vfsul(1,ia,1) - rul(2)*vfsul(1,ia,2) tg(2) = rul(1)*vfsul(2,ia,1) - rul(2)*vfsul(2,ia,2) tg(3) = rul(1)*vfsul(3,ia,1) - rul(2)*vfsul(3,ia,2) call dscal (3, -2.d0/(fsvm(ia)**2), tg,1) if ( iptabt.eq.0 ) call hsmmp2 (nsngt,3,1, dvdfs(2,1),4,1, tg,1,3 & & ,row,1,nsngt ) 1510 continue call dcopy (ityprc*nacase, bet,1, rhs,1) if ( icp2ab.eq.0 ) go to 1600 knup = idcp2(2,icp2ab) knlo = idcp2(3,icp2ab) nwup = isign(1,knup)*((iabs(knup)+3)/4) nwlo = isign(1,knlo)*((iabs(knlo)+3)/4) do 1550 ia = 1,nacase rhs(ia) = bet(ia) if ( iptabt.ne.4 ) goto 1550 tg(1) = rul(1)*vfsul(1,ia,1) - rul(2)*vfsul(1,ia,2) tg(2) = rul(1)*vfsul(2,ia,1) - rul(2)*vfsul(2,ia,2) tg(3) = rul(1)*vfsul(3,ia,1) - rul(2)*vfsul(3,ia,2) call cmpscl (1.d0/betams, compd,tg,tg) call vip (tg,1, fsv(1,ia),1, 3, fac) rhs(ia) = rhs(ia) - 2.d0*fac/fsvm(ia)**2 1550 continue if ( mod(nbccp2,50).eq.1 ) write (6,6005) write (6,6002) nbccp2,(irwcum+1),jc,(rhs(ia),ia=1,nacase) ! 1600 continue if ( jc.eq.ipraic ) call outmtx ('ipraic',ityprc,ityprc,nsngt,row) return ! set the value of mu on a type 6 nw ed ! by extrapolation 1700 continue nrhtyp = 8 call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) icrs = (ifn+2)/2 jx = 1 if ( jfn.gt.1 ) jx = 2 if ( kntpsp.eq.kc ) goto 1740 ! read psp data for current network kntpsp = kc m = nm(kc) nw = m*28 if ( nw.gt.4*mxsngk ) call a502er ('aical' & & ,'scr buffer overflow, ytrns call') call ytrns (kc,scry,nw) call upkpsp (200,m, npsp,kkpsp,iipsp,bpsp, 4*nsngk,scry) ! 1740 continue ! check that the psp has not been nulle if ( kkpsp(icrs,jx).eq.0 ) then call a502ms ('aical','mu set to 0 w/o nulling nlopt') write (6,'(1x,a10,1x, 3i12)') & & 'k,ifn,jfn',kc,ifn,jfn goto 1810 endif ! put in the bc: ! nspsp ! mu(sp point) = sum bpsp(k)*mu( iipsp ! k=1 nwrit = 1 is = kkpsp(icrs,jx) isa = iabs(is) fac = -1.d0 if ( is.lt.0 ) fac = -fac call dcopy (ityprc*nsngt, 0.d0,0, row,1) row(isa) = fac if ( iextrp.lt.2 ) goto 1750 write (6,'(1x,a10,1x, 3i12,f12.6,4i12)') & & 'aic term',irwcum+1,jcn,isa,row(isa),npsp(icrs,jx) & & ,icrs,jx,kc 1750 continue nspsp = npsp(icrs,jx) do 1760 k = 1,nspsp is = iipsp(k,icrs,jx) if ( is.eq.0 ) goto 1760 fac = bpsp(k,icrs,jx) isa = iabs(is) if ( is.lt.0 ) fac = -fac row(isa)= row(isa) + fac if ( iextrp.lt.2 ) goto 1760 write (6,'(1x,a10,1x, 3i12,f12.6)') & & ' term',irwcum+1,jcn,isa,row(isa) 1760 continue call dcopy (ityprc*nacase, 0.d0,0, rhs,1) ! 1810 continue return END Subroutine AiCal ! **deck aicerr subroutine aicerr (nzero,irow,jc,dvdfs) implicit double precision (a-h,o-z) dimension dvdfs(4,1:*) ! ! report an error from aic generation ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call bcond common /bcond/ & & cu,cl,tu(3),tl(3),du,dl,bet(4),nct,nlopt,nropt,necpt & & ,klopt,kldum,betin(4) & & ,nbin !end bcond !call vrwi common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp) !end vrwi !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call singq common /singq/ insq, indq, sgq(16), amuq(25) !end singq !call aarwi ! /aarwi/: common region for index for i/o unit nta=iray(2)=27 ! random file storage for aic matrix. common /aarwi/ nra, nta, nna, nia(mxsngu+1) !end aarwi ! nzero = nzero + 1 call errmsg ('identically zero row encountered') write (6,'(1x,a10,1x, 2i12)') & & 'row #',irow,nzero ! if ( nzero.gt.10 ) go to 420 ne = nwv(jc) write (6,'(1x,a10,1x, 2i12,4f12.6,4i12)') & & 'jc',jc,its,cu,cl,du,dl,nct,nlopt,nropt,necpt call outvci ('iis',ins,iis) call outvec ('sigma',insq,sgq) call outvci ('iid',ind,iid) call outvec ('mu',indq,amuq) call outmat ('dvdfs',4,ne,nsngt,dvdfs) 420 continue ! return END Subroutine AicErr ! **deck aicsup subroutine aicsup (q,saic,daic) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * aicsup computes near field aic-s for superinclined panels * ! * assuming that in local coordinates the panel lies in the * ! * y-z plane. using this convention, the rows of the aic * ! * matrix correspond to (vx,vy,vz,ph). * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * aicsup uses formulae developed by m. epton at the boeing * ! * company. these formulae give the source and doublet * ! * aics as follows * ! * * ! * * ! * -(2*pi) * beta * s(0) = * ! * * ! * ( 1 0 0 ) * ! * psi * ( 0 x 0 ) * ! * ( 0 0 x ) * ! * ( x 0 0 ) * ! * * ! * ( 0 x*ny x*nz ) * ! * + sum phi(k) * ( ny -d*ty*ty -d*ty*tz ) * ! * edges k ( nz -d*tz*ty -d*tz*tz ) * ! * ( -d .5*ny*(x*x-d*d) .5*nz*(x*x-d*d) ) * ! * * ! * ( 0 0 0 ) * ! * + sum delr(k) * ( 0 ty*ny ty*nz ) * ! * edges k ( 0 tz*ny tz*nz ) * ! * ( 0 -d*ty/2 -d*tz/2 ) * ! * * ! * * ! * (2*pi) * d(0) = * ! * * ! * ( 0 0 0 x 0 x ) * ! * psi * ( 0 1 0 0 0 0 ) * ! * ( 0 0 1 0 0 0 ) * ! * ( 1 0 0 x*x/2 0 x*x/2 ) * ! * * ! * ( 0 ny nz -d*ty*ty -2*d*ty*tz -d*tz*tz ) ! * + sum phi(k)*( 0 0 0 x*ny x*nz 0 ) ! * edges k ( 0 0 0 0 x*ny x*nz ) ! * ( 0 x*ny x*nz -x*d*ty*ty/2 -x*d*ty*tz -x*d*tz*tz/2) ! * * ! * ( 0 0 0 ny*ty ny*tz+nz*ty nz*tz )* ! * + sum delr(k)*( 0 0 0 0 0 0 )* ! * edges k ( 0 0 0 0 0 0 )* ! * ( 0 0 0 x*ny*ty/2 x*(ny*tz+nz*ty)/2 x*nz*tz/2)* ! * * ! * where - * ! * * ! * psi = 2*pi - sum (pi) + sum qprm(k) (panel function) * ! * edges corners * ! * * ! * * ! * phi(k) = -( ph(v,r) - ph(v,r) ) (edge )* ! * upper end lower end (functions)* ! * * ! * delr(k)= r - r * ! * upper lower * ! * * ! * x = radius of mach cone, local coords * ! * * ! * (ny,nz)= edge unit normal * ! * * ! * (ty,tz)= edge unit tangent * ! * * ! * d = edge distance * ! * * ! * qprm(k)= a corner function (see below) * ! * * ! * these formulae frovide aic-s with respect to source and * ! * doublet polynomial coefficients evaluated at the control * ! * point projection. these aic-s must then be translated * ! * to the proper expansion point to obtain *s* and *d* * ! * (saic and daic) * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * area local - - - - area of panel * ! * * ! * areak local - - - - area of a triangle determined * ! * by an edge and the control pt.* ! * a signed ouantity. * ! * * ! * btinv supdta input 1/beta, beta=area factor for * ! * global to local transformation* ! * * ! * convex local - - - - true if panel is convex, * ! * otherwise false) * ! * * ! * corner local - - - - corner(k) = true if corner-k * ! * lies inside the mach cone * ! * * ! * d local - - - - d(k) = edge distance * ! * * ! * daic argument output doublet aic-s * ! * * ! * delr local - - - - delr(k) = r(k,+) - r(k,-) * ! * * ! * delrx2 local - - - - delr(k)**/2 * ! * * ! * doublt local - - - - true if daic is to be computed* ! * * ! * drdmn2 local - - - - -delr(k)*d(k)/2 * ! * * ! * edge local - - - - edge(k) = true if edge k has * ! * any points inside the mach cone ! * * ! * fn local - - - - a factor of (1/2*pi) or * ! * possibly (1/4*pi) for daic * ! * * ! * hyy local - - - - .5*y*y y(control point) * ! * * ! * hzz local - - - - .5*z*z z(control point) * ! * * ! * intsct local - - - - true if the intersection of * ! * the panel and control point * ! * is non-empty * ! * * ! * iprsup /supflg/ input print flags for intermediate * ! * output * ! * * ! * k local - - - - index for edges and corners * ! * * ! * km1 local - - - - = mod(k+n-2,n) + 1 * ! * = (k-1) mod(n) * ! * * ! * kp1 local - - - - =mod(k,n)+1 * ! * * ! * n /supdta/ input number of edges on panel * ! * * ! * ncall /locdta/ data number of calls made to aicsup* ! * * ! * nm local - - - - nm(*,k)=edge normal, edge k * ! * * ! * p /supdta/ input local coordinates of control * ! * points projection * ! * * ! * phdmns local - - - - -phi(k)*d(k) * ! * * ! * phdxm2 local - - - - -phi(k)*x*d(k)/2 * ! * * ! * phi local - - - - phi(k) = edge function, edge k* ! * * ! * phny local - - - - phny = phi(k)*nm(1,k) * ! * * ! * phnz local - - - - phnz = phi(k)*nm(2,k) * ! * * ! * * ! * phvsqh local - - - - phi(k)*(x*x-d(k)**2)/2 * ! * * ! * pi /ncons/ input 3.14159265358... * ! * * ! * psi local - - - - a panel function * ! * * ! * psix local - - - - psi*x * ! * * ! * psixx2 local - - - - osi*x*x/2 * ! * * ! * q /supdta/ input panel corner points * ! * * ! * qprm local - - - - corner functions * ! * * ! * r local - - - - value of r at the corners * ! * * ! * rho local - - - - rho(*,k) = relative position * ! * vector from the cp to the * ! * corner oint k * ! * * ! * rhosq local - - - - rhosq(k) = (rho(*,k),rho(*,k))* ! * * ! * saic argument output source aic matrix * ! * * ! * sn local - - - - scale factor for source aic*s * ! * * ! * snalfa local - - - - sin(alfa), alfa=turning angle * ! * for a corner * ! * * ! * tcross local - - - - cross product of two consecu- * ! * tive edge tangents * ! * * ! * tg local - - - - tg(*,k) = edge tangent on * ! * edge k * ! * * implicit double precision (a-h,o-z) ! * tktkp1 local - - - - dot product of two consecutive* ! * edge tangents * ! * * ! * tskw local - - - - tz*tz-ty*ty = tz*ny+ty*nz * ! * * ! * twopi /locdta/ - - - - 2*pi * ! * * ! * twopin /locdta/ - - - - 1/(2*pi) * ! * * ! * tyy local - - - - ty*ty * ! * * ! * tzz local - - - - tz*tz * ! * * ! * vm local - - - - vm(k) = value of v at lower * ! * end of edge k * ! * * ! * vp local - - - - vp(k) = value of v at upper * ! * end of edge k * ! * * ! * vpvm local - - - - vp(k)*vm(k) * ! * * ! * within local - - - - =true if control point projec-* ! * tion lies inside panel * ! * * ! * x /supdta/ input radius of mach cone, local * ! * coordinates * ! * * ! * xeqzro local - - - - true if x = 0 * ! * * ! * xsq local - - - - x*x * ! * * ! * xval local - - - - an x argument for atan2 * ! * * ! * yval local - - - - a y argument for atan2 * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension q(2,16), saic(4,6), daic(4,10) ! input data !call supdta ! /supdta/ common /supdta/ p(2), x, n, doublt, btinv, nf !end supdta logical doublt common /aicscm/ & & vm(16), vp(16), rhosq(16) & & , nm(2,16), edge(16), corner(16), d(16) & & , hb(14) double precision nm dimension h(2,2,2), bv(2), btw(2,2) equivalence (h,hb), (bv,hb(9)), (btw,hb(11)) dimension tg(2,16),rho(2,16),r(16),phi(16),aipsrr(2,2) ! local arrays and variables logical edge, corner, within, intsct, xeqzro, convex, subset !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons data p166/ .166666666666666d0 / data p33 / .333333333333333d0 / twopin = 1.d0/pi2 20 format (34h ----- aicsup input -----, n = ,i3,10hdoublt = , & & l3,7h x = ,e16.8 ,/, 20x,31h field and panel corner points ,/, & & (2x,i2,1h.,3x,e16.8,6x,4e16.8)) 30 continue ! set some constants xeqzro = x.eq.0.d0 xsq = x*x ! initialize aic"s to zero call zero (hb,14) aipsrr(1,1) = 0.d0 aipsrr(1,2) = 0.d0 aipsrr(2,1) = 0.d0 aipsrr(2,2) = 0.d0 ! ng = 3*( 1 + nf/10 ) call zero ( saic, 4*ng) call zero (daic,4*nf) ! check for null integral if ( x.lt.0.d0 ) go to 3000 if ( n.lt.3 ) go to 3000 ! check for too many corners if ( n.gt.20 ) go to 7000 ! determine panel orientation area = 0.d0 km1 = n do 250 k = 1,n area = area + q(1,km1)*q(2,k) - q(2,km1)*q(1,k) km1 = mod(km1,n)+1 250 continue if ( area.gt.0.d0 ) go to 270 go to 3000 270 continue ! get rho(*,k), rhosq(k), corner(k) ! and tg(*,k), nm(*,k), d(k) ! km1 = n do 300 k = 1,n ! rho(*,k) rho(1,k)= q(1,k) - p(1) rho(2,k)= q(2,k) - p(2) ! rhosq(k) rhosq(k)= rho(1,k)**2 + rho(2,k)**2 ! corner(k) corner(k) = .true. if ( xeqzro .or. rhosq(k).ge.xsq ) corner(k) = .false. ! tangent to edge k, tg(*,k) dy = q(1,k) - q(1,km1) dz = q(2,k) - q(2,km1) dnm = sqrt( dy*dy + dz*dz ) tg(1,k) = dy/dnm tg(2,k) = dz/dnm ! normal to edge k, nm(*,k) nm(1,k) = tg(2,k) nm(2,k) = -tg(1,k) ! distance of edge k, d(k) d(k) = rho(1,k)*nm(1,k) + rho(2,k)*nm(2,k) ! update km1 km1 = mod(km1,n) + 1 300 continue ! output partial results ! get vp(k), vm(k), intsct, within, ar ! edge(k), convex intsct = .false. within = .true. convex = .true. area = 0.d0 km1 = n subset = .true. ic2 = 2 do 400 k = 1,n ! update subset subset = subset .and. corner(k) ! vp(k) = ( tg(k), rho(k)) vp(k) = tg(1,k)*rho(1,k ) + tg(2,k)*rho(2,k ) ! vm(k) = ( tg(k), rho(k-1) ) vm(k) = tg(1,k)*rho(1,km1) + tg(2,k)*rho(2,km1) ! edge(k) edge(k) = corner(km1) .or. corner(k) vpvm = vp(k)*vm(k) if ( abs(d(k)).lt.x .and. x.ne.0.d0 .and. vpvm.le.0.d0 ) & & edge(k) = .true. ! update intsct intsct = intsct .or. edge(k) ! update area areak = rho(1,km1)*rho(2,k) - rho(2,km1)*rho(1,k) area = area + areak ! update convex. the sine of the ! turning angle alpha is given ! sin(alpha) = tg(k-1) x tg(k) ! = tg(k-1) . nm(k) ! if sin(alpha) .ge. 0, corner k-1 ! is convex snalfa = tg(1,km1)*nm(1,k) + tg(2,km1)*nm(2,k) if ( snalfa .lt. 0.d0 ) convex = .false. isgn = 1 if ( snalfa.lt.0.d0 ) isgn=-1 ik = 1 ikm1 = 1 if ( d(k) .lt. 0.d0 ) ik = -1 if ( d(km1).lt.0.d0) ikm1 = -1 if ( ik*ikm1 .lt. 0 ) ic2 = ic2 - isgn km1 = mod(km1,n)+1 400 continue within = ic2.eq.2 if ( convex .or. subset ) go to 415 go to 7000 415 continue if ( area .le. 0.d0 ) go to 3000 ! if the boundary of sigma has a point lying within c ! (intsct =.t. ) or if the center of c lies within sigma ! (within =.t. ) their intersection is non-null and we ! must compute aic"s if (.not.intsct .and. .not.within ) go to 3000 ! get functions r, qprm kp1 = 2 psi = pi2 do 500 k = 1,n r(k) = 0.d0 if ( corner(k) ) psi = psi + pi if ( edge(k) ) psi = psi - pi if ( .not.corner(k) ) go to 490 ! r(k) = sqrt( x*x - rho**2 ) r(k) = sqrt ( xsq - rhosq(k) ) ! qprm(k) tktkp1 = tg(1,k)*tg(1,kp1) + tg(2,k)*tg(2,kp1) tcross = tg(1,k)*tg(2,kp1) - tg(2,k)*tg(1,kp1) xval = d(k)*d(kp1) - xsq*tktkp1 yval = x*r(k)*tcross psi = psi - atan2( yval, -xval) 490 continue kp1 = mod(kp1,n)+1 500 continue ! phi(k) km1 = n do 550 k = 1,n phi(k) = 0.d0 if ( .not.edge(k) ) go to 540 phi(k) = -pi if ( .not.corner(k) .and. .not.corner(km1) ) go to 540 vpk = vp(k) if ( .not.corner(k)) vpk = 1.d0 vmk = vm(k) if ( .not.corner(km1))vmk =-1.d0 xval = vpk*vmk + r(k)*r(km1) yval = r(k)*vmk - r(km1)*vpk phi(k) = atan2 ( yval, xval) 540 km1 = mod(km1,n) + 1 550 continue psix = psi*x psixx2 = .5d0 * x * psix ! initialize s and d saic(1,1)= psi saic(2,2)= psix saic(3,3)= psix saic(4,1)= psix ! check for doublet terms if (.not.doublt) go to 700 daic(1,4)= psix daic(1,6)= psix ! daic(2,2)= psi ! daic(3,3)= psi ! daic(4,1)= psi daic(4,4)= psixx2 daic(4,6)= psixx2 700 continue ! if ( .not. intsct ) go to 1100 ! add in edge contributions km1 = n do 1000 k = 1,n if (.not.edge(k)) go to 990 phx = phi(k)*x phdmns = -phi(k)*d(k) phny = phi(k)*nm(1,k) phnz = phi(k)*nm(2,k) phvsqh = .5d0 * phi(k) * ( xsq - d(k)**2 ) delr = r(k) - r(km1) drdmn2 = - delr * d(k) * .5d0 ! get source terms, phi(k) saic(1,2)=saic(1,2) + phny*x saic(1,3)=saic(1,3) + phnz*x ! saic(2,1)=saic(2,1) + phny saic(2,2)=saic(2,2) + phdmns*tg(1,k)*tg(1,k) saic(2,3)=saic(2,3) + phdmns*tg(1,k)*tg(2,k) ! saic(3,1)=saic(3,1) + phnz saic(3,2)=saic(3,2) + phdmns*tg(2,k)*tg(1,k) saic(3,3)=saic(3,3) + phdmns*tg(2,k)*tg(2,k) ! saic(4,1)=saic(4,1) + phdmns saic(4,2)=saic(4,2) + phvsqh*nm(1,k) saic(4,3)=saic(4,3) + phvsqh*nm(2,k) ! add in delr terms saic(2,2)=saic(2,2) + delr*tg(1,k)*nm(1,k) saic(2,3)=saic(2,3) + delr*tg(1,k)*nm(2,k) ! saic(3,2)=saic(3,2) + delr*tg(2,k)*nm(1,k) saic(3,3)=saic(3,3) + delr*tg(2,k)*nm(2,k) ! saic(4,2)=saic(4,2) + drdmn2*tg(1,k) saic(4,3)=saic(4,3) + drdmn2*tg(2,k) ! check for phi(k) doublet terms phdxm2 = phdmns*x*.5d0 delrx2 = delr * x * .5d0 tyy = tg(1,k)**2 tyz = tg(1,k)*tg(2,k) tyz2 = 2.d0*tyz tzz = tg(2,k)**2 tskw = tzz - tyy if ( .not. doublt ) go to 900 ! get doublet terms, phi(k) daic(1,2)=daic(1,2) + phny daic(1,3)=daic(1,3) + phnz daic(1,4)=daic(1,4) + phdmns*tyy daic(1,5)=daic(1,5) + phdmns*tyz2 daic(1,6)=daic(1,6) + phdmns*tzz ! daic(2,4)=daic(2,4) + phny*x daic(2,5)=daic(2,5) + phnz*x ! daic(3,5)=daic(3,5) + phny*x daic(3,6)=daic(3,6) + phnz*x ! daic(4,2)=daic(4,2) + phny*x daic(4,3)=daic(4,3) + phnz*x daic(4,4)=daic(4,4) + phdxm2*tyy daic(4,5)=daic(4,5) + phdxm2*tyz2 daic(4,6)=daic(4,6) + phdxm2*tzz ! add in delr doublet terms daic(1,4)=daic(1,4) + delr*tyz daic(1,5)=daic(1,5) + delr*tskw daic(1,6)=daic(1,6) + (-delr*tyz) ! daic(4,4)=daic(4,4) + delrx2*tyz daic(4,5)=daic(4,5) + delrx2*tskw daic(4,6)=daic(4,6) + (-delrx2*tyz) ! check for cubic terms 900 continue if ( nf.lt.10 ) go to 990 ! coefficients for n(*)n(*), ! ( n(*)t(*)+t(*)n(*) ), t(*)t(*) cnn = -phi(k)*d(k)*d(k) cnt = -d(k)*delr ctt = -phvsqh - .5d0*( r(k)*vp(k) - r(km1)*vm(k) ) ! compute int( rho(*) rho(*) psi dv ) btw(1,1)= cnn*tzz + cnt*tyz2 + ctt*tyy btw(1,2)= -cnn*tyz + cnt*tskw + ctt*tyz btw(2,2)= cnn*tyy - cnt*tyz2 + ctt*tzz btw(2,1)= btw(1,2) ! update h-accumulation do 950 l = 1,2 do 950 i = 1,2 do 950 j = 1,2 h(i,j,l) = h(i,j,l) + btw(i,j)*nm(l,k) 950 continue ! ! accumulate - sum a(k) * int( rho * rho * (1/r) dv ) ! k aipsrr(1,1) = aipsrr(1,1) + d(k) * btw(1,1) aipsrr(1,2) = aipsrr(1,2) + d(k) * btw(1,2) aipsrr(2,2) = aipsrr(2,2) + d(k) * btw(2,2) ! update km1 990 km1 = mod(km1,n) + 1 1000 continue 1100 continue ! get doublet cubic terms if required if ( nf .lt. 10 ) go to 1310 ! int ( rho(*) grad(psi) ) ds btw(1,1)= -saic(2,2) btw(1,2)= -saic(2,3) btw(2,1)= -saic(3,2) btw(2,2)= -saic(3,3) ! int ( rho(*) psi ) ds bv(1) = saic(4,2) bv(2) = saic(4,3) ! update h do 1210 ik = 1,2 do 1210 j = 1,2 h(ik,j,ik) = h(ik,j,ik) - bv(j) 1210 continue do 1220 jk = 1,2 do 1220 i = 1,2 h(i,jk,jk) = h(i,jk,jk) - bv(i) 1220 continue if( .not. doublt ) go to 1305 daic(1,7)= -.5d0*h(1,1,1) daic(1,8)= -.5d0*( h(1,1,2) + h(1,2,1) + h(2,1,1) ) daic(1,9)= -.5d0*( h(2,2,1) + h(2,1,2) + h(1,2,2)) daic(1,10)= -.5d0*h(2,2,2) ! daic(2,7) = -.5d0*x*btw(1,1) daic(2,8) = -.5d0*x*( btw(1,2)+btw(2,1) ) daic(2,9) = -.5d0*x*btw(2,2) ! do 1250 j = 8,10 1250 daic(3,j) = daic(2,j-1) ! do 1300 j = 7,10 1300 daic(4,j) = (x/3.d0)*daic(1,j) 1305 continue ! quadratic source terms saic(1,4) = .5d0*x*saic(2,2) saic(1,5) = x*saic(2,3) saic(1,6) = .5d0*x*saic(3,3) ! saic(2,4) = -.5d0*h(1,1,1) saic(2,5) = - h(1,1,2) saic(2,6) = -.5d0*h(1,2,2) ! saic(3,4) = -.5d0*h(1,1,2) saic(3,5) = - h(1,2,2) saic(3,6) = -.5d0*h(2,2,2) ! saic(4,4) = p166 * ( aipsrr(1,1) - xsq*btw(1,1) ) saic(4,5) = p33 * ( aipsrr(1,2) - xsq*btw(1,2) ) saic(4,6) = p166 * ( aipsrr(2,2) - xsq*btw(2,2) ) 1310 continue ! apply factor of 1/(2*pi) ! (use 1/(4*pi) if on panel) fn = twopin if ( xeqzro .and. within ) fn = .5d0*fn ! apply source factor, -1/beta sn = -fn*btinv call vmul (saic,sn,saic,4*ng) call vmul (daic,fn,daic,4*nf) ! translate aic"s from the mach cone ! centered coordinate system to the ! panel*s origin ! sources ideg = 1 if ( nf.gt.6 ) ideg = 2 call shftic (saic,4,ideg,p(1),p(2)) ! doublets if ( .not.doublt ) go to 1810 ideg = 2 if ( nf .gt. 6 ) ideg = 3 call shftic (daic,4,ideg,p(1),p(2)) 1810 continue 3000 continue return ! ! fatal error encountered. dump input and abort 7000 continue write (6,7100) 7100 format (44h fatal error in aicsup, input data follows ) write (6,20) n,doublt,x,(i,p(i),(q(i,j),j=1,4),i=1,2) stop 1505 ! ! variable definitions ! ! input variables, /supdta/ ! doublt logical variable, if true, compute daic ! n number of corner points on the panel sigma ! p(*) coordinates of the field point"s projection on the ! plane of sigma, local coordinates ! q(*,k) coordinates of the corner points on the panel sigma ! (local coordinates) ! x downstream distance of field point, local coordinate ! ! output variables, s and d aic*s ! daic doublet aic matrix ! saic source aic matrix ! ! local real variables ! d(k) distance from center to edge k. ! d(k) = ( rho(*,k), nm(*,k)) ! nm(*,k) normal vector for edge k, equal to (tg(2,k),-tg(1,k) ! phi(k) = phase( (vp(k)*vm(k)+r(k)*r(k-1)), ! (r(k)*vm(k)-r(k-1)*vp(k)) ) ! qprm(k) = phase( d(k)*d(k+1)- x*x*(tg(*,k),tg(*,k+1)), ! x*r(k)*( tg(*,k) x tg(*,k+1) ) ) ! r(k) = sqrt ( x**2 - rhosq(k) ) when defined ! rho(*,k) vector from center of mach cone to corner k ! rho(*,k) = q(*,k) - p(*) ! rhosq(k) the square of rho(*,k) ! tg(*,k) tangent vector for edge k, the normalization of ! q(*,k) - q(*,k-1) ! vm(k) distance along edge k of its initial point ! vm(k) = ( tg(*,k), rho(*,k-1)) ! vp(k) distance along edge k of its end point ! vp(k) = ( tg(*,k), rho(*,k) ) ! ! local logical variables ! convex = true if sigma is convex. sigma will be convex ! if all turning angles alfa(k) are positive. ! sin(alfa(k)) = tg(*,k) x tg(*,k+1) ! corner(k) = true if corner k lies inside c ! edge(k) = true if edge k has points lying within c ! intsct = true if any of sigma"s boundary points lies ! inside c . intsct = or ( edge(k) ) ! within = true if p lies inside sigma ! xeqzro = true if x (q.v.) is identically zero END Subroutine AicSup ! **deck avg2pt subroutine avg2pt (za,zb,zavg) implicit double precision (a-h,o-z) dimension za(3), zb(3), zavg(3) ! ! compute the average of two points in 3-space ! zavg(1) = .5d0*( za(1) + zb(1) ) zavg(2) = .5d0*( za(2) + zb(2) ) zavg(3) = .5d0*( za(3) + zb(3) ) return END subroutine avg2pt ! **deck bconcl subroutine bconcl (mapbc,locsrt,keyloc,maps & & ,locs,mapb,iflgsp,nedaba & & ,kfdseg,kfdkey,kfdsgn,iedgtp & & ,mtchab,kptlm,ksgnlm,isngpk & & ,map1,map2,map3,jcnb,ijfnk & & ,almval,vpmfg,amu,dcpdn & & ,nctrw,nsngw,nabtw,nfdsw,mxmn,mxmnfg) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to eliminate redundant boundary condition defining quantities* ! * for coincident control points. then to process user specified* ! * boundary condition options and print boundary condition * ! * defining quantities if desired. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * the loop 100 sets the boundary condition network indices * ! * assuming redundant specification for coincident control * ! * points per input instructions. the loop 200 determines and * ! * writes on a sequential file boundary condition defining * ! * quantities for each distinct control point. finally the loop * ! * 300 processes user specified options for each boundary * ! * condition and writes the resultant boundary condition * ! * defining quantities back out on the original random file * ! * using the control point sequence number as an index. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bet /bcond/ input boundary condition (multiple) * ! * right hand side values * ! * * ! * bet1 /bcon/ in/output first boundary condition * ! * (multiple) right hand side * ! * values * ! * * ! * bet2 /bcon/ in/output second boundary condition * ! * (multiple) right hand side * ! * values * ! * cl /bcond/ input boundary condition coefficient* ! * of lower surface perturbation * ! * normal mass flux * ! * * ! * cl1 /bcon/ in/output first boundary conidition * ! * coefficient of lower surface * ! * perturbation normal mass flux * ! * * ! * cl2 /bcon/ in/output second boundary condition * ! * coefficient of lower surface * ! * perturbation normal mass flux * ! * * ! * cu /bcond/ input boundary condition coefficient* ! * of upper surface perturbation * ! * normal mass flux * ! * * ! * cu1 /bcon/ in/output first boundary condition * ! * coefficient of upper surface * ! * perturbation normal mass flux * ! * * ! * cu2 /bcon/ in/output second boundary condition * ! * coefficient of upper surface * ! * perturbation normal mass flux * ! * * ! * dl /bcond/ input boundary condition coefficient* ! * of lower surface perturbation * ! * potential * ! * * ! * dl1 /bcon/ in/output first boundary condition * ! * coefficient of lower surface * ! * perturbation potential * ! * * ! * dl2 /bcon/ in/output second boundary condition * ! * coefficient of lower surface * ! * perturbation potential * ! * * ! * du /bcond/ input boundary condition coefficient* ! * of upper surface perturbation * ! * potential * ! * * ! * du1 /bcon/ in/output first boundary condition * ! * coefficient of upper surface * ! * perturbation potential * ! * * ! * du2 /bcon/ in/output second boundary condition * ! * coefficient of upper surface * ! * perturbation potential * ! * * ! * iacase /acase/ -local- index of loop over cases * ! * * ! * jc -local- - - - - overall control point index * ! * * ! * jck -local- - - - - control point index within * ! * network * ! * * ! * jzc /cntrq/ input cumulative row/column index * ! * of zc in network kc * ! * * ! * k -local- - - - - network index * ! * * ! * kc /cntrq/ input network on which zc lies * ! * * ! * nacase /acase/ input number of freestream cases * ! * for simultaneous solution * ! * * ! * nbc /index/ -local- number of boundary condition * ! * records for each network * ! * * ! * nbca /index/ output cumulative sum of nbc * ! * * ! * nbcot /index/ output total number of boundary * ! * conditions * ! * * ! * nbdq /brwi/ input number of boundary condition * ! * defining quantities per block * ! * * ! * nct /bcond/ input boundary condition left hand * ! * side coefficient descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * nct1 /bcon/ in/output first boundary condition left * ! * hand side coefficient * ! * descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * nct2 /bcon/ in/output second boundary condition left* ! * hand side coefficient * ! * descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * * ! * nlopt /bcond/ input indicator governing left hand * ! * side coefficient selection * ! * nlopt1 /bcon/ input first boundary condition * ! * left hand side coefficient * ! * option indicator * ! * * ! * nlopt2 /bcon/ input second boundary condition * ! * left hand side coefficient * ! * option indicator * ! * * ! * nm /index/ input array containing number of * ! * rows in each network corner * ! * point grid * ! * * ! * nn /index/ input array containing number of * ! * columns in each network * ! * corner point grid * ! * * ! * nnett /index/ input total number of networks * ! * * ! * nropt /bcond/ input indicator governing right hand* ! * side value selection * ! * * ! * nropt1 /bcon/ input first boundary condition * ! * right hand side value * ! * option indicator * ! * * ! * nropt2 /bcon/ input second boundary condition * ! * right hand side value * ! * option indicator * ! * * ! * ntd /index/ input array containing network * ! * doublet types * ! * * ! * nts /index/ input array containing network * ! * source types * ! * * ! * tl /bcond/ input boundary condition coefficient* ! * vector of lower surface per- * ! * turbation tangential velocity * ! * * ! * tl1 /bcon/ in/output first boundary condition * ! * coefficient vector of lower * ! * surface perturbation * ! * tangential velocity * ! * * ! * tl2 /bcon/ in/output second boundary condition * ! * coefficient vector of lower * dimension & & mapbc(nctrw), locsrt(4*nsngw),keyloc(nsngw), maps(nsngw) & & , locs(4*nsngw), mapb(nsngw), iflgsp(nsngw), nedaba(nabtw+1)& & , kfdseg(4*nfdsw), kfdkey(nfdsw), kfdsgn(nfdsw), iedgtp(601) & & , mtchab(4,nabtw), kptlm(nsngw), ksgnlm(nsngw), isngpk(4*nsngw)& & , map1(mxmnfg), map2(mxmnfg), map3(mxmnfg), jcnb(nsngw) & & , ijfnk(nsngw) & & , almval(4*mxmn), vpmfg(3,2*mxmnfg),amu(mxmnfg), dcpdn(2*mxmn) ! * surface perturbation * ! * tangential velocity * ! * * ! * tu /bcond/ input boundary condition coefficient* ! * vector of upper surface per- * ! * turbation tangential velocity * ! * * ! * tu1 /bcon/ in/output first boundary condition * ! * coefficient vector of upper * ! * surface perturbation * ! * tangential velocity * ! * * ! * tu2 /bcon/ in/output second boundary condition * ! * coefficient vector of upper * ! * surface perturbation * ! * tangential velocity * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call bcon common /bcon/ & & cu1,cl1,tu1(3),tl1(3),du1,dl1,bet1(4),nct1,nlopt1,nropt1,necpt1 & & ,klopt1,kldum1,betin1(4) & & ,cu2,cl2,tu2(3),tl2(3),du2,dl2,bet2(4),nct2,nlopt2,nropt2,necpt2 & & ,klopt2,kldum2,betin2(4) & & ,ndbcon !end bcon !call bcond common /bcond/ & & cu,cl,tu(3),tl(3),du,dl,bet(4),nct,nlopt,nropt,necpt & & ,klopt,kldum,betin(4) & & ,nbin !end bcond !call brwi parameter (nsbp=6) common/brwi/nbdq,nsb,nrb,ntb,nnb,nib((maxcp+nsbp-1)/nsbp+1) !end brwi !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call irwi common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21) !end irwi !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !call lndblx ! /lndblx/ common /lndblx/ genwak(3,mxnett), slndbl(mxnett) & & , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett) !end lndblx !ca lfqprm ! /lfqprm/ ! major flags for controlling the low-frequency features ! mlofrq = 0, normal run ! = 1, ph/0 run, low frequency theory ! = 2, (d/dt) ph/0 run, low frequency theory ! = 3, ph/1,h run, low frequency theory ! adjgeo = .true., include ztz corrections in geometry ! (full low frequency theory) ! = .false., do not include ztz corrections in geometry, ! (linearized low frequency theory) ! adjwak = .true., adjust wake zeta's, fixing trailing edges ! .false., accept user's values of wake zeta's as given ! inczex = .true., include zeta terms for nropt =4,9 (exhaust bc's) ! = .false., exclude zeta terms for nropt =4,9 ! lfqind controls the type of processing done and implies that ! mlofrq will take on certain values ! lfqind = 0, standard a502 run; mlofrq = 0 [bconcl] ! = 1, low frequency theory with current geometry ! mlofrq = 1 [bconcl]; 2,3 [lfqg23] ! = 2, low frequency theory with linearized solution ! mlofrq = 0 [bconcl]; 1,2,3 [lfq123] common /lfqprm/ mlofrq, adjgeo, adjwak, inczex & & , lfqind logical adjgeo, adjwak, inczex ! !end lfqprm logical genmap dimension locpak(4), zk(3), zl(3) dimension locw(4) !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call indxsp common /indxsp/ nxsptt, nxspa(151), locxsp(1200) & & , ngsptt, ngspa(151), locgsp(1200) !end indxsp !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !ca jrwi ! /jrwi/ common /jrwi/ njdq, ntj, nnj, nij(maxcp+2) !end jrwi !ca stparm ! /stparm/ common /stparm/ smach, salpha, sbeta, tscst(5), wst(4) !end stparm !ca outdat ! /outdat/ logical lstdy common/outdat/iflag,lstdy !end outdat dimension nabc(150) dimension nsu(150), ndu(150), nbceqn(150) dimension bcond1(46), bcond2(46) dimension jcmult(400), betxa(4), betxb(4), betn(4) integer itnwfg(4), nwjit(4) integer icntyp(4) !call vicovr ! override vic specifications /vicovr/ common /vicovr/ nedflt(mxnett) ! /vicovr/ !end vicovr !call cumabc ! /cumabc/ ! cumulative bc count, used in bconcl common /cumabc/ nabca(151) !end cumabc ! ! ! rewind 93 call xtrns (31,mapbc,nctrn) call xtrns (5,kfdkey,nfdseg) call xtrns (6,kfdsgn,nfdseg) call xtrns ( 7,kfdseg,nx7) nfdseg = nx7/4 call xtrns (16,nedaba,nx16) nabt = nx16 - 1 call xtrns (26,maps,nsngn) call xtrns (27,locs, nx27) call xtrns (28,locsrt,nx28) nsngn = nx28/4 call xtrns (29,keyloc,nsngn) call xtrns (18,iedgtp,nedgt) call xtrns (17,mtchab,nx17) write (6,'( '' nctrw nsngw nabtw nfdsw nnett '',/,5i7 & & ,/, '' nctrn nsngn nabt nfdseg nedgt '',/,5i7 & & ,/, '' nx7 nx17 nx27 nx28 '',/,5i7 )') & & nctrw, nsngw, nabtw, nfdsw, nnett & & , nctrn, nsngn, nabt, nfdseg,nedgt & & , nx7, nx17, nx27, nx28 if ( nctrn.gt.nctrw .or. & & nx28.gt.4*nsngw .or. & & nsngn.gt.nsngw .or. & & nx27.gt.4*nsngw .or. & & nabt.gt.nabtw .or. & & nx7.gt.4*nfdsw .or. & & nfdseg.gt.nfdsw .or. & & nedgt.gt.4*nnett .or. & & nx17.gt.4*nabtw .or. & & nsngt.gt.nsngw ) then call a502er ('bconcl','array overflow during mapping') CALL AbortPanair('bconcl-1') endif ! do 20 i = 1,nsngt iflgsp(i) = 0 kptlm(i) = i ksgnlm(i) = 1 20 continue ! ibctot = 0 do 100 jc = 1,nctrt call ctrns (jc,zc) call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) if ( jzc .lt. 0 ) go to 50 call mnmod (jzc,nm(kc)+1,mzc,nzc) icnaif = jzc if ( nts(kc).eq.0 .and. ( ntd(kc).eq.8 .or. & & ntd(kc).eq.10 .or. & & ntd(kc).eq.18 .or. & & ntd(kc).eq.20 )) icnaif = nzc if ( (ntd(kc).eq.10 .or. ntd(kc).eq.20) .and. icnaif.gt.1 ) & & call abtjob('bconcl','program bug: bad c.p. index on wake-2') ica = icnaif + nbca(kc) call btrns (ica,cu1) if ( necpt1.ne.0 ) necpt1 = iabs( mapbc( necpt1 ) ) if ( necpt2.ne.0 ) necpt2 = iabs( mapbc( necpt2 ) ) go to 90 ! 50 continue call mnmod (ijfgc, 2*nm(kc)-1, ifn, jfn) icrs = (ifn+1)/2 jcrs = (jfn+1)/2 if ( icrs .eq. 1 ) go to 61 if ( jcrs .eq. nn(kc) ) go to 62 if ( icrs .eq. nm(kc) ) go to 63 if ( jcrs .eq. 1 ) go to 64 call errmsg ('extra control pt not on edge') ! 61 continue icp1 = 1 jcp1 = (jfn+1)/2 icp2 = 1 jcp2 = (jfn+3)/2 icrs1 = 1 jcrs1 = jcrs - 1 icrs2 = 1 jcrs2 = jcrs + 1 go to 70 ! 62 continue icp1 = (ifn+1)/2 jcp1 = nn(kc)+1 icp2 = (ifn+3)/2 jcp2 = nn(kc)+1 icrs1 = icrs - 1 jcrs1 = nn(kc) icrs2 = icrs + 1 jcrs2 = nn(kc) go to 70 ! 63 continue icp1 = nm(kc)+1 jcp1 = (jfn+1)/2 icp2 = nm(kc)+1 jcp2 = (jfn+3)/2 icrs1 = nm(kc) jcrs1 = jcrs - 1 icrs2 = nm(kc) jcrs2 = jcrs + 1 go to 70 ! 64 continue icp1 = (ifn+1)/2 jcp1 = 1 icp2 = (ifn+3)/2 jcp2 = 1 icrs1 = icrs - 1 jcrs1 = 1 icrs2 = icrs + 1 jcrs2 = 1 go to 70 ! 70 continue call cmngrd (kc,mcpnet,ncpnet) ica1 = icp1 + (jcp1-1)*mcpnet + nbca(kc) ica2 = icp2 + (jcp2-1)*mcpnet + nbca(kc) call btrns (ica1,bcond1) call btrns (ica2,bcond2) lcp1 = icrs1 + (jcrs1-1)*nm(kc) + nza(kc) lcp2 = icrs2 + (jcrs2-1)*nm(kc) + nza(kc) lcp = icrs + (jcrs -1)*nm(kc) + nza(kc) call distnc (zm(1,lcp),zm(1,lcp1),dst1) call distnc (zm(1,lcp),zm(1,lcp2),dst2) wgt1 = dst2/(dst1+dst2) wgt2 = dst1/(dst1+dst2) if ( iextrp.eq.0 ) go to 80 write (6,'(1x,a10,1x, 4i12)') & & 'jzc,kc,ic*',jzc,kc,ica1,ica2 write (6,'(1x,a10,1x, 2i12,2f12.6,3i12)') & & 'f-g,wgt*',ifn,jfn,wgt1,wgt2,lcp,lcp1,lcp2 write (6,'(1x,a10,1x, 6i12)') & & 'cp-grid',ifn,jfn,icp1,jcp1,icp2,jcp2 write (6,'(1x,a10,1x, 6i12)') & & 'crs-grid',icrs,jcrs,icrs1,jcrs1,icrs2,jcrs2 80 continue call xbcncl (nbdq, wgt1,bcond1, wgt2,bcond2) go to 90 ! 90 continue write(93) cu1,cl1,tu1,tl1,du1,dl1,bet1,nct1,nlopt1,nropt1,necpt1 & & ,klopt1,betin1 & & ,cu2,cl2,tu2,tl2,du2,dl2,bet2,nct2,nlopt2,nropt2,necpt2 & & ,klopt2,betin2 ! ibc1 = 0 ibc2 = 0 if ( nlopt1.ne.0 ) ibctot = ibctot + 1 if ( nlopt1.ne.0 ) ibc1 = ibctot if ( nlopt2.ne.0 ) ibctot = ibctot + 1 if ( nlopt2.ne.0 ) ibc2 = ibctot 6001 format (1x,'options',2x,4i4, 5x,4i4, 5x,4i4) 100 continue ! rewind 93 nabca(1) = 0 nbcd2 = nbdq/2 ibctot = 0 ncmult = 0 do 300 k = 1,nnett mn = nm(k)*nn(k) mnpan = (nm(k)-1)*(nn(k)-1) mnfg = (2*nm(k)-1)*(2*nn(k)-1) call dcopy (4*mnpan, 0.d0,0, almval,1) call dcopy (6*mnfg, 0.d0,0, vpmfg,1) call dcopy (mnfg, 0.d0,0, amu,1) call dcopy (2*mnpan, 0.d0,0, dcpdn,1) nabck = 0 jc1 = nca(k) + 1 jc2 = nca(k+1) do 250 jc = jc1,jc2 call ctrns (jc,zc) call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) read (93) cu1,cl1,tu1,tl1,du1,dl1,bet1,nct1,nlopt1,nropt1,necpt1 & & ,klopt1,betin1 & & ,cu2,cl2,tu2,tl2,du2,dl2,bet2,nct2,nlopt2,nropt2,necpt2 & & ,klopt2,betin2 nbcd2 = nbdq/2 klopt1 = nlopt1 klopt2 = nlopt2 call dcopy (ityprc*nacase, bet1,1, betin1,1) call dcopy (ityprc*nacase, bet2,1, betin2,1) ! call icopy (nbcd2, cu1,1, cu,1) if ( mlofrq.eq.0 ) then call bcopt else endif call icopy (nbcd2, cu,1, cu1,1) ! call icopy (nbcd2, cu2,1, cu,1) if ( mlofrq.eq.0 ) then call bcopt else endif call icopy (nbcd2, cu,1, cu2,1) ! determine which bc any matching condi ! should over-ride if ( kabmtc.ne.0 .and. zdc.le.0.d0 ) call a502er ('bconcl' & & ,'kabmtc.ne.0 and zdc.le.0: incompatible') if ( kabmtc.eq.0 .and. zdc.gt.0.d0 ) call a502er ('bconcl' & & ,'kabmtc.eq.0 and zdc.gt.0: incompatible') if ( kabmtc.eq.0 ) go to 220 if ( nlopt1.ne.0 .and. nct1.ne.3 ) nbinmc = 1 if ( nlopt2.ne.0 .and. nct2.ne.3 ) nbinmc = 2 if ( nbinmc.eq.0 ) call a502ms ('bconcl' & & ,'no bc available for override by matching') if ( nbinmc.eq.0 ) go to 220 if ( nbinmc.eq.2 ) go to 215 ! nbinmc = 1, override bc no. 1 nlopt1 = 8 if ( zdc.eq. 5.d0 ) nlopt1 = 9 nropt1 = 2 nct1 = 4 call zero (bet1,ityprc*nacase) go to 220 ! nbinmc = 2, override bc no. 2 215 continue nlopt2 = 8 if ( zdc.eq. 5.d0 ) nlopt2 = 9 nropt2 = 2 nct2 = 4 call zero (bet2,ityprc*nacase) go to 220 ! 220 continue ! delete redundant singularity paramete ! associated with exact matching of one ! or two networks. call sngdel (nedaba,kfdseg,kfdkey,kfdsgn & & ,locsrt,keyloc,maps,iflgsp & & ,kptlm,ksgnlm) ! count required ic rows: nec indphi = 0 indvel = 0 ipotk = ipot(kc) iapotk = iabs(ipotk) do 240 nbin = 1,2 if ( nbin.eq.1 ) call icopy (nbcd2, cu1,1, cu,1) if ( nbin.eq.2 ) call icopy (nbcd2, cu2,1, cu,1) if ( nlopt.eq.0 ) go to 240 if ( nbin.ne.nbinmc ) go to 230 ! nbin = nbinmc ! ********* if ( (idcpmc.ge.1 .and.idcpmc.le.3) .and. if ( (idcpmc.eq.2 .or. idcpmc.eq.3) .and. & & (iapotk.eq.0 .or. iapotk.eq.1 .or. iapotk.eq.3) ) & & indvel = 1 go to 240 ! nbin.ne.nbinmc 230 continue if ( nlopt.eq.5 .or. nlopt.eq.9 ) go to 240 indphi = 1 if ( nct.eq.4 .and. (iapotk.eq.2 .or. iapotk.eq.4) ) & & go to 240 indvel = 1 240 continue ! nec = 0 if ( indphi.ne.0 ) nec = 1 if ( indvel.ne.0 ) nec = 4 nec = max ( nec, nedflt(kc) ) if ( nlopt1 .ne. 0 ) nabck = nabck + 1 if ( nlopt2 .ne. 0 ) nabck = nabck + 1 ! ibc1 = 0 ibc2 = 0 if ( nlopt1.ne.0 ) ibctot = ibctot + 1 if ( nlopt1.ne.0 ) ibc1 = ibctot if ( nlopt2.ne.0 ) ibctot = ibctot + 1 if ( nlopt2.ne.0 ) ibc2 = ibctot izdc = zdc ! ! check for a multi-nw bc at this c.p. ! if ( kabmtc.ge.0 .or. (idcpmc.ne.2 .and. idcpmc.ne.3) )go to 245 ncmult = ncmult + 1 if(ncmult.gt.400) call a502ms ('bconcl' & & ,'too many multi-nw bc-s in this case ') if ( ncmult.gt.400 ) go to 245 jcmult(ncmult) = jc 245 continue call ibtrns (jc,cu1) call ictrns (jc,zc) 250 continue nabc(k) = nabck 6003 format (80x,'after nw',i5,' having',i5,' aic rows,',i5,' cum') 300 continue ! nabca(1)= 0 do 310 k = 1,nnett nabca(k+1) = nabca(k) + nabc(k) 310 continue nbcot = nabca(nnett+1) if ( iextrp.eq.0 ) go to 320 call outvci ('kptlm',nsngt,kptlm) call outvci ('ksgnlm',nsngt,ksgnlm) call outvci ('iflgsp',nsngt,iflgsp) 320 continue ! ! define beta values for multi-network b.c.'s ! if ( ncmult.gt.0 ) write (6,6013) 6013 format (//,15x,'right hand side computation for multi-network' & & ,' boundary conditions' & & ,//,10x,2x,'abmt',6x,'nearest wake control point preceeding',2x & & ,6x,'nearest wake control point following ',2x & & ,/,8x,'jc',3x,'tau',4x,'jc1',2x,'tau1',14x,'bet1',14x & & ,4x,'jc2',2x,'tau2',14x,'bet2',14x & & ,/,8x,'--',3x,'---',4x,'---',2x,'----',3x,'---------------' & & ,'--------------' & & ,4x,'---',2x,'----',3x,'---------------' & & ,'--------------' & & ) ! loop over the multi-network bc's ! extracting the betn values from ! the appropriate bet values specified ! for the wake network do 350 imult = 1,ncmult jc = jcmult(imult) call ctrns (jc,zc) taucrt = tauc jccrt = jc nbcrt = nbinmc iabt = iabs(kabmtc) ! get fund. seg. and other properties ! of the wake network involved kwfsg = mtchab(2,iabt) call icopy (4, kfdseg(4*(kwfsg)-3),1, kokseg,1) kfn1 = 2*i1kseg-1 kfn2 = 2*i2kseg-1 call mnmod (kedseg,4,kwsd,kwnet) jc1 = nca(kwnet) + 1 jc2 = nca(kwnet+1) taua = -.1d0 taub = 1.1d0 inda = 0 indb = 0 mfn = 2*nm(kwnet) - 1 nfn = 2*nn(kwnet) -1 ! loop over wake control points looking ! for control points along appropriate ! fundamental segment do 330 jc = jc1,jc2 call ctrns (jc,zc) call mnmod (ijfgc,mfn,ifn,jfn) if ( kwsd.eq.1 .and. ifn.ne.1 ) go to 330 if ( kwsd.eq.2 .and. jfn.ne.nfn ) go to 330 if ( kwsd.eq.3 .and. ifn.ne.mfn ) go to 330 if ( kwsd.eq.4 .and. jfn.ne.1 ) go to 330 if ( kwsd.eq.1 ) kfn = jfn if ( kwsd.eq.2 ) kfn = ifn if ( kwsd.eq.3 ) kfn = nfn + 1 - jfn if ( kwsd.eq.4 ) kfn = mfn + 1 - ifn if ( kfn.le.kfn1 .or. kfn.ge.kfn2 ) go to 330 ! found a control pt on target fund. ! seg. bracket taucrt. call btrns (jc,cu1) ! if tauc .le. taucrt, set lower limit if ( tauc.gt.taucrt ) go to 325 if ( tauc.lt.taua ) go to 325 if ( klopt1.eq.16 .or. klopt1.eq.17 ) & & call dcopy (ityprc*nacase, betin1,1, betxa,1) if ( klopt2.eq.16 .or. klopt2.eq.17 ) & & call dcopy (ityprc*nacase, betin2,1, betxa,1) taua = tauc inda = jc 325 continue ! if tauc .ge. taucrt, set upper limit if ( tauc.lt.taucrt ) go to 327 if ( tauc.gt.taub ) go to 327 if ( klopt1.eq.16 .or. klopt1.eq.17 ) & & call dcopy (ityprc*nacase, betin1,1, betxb,1) if ( klopt2.eq.16 .or. klopt2.eq.17 ) & & call dcopy (ityprc*nacase, betin2,1, betxb,1) taub = tauc indb = jc 327 continue 330 continue ! cp's inda & inda on wk bracket jccrt write (6,6012) imult,jccrt,taucrt,inda,taua,betxa,indb,taub,betxb 6012 format (1x,i3,1h.,i5,f6.3,2x,i5,f6.3,4f8.3,2x,i5,f6.3,4f8.3) if ( inda.eq.0 .and. indb.eq.0 ) call a502ms ('bconcl' & & ,'multi-nw boundary condition error') ! reset bet values for cp jccrt via ! copying or via linear interpolation call btrns (jccrt,cu1) call dcopy (ityprc*nacase, betxa,1, betn,1) if ( inda.eq.0 ) call dcopy (ityprc*nacase, betxb,1, betn,1) if ( inda.eq.indb .or. taua.eq.taub ) go to 341 if ( inda.eq.0 .or. indb.eq.0 ) go to 341 wa = (taucrt-taub)/(taua-taub) wb = (taua-taucrt)/(taua-taub) do 340 ia = 1,nacase betn(ia) = wa*betxa(ia) + wb*betxb(ia) 340 continue 341 continue if ( nbinmc.eq.1 ) call dcopy (ityprc*nacase, betn,1, bet1,1) if ( nbinmc.eq.2 ) call dcopy (ityprc*nacase, betn,1, bet2,1) call ibtrns (jccrt,cu1) 350 continue ! ! count the various types of s.p.'s ! also, flag equivalence classes of ! null singularity parameters by settin ! iflgsp(lbasic) = 3 for each basic s.p ! that is null init = 1 390 continue do 400 i = init,nsngt isv = i if ( kptlm(i) .gt. 0 ) go to 410 400 continue ! all done. restore kptlm and proceed ! to next phase do 405 i = 1,nsngt kptlm(i) = iabs(kptlm(i)) 405 continue go to 600 ! 410 continue call jzero (icntyp,4) icntot = 0 init = isv kpt = init nloop = 0 ! 420 continue ityp = iflgsp(kpt) icntyp(ityp+1) = icntyp(ityp+1) + 1 icntot = icntot + 1 kptn = kptlm(kpt) kptlm(kpt) = -kptlm(kpt) kpt = kptn nloop = nloop + 1 if ( kpt.lt.1 .or. kpt.gt.nsngt .or. nloop.gt.nsngt+2 ) & & call abtmsg ('bconcl/2 infinite loop trap') if ( kpt .ne. isv ) go to 420 ! nku = icntyp(1) + icntyp(2) neqv = icntyp(3) nzro = icntyp(4) if ( nku.gt.0 .and. nzro.gt.0 ) go to 425 if ( nku.gt.1 ) go to 425 if ( nku.ne.1 .and. neqv.gt.0 .and. nzro.eq.0 ) go to 425 go to 429 ! 425 continue write (6,6011) init, icntyp 6011 format (' init, icntyp ',5i6) call a502ms ('bconcl' & & ,'bad equivalence class of s.p.-s found ') ! ! ! 429 continue if ( icntyp(4) .eq. 0 ) go to 440 kpt = isv call jzero (icntyp,4) icntyp(4) = icntot nloop = 0 430 continue iflgsp(kpt) = 3 kpt = iabs( kptlm(kpt) ) nloop = nloop + 1 if ( kpt.lt.1 .or. kpt.gt.nsngt .or. nloop.gt.nsngt+2 ) & & call abtmsg ('bconcl/3 infinite loop trap') if ( kpt .ne. isv ) go to 430 ! 440 continue go to 390 ! ! ! ! ! now account for all known s.p.'s ! ! ! 600 continue nsngk = 0 do 700 jc = 1,nctrt call ctrns (jc,zc) call btrns (jc,cu1) do 650 isd = 1,2 nbin = 0 if ( nlopt1.eq.(4*isd+1) .and. necpt1.eq.0 ) nbin = nbin + 1 if ( nlopt2.eq.(4*isd+1) .and. necpt2.eq.0 ) nbin = nbin + 2 if ( nbin .eq. 3 ) go to 1400 if ( nbin .eq. 0 ) go to 650 call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) call spbsc (kc,ifn,jfn,isd, lbasic, locsrt,keyloc,maps) if ( lbasic.eq.0 ) go to 650 if ( iflgsp(lbasic).ne.0 ) go to 650 ! nsngk = nsngk + 1 iflgsp(lbasic) = -( 16*jc + 4*nbin + isd ) 650 continue 700 continue ! account for known s.p.'s of type mu/x do 710 knet = 1,nnett ntdk = ntd(knet) if ( ntdk.ne.18 .and. ntdk.ne.20 ) goto 710 l1 = nssa(knet) + 1 l2 = nssa(knet+1) do 705 l = l1,l2 call icopy (4, locsrt(4*l-3),1, locpak,1) isd = locpak(4) if ( isd.ne.3 ) goto 705 lnaif = keyloc(l) lbasic = maps(lnaif) nsngk = nsngk + 1 iflgsp(lbasic) = -( 16*(nctrt+1) + isd ) 705 continue 710 continue ! ! ! create isngpk(lbasic) containing ! (type . nw . smallest-ijfn . isd ) ! for each basic s.p. ! call jzero (isngpk,4*nsngt) do 750 lnaif = 1,nsngn call icopy (4, locs(4*(lnaif)-3),1, locpak,1) lnet = locpak(1) jfn = locpak(2) ifn = locpak(3) isd = locpak(4) ijfn = ifn + (jfn-1)*(2*nm(lnet)-1) lbasic = maps(lnaif) call icopy (4, isngpk(4*(lbasic)-3),1, itnwfg,1) if ( isngpk(4*lbasic-3).eq.0.and. & & isngpk(4*lbasic-2).eq.0.and. & & isngpk(4*lbasic-1).eq.0.and. & & isngpk(4*lbasic ).eq.0 ) go to 720 if ( itnwfg(3).lt.ijfn ) go to 750 ! 720 continue ityp = iflgsp(lbasic) if ( ityp.lt.0 ) ityp = 1 if ( ityp.gt.3 ) call uabend itnwfg(1) = ityp itnwfg(2) = lnet itnwfg(3) = ijfn itnwfg(4) = isd call icopy (4, itnwfg,1, isngpk(4*(lbasic)-3),1) 750 continue ! ! ! define the map, mapb of basic s.p. ! indices to final s.p. indices. updat ! the nlopt data on the btrns file ! to account for known s.p.'s ! call ishel2 (nsngt,isngpk,keyloc) call ukysr2 (nsngt,isngpk,keyloc) call jzero (nsu,nnett) call jzero (ndu,nnett) rewind 93 call jzero (icntyp,4) isngk = 0 do 900 is = 1,nsngt lbasic = keyloc(is) ityp = iflgsp(lbasic) iknown = iabs( ityp ) if ( ityp.lt.0 ) ityp = 1 if ( ityp.gt.3 ) call uabend icntyp(ityp+1) = icntyp(ityp+1) + 1 itf = ityp + 1 go to (800,810,820,830), itf ! unknown: type = 0 800 continue mapb(lbasic) = is call icopy (4, isngpk(4*(lbasic)-3),1, itnwfg,1) isd = itnwfg(4) lnet = itnwfg(2) if ( isd.eq.1 ) nsu(lnet) = nsu(lnet) + 1 if ( isd.eq.2 ) ndu(lnet) = ndu(lnet) + 1 go to 900 ! ! known: type = 1 810 continue mapb(lbasic) = is call icopy (4, isngpk(4*(lbasic)-3),1, itnwfg,1) lnet = itnwfg(2) isd = mod( iknown, 4) isngk = isngk + 1 if ( isd.ne.3 ) goto 815 ! special mu/x = const basic s.p. jc = nctrt+1 jcnb(isngk) = 3 + 4*( jc-1 + (lnet-1)*(nctrt+1) ) ijfnk(isngk)= itnwfg(3) amux = 0.d0 call dcopy (nacase, amux,0, bet1,1) write (93) bet1 ! check for errors nbinz = mod( jcnb(isngk), 4) jcnet = jcnb(isngk)/4 call mnmod (jcnet,nctrt+1,jczm,lnetz) jcz = jczm + 1 if ( nbinz.ne.3 .or. jc.ne.jcz .or. lnet.ne.lnetz ) & & call a502er ('bconcl','error in jcnb packing') goto 900 ! 815 continue isd = mod( iknown, 4) nbin = mod( iknown/4, 4) jc = iknown/16 jcnb(isngk) = nbin + 4*( jc-1 + (lnet-1)*(nctrt+1) ) ijfnk(isngk)= itnwfg(3) call btrns (jc,cu1) if ( nbin.eq.1 ) write (93) bet1 if ( nbin.eq.2 ) write (93) bet2 mapb(lbasic) = is if ( nbin .eq. 1 ) nlopt1 = 0 if ( nbin .eq. 2 ) nlopt2 = 0 call ibtrns (jc,cu1) ! check for errors nbinz = mod( jcnb(isngk), 4) jcnet = jcnb(isngk)/4 call mnmod (jcnet,nctrt+1,jczm,lnetz) jcz = jczm + 1 if ( nbinz.ne.nbin .or. jc.ne.jcz .or. lnet.ne.lnetz ) & & call a502er ('bconcl','error in jcnb packing') go to 900 ! ! equivalenced: type = 2 820 continue kpt = lbasic nloop = 0 825 continue kpt = kptlm(kpt) call icopy (4, isngpk(4*(kpt)-3),1, itnwfg,1) if ( itnwfg(1).eq.0 .or. itnwfg(1).eq.1 ) go to 827 nloop = nloop + 1 if ( kpt.ne.lbasic .and. nloop.lt.nsngt+2 ) go to 825 ! error detected write (6,'(1x,a10,1x, 3i12)') & & 'bconcl/4',kpt,lbasic,iflgsp(lbasic) CALL AbortPanair('bconcl-2') ! 827 continue isnew = mapb(kpt) if ( ksgnlm(kpt) .lt. 0 ) isnew = -isnew if ( ksgnlm(lbasic) .lt. 0 ) isnew = - isnew mapb(lbasic) = isnew go to 900 ! ! zeroed: type = 3 830 continue mapb(lbasic) = 0 go to 900 900 continue if ( isngk.ne.icntyp(2) ) call a502er ('bconcl' & & ,'count of known singularity parms inconsistent') ! ! ! define the various counts of singular izdc = zdc ! parameter types, nsgn* * = (u,k,e,z ! ! u = unknown, final (and basic) s.p. ! k = known, final (and basic) s.p.'s ! t = total, final s.p.'s t = u + k ! n = number of naive s.p.'s ! b = number of basic s.p.'s b = u+k ! e = number of equivalenced basic s. ! z = number of zeroed basic s.p.'s ! nsngu = icntyp(1) nsngk = icntyp(2) nsnge = icntyp(3) nsngz = icntyp(4) nsngb = nsngt nsngt = nsngu + nsngk write (6,6006) nsngn, nsngb, nsngu, nsngk, nsnge, nsngz, nsngt 6006 format ('0 singularity parameter counts ' & & ,/,' naive s.p. count (based on networking) ' ,i6 & & ,/,' basic s.p. count (duplicates squeezed out)' ,i6 & & ,/,' no. of unknown basic s.p.-s ' ,i6 & & ,/,' no. of known basic s.p.-s ' ,i6 & & ,/,' no. of equivalenced basic s.p.-s ' ,i6 & & ,/,' no. of zeroed basic s.p.-s ' ,i6 & & ,/,' final s.p. count ( known + unknown ) ' ,i6 & & ) ! ! define the map, maps of naive s.p. ! indices to final s.p. indices. this ! map is used in ffgen to update the ! s.p. index arrays iis and iid ! defining the spline dependencies. ! !--- call outvec ('naif/basic',nsngn,maps) do 910 lnaif = 1,nsngn lbasic = maps(lnaif) lfinal = mapb(lbasic) maps(lnaif) = lfinal 910 continue call icopy (4*nsngt, 0,0, locsrt,1) do 912 lnaif = 1,nsngn lfinal = maps(lnaif) if ( lfinal .le. 0 ) goto 912 if ( lfinal .gt. nsngt ) then CALL AbortPanair('bconcl-3') endif call icopy (4, locsrt(4*lfinal-3),1, locpak,1) call icopy (4, locs(4*lnaif-3),1, locw,1) if ( locpak(1).eq.0 ) goto 911 if ( locpak(1).gt.locw(1) ) goto 911 if ( locpak(1).lt.locw(1) ) goto 912 if ( locpak(2).gt.locw(2) ) goto 911 if ( locpak(2).lt.locw(2) ) goto 912 if ( locpak(3).gt.locw(3) ) goto 911 if ( locpak(3).lt.locw(3) ) goto 912 911 continue call icopy (4, locw,1, locsrt(4*lfinal-3),1) 912 continue write (89) nsngt,nsngu,nsngk write (89) (locsrt(i),i=1,4*nsngt) call ixtrns (35,locsrt,4*nsngt) ! ! generate summaries of b.c., aic, and ! information for each network ! ibctot = 0 ibcsav = 0 do 940 k = 1,nnett mfn = 2*nm(k) - 1 nfn = 2*nn(k) - 1 nbcwr = 0 if ( ibconp.ne.0 ) write (6,6005) k jc1 = nca(k) + 1 jc2 = nca(k+1) genmap = .true. nfingr = (2*nm(k)-1)*(2*nn(k)-1) if ( nfingr .gt. mxsngt ) genmap = .false. if ( genmap ) call jzero (map1,nfingr) if ( genmap ) call jzero (map2,nfingr) do 915 jc = jc1,jc2 call ctrns (jc,zc) call btrns (jc,cu1) call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) ibc1 = 0 ibc2 = 0 if ( nlopt1.ne.0 ) ibctot = ibctot + 1 if ( nlopt1.ne.0 ) ibc1 = ibctot if ( nlopt2.ne.0 ) ibctot = ibctot + 1 if ( nlopt2.ne.0 ) ibc2 = ibctot izdc = zdc if ( ibconp.eq.0 ) go to 913 ! *** if ( ibc1.eq.0 ) go to 913 if ( mod(nbcwr,25).eq.0 .and. nbcwr.ne.0 ) write (6,6005) k if ( mod(nbcwr,25).eq.0 ) write (6,6004) nbcwr = nbcwr + 1 int1 = 1 if ( nbinmc.eq.1 ) int1 = -1 write (6,6002) ibc1,jc,kc,ifn,jfn,nlopt1,nropt1,nct1,necpt1 & & ,izdc,kabmtc,cu1,cl1,tu1,tl1,du1,dl1 & & ,int1,nec,bet1 913 continue ! if ( ibconp.eq.0 ) go to 914 ! *** if ( ibc2.eq.0 ) go to 914 if ( mod(nbcwr,25).eq.0 .and. nbcwr.ne.0 ) write (6,6005) k if ( mod(nbcwr,25).eq.0 ) write (6,6004) nbcwr = nbcwr + 1 int2 = 2 if ( nbinmc.eq.2 ) int2 = -2 write (6,6002) ibc2,jc,kc,ifn,jfn,nlopt2,nropt2,nct2,necpt2 & & ,izdc,kabmtc,cu2,cl2,tu2,tl2,du2,dl2 & & ,int2,nec,bet2 914 continue ! if ( .not. genmap ) go to 915 ijfn = ifn + (jfn-1)*(2*nm(kc)-1) map1(ijfn) = ibc1 map2(ijfn) = ibc2 915 continue ! if ( .not.genmap ) go to 918 if ( ibcmap.eq.0 ) go to 918 ! print bc map header write (6,6007) k call outmti ('aic(bc1)',mfn,mfn,nfn,map1) call outmti ('aic(bc2)',mfn,mfn,nfn,map2) 918 continue if ( .not.genmap ) go to 940 ! control point map call jzero (map1,nfingr) do 925 jc = jc1,jc2 call ctrns (jc,zc) map1(ijfgc) = jc 925 continue if ( icpmap.eq.0 ) go to 926 ! print cp map header write (6,6008) k call outmti ('c.p. map',mfn,mfn,nfn,map1) 926 continue ! singularity parameter maps call jzero (map1,nfingr) call jzero (map2,nfingr) if ( genmap ) call jzero (map3,nfingr) kmap3 = 0 is1 = nssa(k) + 1 is2 = nssa(k+1) do 930 lnaif = is1,is2 call icopy (4, locs(4*(lnaif)-3),1, locpak,1) lnet = locpak(1) jfn = locpak(2) ifn = locpak(3) isd = locpak(4) ijfn = ifn + (jfn-1)*mfn lfinal = maps(lnaif) if ( isd.eq.1 ) map1(ijfn) = lfinal if ( isd.eq.2 ) map2(ijfn) = lfinal if ( isd.eq.3 ) map3(ijfn) = lfinal if ( isd.eq.3 ) kmap3 = kmap3 + 1 930 continue if ( ispmap.eq.0 ) go to 935 ! print sp map header write (6,6009) k lndb = 0 if ( lndb.ne.0 ) write (6,'(1x,a10,1x,i12,f12.6)') & & 'linear-mu',lndb,slndbl(k) call outmti ('src sp-s',mfn,mfn,nfn,map1) call outmti ('dbl sp-s',mfn,mfn,nfn,map2) if ( kmap3.gt.0 ) call outmti ('mux sp-s',mfn,mfn,nfn,map3) ! 935 continue nabck = ibctot - ibcsav ibcsav = ibctot write (6,6003) k,nabck,ibctot nbceqn(k) = nabck 940 continue nerr = 0 do 950 k = 1,nnett if ( nbceqn(k) .eq. nsu(k)+ndu(k) ) go to 950 write (6,6010) k, nsu(k), ndu(k), nbceqn(k) nerr = nerr + 1 ibconp = max ( 2, ibconp) call a502ms ('bconcl' & & ,'imbalance between aic rows and unknowns') 6010 format ('0 *** error *** imbalance between aics and singulari& &ty parameters for network',i4 ,/, & & 20x,' #source =',i4,' #doublet =',i4,' #aic rows =',i4) 950 continue if ( ibconp.lt.2 ) go to 960 call outvci ('nsu',nnett,nsu) call outvci ('ndu',nnett,ndu) call outvci ('nbceqn',nnett,nbceqn) 960 continue ! call ixtrns (36,mapb,nsngb) call ixtrns (37,maps,nsngn) call ixtrns (38,jcnb,nsngk) call ixtrns (39,ijfnk,nsngk) !--- call outvec ('naif/final',nsngn,maps) !--- call outvec ('basic/final',nsngb,mapb) rewind 93 ! ! ! return ! ! error conditions ! 1200 continue 1400 continue write (6,'(1x,a10,1x, 6i12)') & & 'bconcl/abt',init,isv,kpt,kptn,jc,nbin call outvci ('icntyp',4,icntyp) CALL AbortPanair('bconcl-4') 6002 format (1x,i4,i5,3i4,2i3,i2,i5 & & ,i3,i4,10f9.4 & & ,/,9x,i2,' ne',i2,25x,10f9.4 ) 6004 format (1h0,' aic jc nw ifn jfn nl nr ct jce zdc abut' & & ,4x,'cu',7x,'cl',6x,'tux',6x,'tuy',6x,'tuz' & & ,6x,'tlx',6x,'tly',6x,'tlz',7x,'du',7x,'dl' & & ,/,10x,'bc',35x,'bet1',5x,'bet2',5x,'bet3',5x,'bet4') 6005 format (1h1,10x,'boundary condition information for network',i4) 6007 format ('0 boundary condition maps for network :',i5) 6008 format ('0 control point map for network :',i5) 6009 format ('0 singularity parameter maps for network :',i5) END subroutine bconcl ! **deck bcopt subroutine bcopt implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * set boundary condition equation coefficients for either first* ! * or second boundary condition at a given control point. * ! * boundary condition equation is of the form * ! * cu*(vu,nc)+cl*(vl,nc)+(tu,vu)+(tl,vl)+du*pheu+dl*phel=bet * ! * where pheu (phel) is upper (lower) surface perturbation * ! * potential and vu (vl) is the upper (lower) surface * ! * perturbation velocity vector. nc is the upper surface * ! * co-normal vector and (a,b) is the usual vector inner product.* ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * current control point defining q8antities are stored in * ! * /cntrq/ and current (first or second) boundary condition * ! * defining quantities for current control point are stored in * ! * /bcond/. nlopt governs left hand side coefficient selection * ! * and nropt governs right hand side coefficient selection. * ! * subroutine sets left hand coefficients prior to statement 500* ! * and right hand coefficients after statement 500. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bet /bcond/ output boundary condition (multiple) * ! * right hand side coefficients * ! * * ! * betams /comprs/ input 1.-(freestream mach number)**2* ! * * ! * cl /bcond/ output boundary condition coefficient* ! * of lower surface perturbation * ! * normal mass flux * ! * * ! * compd /comprs/ input compressibility direction * ! * vector * ! * * ! * cu /bcond/ output boundary condition coefficient* ! * of upper surface perturbation * ! * normal mass flux * ! * * ! * dl /bcond/ output boundary condition coefficient* ! * of lower surface perturbation * ! * potential * ! * * ! * du /bcond/ output boundary condition coefficient* ! * of upper surface perturbation * ! * potential * ! * * ! * fsv /acase) input (multiple) freestream velocity* ! * vectors * ! * * ! * nbin /bcond/ input boundary condition flag * ! * =1 values refer to first * ! * boundary condition at * ! * control point * ! * =2 values refer to second * ! * boundary condition at * ! * control point * ! * * ! * nacase /acase/ input number of freestream casses * ! * * ! * nct /bcond/ output boundary condition left hand * ! * side coefficient descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * nlopt /bcond/ input indicator governing left hand * ! * side coefficient selection * ! * * ! * nropt /bcond/ input indicator governing right hand* ! * side value selection * ! * * ! * tl /bcond/ output boundary condition coefficient* ! * vector of lower surface per- * ! * turbation tangential velocity * ! * * ! * tu /bcond/ output boundary condition coefficient* ! * vector of upper surface per- * ! * turbation tangential velocity * ! * * ! * zc /cntrq/ input control point position in * ! * global coordinates * ! * * ! * zcs -local- - - - - co-position vector for control* ! * point * ! * * ! * zdc /cntrq/ input control point function flag * ! * =0. panel center control * ! * point with specified * ! * boundary conditions * ! * =-1. network edge control * ! * point with specified * ! * boundary conditions * ! * =1. to 4. * ! * network edge control * ! * point used to match * ! * doublet strength across * ! * respective network edge * ! * 1. to 4. * ! * * ! * znc /cntrq/ input upper surface normal at * ! * control point (in global * ! * coordinates) * ! * * ! * zncs -local- - - - - upper surface co-normal at * ! * control point (in global * ! * coordinates) * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call bcond common /bcond/ & & cu,cl,tu(3),tl(3),du,dl,bet(4),nct,nlopt,nropt,necpt & & ,klopt,kldum,betin(4) & & ,nbin !end bcond !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call pincl common/pincl/enx1,enx2,al1,al2 !end pincl !call curpan common/curpan/cpnorm(150) !end curpan !ca rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !ca glopar ! /glopar/ common /glopar/ omgbin, kontrl, inplot, ilstdy, ktype & & , icamax & & , kutflg(150) logical ilstdy !end glopar dimension betr(4), dbtdzr(3,5) dimension zcs(3),zncs(3),h(3) dimension vdif(3), dv(3), wfs(3) dimension tgv(3), znu(3) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp !c ! * ignore coefficients for null boundary condition * !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call nwkrgn ! /nwkrgn/ region information for the upper/lower nw surfaces ! zctrgn(3,k) zctr for each network ! ntrgn total number of regions ! kinrgn(i) starting pointer in kptrgn for region i ! nsfrgn(i) number of surfaces bounding region i ! isfrgn(nlop) gives surface on which bc nlop is applied (1=u ! indrgn(1:2,k) region index for nw surfaces (1=u,2=l; k=nw-in ! kptrgn(2*nnett) equivalence class pointer structure for nw sur ! kbcrgn(k) error counter for 4/9 b.c.'s on nw k common /nwkrgn/ zctrgn(3,2,150) & & , ntrgn, kinrgn(100), nsfrgn(100), isfrgn(0:25) & & , indrgn(2,150), kptrgn(2*150) & & , kbcrgn(150) !end nwkrgn dimension tg(3) dimension vfs(3,4), zmctr(3) ! ! express: znc = almnu*znu + tgv call dcip (znc,znc,znznu) call cmpscl (betams,compd,znc,znu) almnu = ddot(3, znc,1, znc,1)/znznu tgv(1) = znc(1) - almnu*znu(1) tgv(2) = znc(2) - almnu*znu(2) tgv(3) = znc(3) - almnu*znu(3) ! define upper and lower surface coeffi imatup = matnet(1,kc) imatlo = matnet(2,kc) akvu = vfmat(imatup) akvl = vfmat(imatlo) akwu = wfmat(imatup) akwl = wfmat(imatlo) akfsv = 1.d0 if(nlopt.eq.0) go to 900 !c ! * execute left hand side coefficient options * ! go to (100, 110, 120, 130, 140 & & ,150, 160, 170, 180, 190 & & ,200, 210, 220, 230, 240 & & ,250, 260, 270, 280, 290 & & , 300, 310, 320, 330, 340 & & ), nlopt 100 continue !c ! * all coefficients are assumed specified in input routine * ! go to 500 110 continue !c ! * upper surface normal perturbation mass flux specification * ! nct=1 cu=1.d0 cl=0.d0 go to 500 120 continue !c ! * lower surface normal perturbation mass flux specification * ! nct=1 cu=0.d0 cl=1.d0 go to 500 130 continue !c ! * average nromal perturbation mass flux specification * ! nct=1 cu=.5d0 cl=.5d0 go to 500 140 continue !c ! * difference normal perturbation mass flux specification * ! nct=1 cu=1.d0 cl=-1.d0 go to 500 150 continue !c ! * upper surface perturbation potential specification * !+ nct=4 du=1.d0 dl=0.d0 go to 500 160 continue !c ! * lower surface perturbation potential specification * ! nct=4 du=0.d0 dl=1.d0 go to 500 170 continue !c ! * average perturbation potential specification * ! nct=4 du=.5d0 dl=.5d0 go to 500 180 continue !c ! * difference perturbation potential specification * !+ nct=4 du=1.d0 dl=-1.d0 go to 500 190 continue !c ! * specify coefficients in fortran coded routine ccof if * ! * control point geometric characteristics are required * ! call ccof(cu,cl,tu,tl,du,dl,nct,nbin) go to 500 200 continue !c ! * upper surface normal perturbation velocity specification * ! call zero(cu,10) call cmpscl(betams,compd,znc,zncs) call mxm (compd,1,znc,3,enx,1) enxm=amach*enx alam=al1 if(enxm.ge.enx2) alam=al2 if((enxm.lt.enx2).and.(enxm.gt.enx1)) & &alam=(al2*(enxm-enx1)+al1*(enx2-enxm))/(enx2-enx1) alam=alam*amach*amach*enx call vadd(znc,-alam,compd,h,3) call mxm (h,1,znc,3,hznc,1) call mxm (zncs,1,znc,3,alam,1) alam=hznc/alam call vadd(h,-alam,zncs,zncs,3) nct=2 cu=alam tu(1)=zncs(1) tu(2)=zncs(2) tu(3)=zncs(3) go to 500 210 continue !c ! * lower surface normal perturbation velocity specification * ! call zero(cu,10) call cmpscl(betams,compd,znc,zncs) call mxm (compd,1,znc,3,enx,1) enxm=-amach*enx alam=al1 if(enxm.ge.enx2) alam=al2 if((enxm.lt.enx2).and.(enxm.gt.enx1)) & &alam=(al2*(enxm-enx1)+al1*(enx2-enxm))/(enx2-enx1) alam=alam*amach*amach*enx call vadd(znc,-alam,compd,h,3) call mxm (h,1,znc,3,hznc,1) call mxm (zncs,1,znc,3,alam,1) alam=hznc/alam call vadd(h,-alam,zncs,zncs,3) nct=2 cl=alam tl(1)=zncs(1) tl(2)=zncs(2) tl(3)=zncs(3) go to 500 220 continue !c ! * average normal perturbation velocity specification * ! call zero(cu,10) call cmpscl(betams,compd,znc,zncs) call mxm (compd,1,znc,3,enx,1) enxm=amach*enx if ( iabs(nropt).eq.6 ) enxm = -amach*enx alam=al1 if(enxm.ge.enx2) alam=al2 if((enxm.lt.enx2).and.(enxm.gt.enx1)) & &alam=(al2*(enxm-enx1)+al1*(enx2-enxm))/(enx2-enx1) alam=alam*amach*amach*enx call vadd(znc,-alam,compd,h,3) call mxm (h,1,znc,3,hznc,1) call mxm (zncs,1,znc,3,alam,1) alam=hznc/alam call vadd(h,-alam,zncs,zncs,3) nct=2 cu=.5d0*alam tu(1)=.5d0*zncs(1) tu(2)=.5d0*zncs(2) tu(3)=.5d0*zncs(3) cl=.5d0*alam tl(1)=.5d0*zncs(1) tl(2)=.5d0*zncs(2) tl(3)=.5d0*zncs(3) go to 500 230 continue !c ! * difference normal perturbation velocity specification * ! call zero(cu,10) call cmpscl(betams,compd,znc,zncs) call mxm (compd,1,znc,3,enx,1) enxm=amach*enx if ( iabs(nropt).eq.6 ) enxm = -amach*enx alam=al1 if(enxm.ge.enx2) alam=al2 if((enxm.lt.enx2).and.(enxm.gt.enx1)) & &alam=(al2*(enxm-enx1)+al1*(enx2-enxm))/(enx2-enx1) alam=alam*amach*amach*enx call vadd(znc,-alam,compd,h,3) call mxm (h,1,znc,3,hznc,1) call mxm (zncs,1,znc,3,alam,1) alam=hznc/alam call vadd(h,-alam,zncs,zncs,3) nct=2 cu=alam tu(1)=zncs(1) tu(2)=zncs(2) tu(3)=zncs(3) cl=-alam tl(1)=-zncs(1) tl(2)=-zncs(2) tl(3)=-zncs(3) go to 500 240 continue nct = 4 du = .5d0 dl = .5d0 go to 500 250 continue nct = 4 du = .5d0 dl = .5d0 go to 500 ! delta (cp/isen) = beta 260 continue nct = 4 du = .5d0 dl = .5d0 go to 500 ! delta (cp) = beta 270 continue 280 continue 290 continue nct = 2 call zero (cu,10) call dcip (znc,znc,znznu) call cmpscl (betams,compd,znc,zncs) do 295 iul = 1,2 ! sgn = (+1,-1) as (upper,lower) sgn = 3 - 2*iul imat = matnet(iul,kc) rcon = cpfmat(imat) sclf = -2.d0*sgn*rcon/fsvm(1)**2 call vmul (fsv(1,1), sclf, tg, 3) fac = ddot(3, znc,1, tg,1)/znznu call vadd (tg, -fac, zncs, tg, 3) cg = fac if ( iul.eq.1 ) then cu = cg call dcopy (3, tg,1, tu,1) else cl = cg call dcopy (3, tg,1, tl,1) endif 295 continue go to 500 ! nlopt = 21 300 continue goto 500 ! nlopt = 22 310 continue goto 500 ! nlopt = 23 320 continue goto 500 ! nlopt = 24 330 continue goto 500 ! nlopt = 25 340 continue goto 500 ! ! ! 500 continue call dcopy(3,znc,1,h,1) if(cpnorm(kc).eq.1.d0) call cpnor(ipc,zc,h) if(cpnorm(kc).eq.2.d0) call cpnor2 (kc,ipc,icc,zc,h) !c ! * execute right hand side coefficient options * ! if ( nropt.eq.0 ) go to 900 kmatu = matnet(1,kc) kmatl = matnet(2,kc) call dcopy (3*nacase, fsv,1, vfs,1) iul = isfrgn( iabs(nlopt) ) call dcopy (3, 0.d0,0, zmctr,1) if ( iul.ne.0 ) call dcopy (3, zctrgn(1,iul,kc),1, zmctr,1) nropta = iabs(nropt) if ( iul.eq.0 .and. (nropta.eq.4 .or. nropta.eq.9) ) call a502ms & & ('bcopt', 'unexpected error, contact a502 support group' ) goto (600,610,620,630,640,650,660,670,680,690), nropta 600 continue !c ! * right hand side for all cases specified in input routine * ! go to 900 610 continue !c ! * right hand side for all cases set to zero * ! call zero (bet,ityprc*nacase) go to 900 620 continue !c ! * right hand side for all cases subtracts off nromal component * ! * of freestream velocity * ! call mxm (h,1,vfs,3,bet,nacase) do 625 iacase=1,nacase 625 bet(iacase)=-bet(iacase) go to 900 630 continue !c ! * right hand side for all cases subtracts off co-position * ! * vector dotted into freestream velocity vector * ! call vadd (zc,-1.d0,zmctr(1),tg,3) call cmpscl (1.d0/betams,compd,tg,zcs) call mxm (zcs,1,vfs,3,bet,nacase) do 635 iacase=1,nacase 635 bet(iacase)=-bet(iacase) go to 900 640 continue !c ! * right hand side for all cases specified in fortran coded * ! * subroutine cbet if control point geometric characteristics * ! * are required * ! call cbet(bet,nbin) go to 900 650 continue !c ! * right hand side for all cases is normal component * ! * of freestream velocity * ! call mxm (h,1,vfs,3,bet,nacase) go to 900 660 continue !== call mxmcs (h,1,vfs,3,bet,nacase) call hsmmp3 (1,3,nacase, h,1,1, vfs,1,3, bet,1,1) go to 900 670 continue !== call mxmca (h,1,vfs,3,bet,nacase) call hsmmp2 (1,3,nacase, h,1,1, vfs,1,3, bet,1,1) go to 900 680 continue call vadd (zc,-1.d0,zmctr(1),tg,3) call mxm (tg,1,vfs,3,bet,nacase) do 665 iacase=1,nacase 665 bet(iacase)=-bet(iacase) goto 900 ! 690 continue goto 900 ! 900 return END subroutine bcopt ! **deck binsch subroutine binsch(z,x,n,il,iu) implicit double precision (a-h,o-z) !call propre !c !******************************************************************* ! ! note ! ! ! A502 was developed by: ! ! The Boeing Company ! Boeing Commercial Airplanes ! Aerodynamics Research Group ! ! Individuals who have contributed to its development ! include: ! ! Forrester T. Johnson ! F. Edward Ehlers ! Michael A. Epton ! Larry L. Erickson (NASA) ! Paul E. Rubbert ! Gary R. Saaris ! Edward N. Tinoco ! ! !c !*********************************************************************** ! !end propre !****** ! purpose to find the interval (x(il),x(iu)) which z lies ! ! input calling sequence ! z - the search argument ! x - array of values, must be either monotonically increas ! -ing or decreasing ! n - dimension of the array x ! ! output calling sequence ! il - lower index of the search interval ! iv - upper index of the search interval ! ! discussion use binary search scheme. if z is not in the range of ! x, the nearest endpoint of x will be indicated as an ! exact fit (il and iu will be set to be index of endpoint) !****** dimension x(n) logical lup ! check if the sequence of given values is ! ascending or descending lup = .true. if(x(1).gt.x(n)) lup = .false. if(.not.lup) go to 20 ! for ascending case, set il and iu equal to ! the index of the nearest endpoint when z ! is not in the range of x if((z.gt.x(1)).and.(z.lt.x(n))) go to 40 if(z.ge.x(n)) go to 10 il = 1 iu = 1 go to 90 10 il = n iu = n go to 90 ! for descending case, set il and iv equal ! to the index of the nearest endpoint when ! z is not in the range of x 20 continue if((z.lt.x(1)).and.(z.gt.x(n))) go to 40 if(z.le.x(n)) go to 30 il = 1 iu = 1 go to 90 30 il = n iu = n go to 90 ! start binary search 40 il = 1 iu = n 50 if(il.gt.iu) go to 70 i = (il+iu)/2 ! check if exact fit if(z.eq.x(i)) go to 80 if(z.gt.x(i)) go to 60 if(lup) iu = i-1 if(.not.lup) il = i+1 go to 50 60 if(lup) il = i+1 if(.not.lup) iu = i-1 go to 50 ! set the interval 70 itemp = il il = iu iu = itemp go to 90 ! for exact fit 80 il = i iu = i 90 return END subroutine binsch ! **deck bkfact subroutine bkfact (s,ns,n,nrhs, lmat,lint,llu, lprnt,nhdat,ier) implicit double precision (a-h,o-z) dimension s(ns), nhdat(6) logical lprnt !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk ! ! ! !call facdat ! /facdat/ common /facdat/ ierh, nsh, nh, nrhsh, pph, qqh integer pph, qqh !end facdat integer pp, qq, p, q ! lprblk = lprnt ierh = 0 if ( ns.le.n ) go to 9100 call blksze (ns,n,nrhs, pp,qq,s) ! insert code here to force an overr ! of the blksze choice of pp and qq if ( lprblk ) & &write (6,6400) ns,n,nrhs,pp,qq 6400 format ('0 ***** bkfact ***** ns',i8,' n',i4 & & ,' nrhs',i3,' pp',i4,' qq',i4 ) ! nsh = ns nh = n nrhsh = nrhs pph = pp qqh = qq call ifera (ierh,nhdat,6) if ( pp.eq.0 ) go to 9200 if ( qq.eq.0 ) go to 1000 ! normal case, out of core factorizatio p = (n+pp-1)/pp q = (n+qq-1)/qq kint = p*q + 1 klu = p*p + 2 ! map stage (1) ll = 1 ! llint = ll ll = ll + kint ! llaq = ll ll = ll + qq*n ! lla = ll ll = ll + n ! last1 = ll - 1 if ( last1.gt.ns ) go to 9300 ! map stage (2) ll = llaq ! llbpp = ll ll = ll + pp*pp ! llbqp = ll ll = ll + qq*pp ! llilu = ns - klu + 1 if ( llilu.lt.ll ) go to 9400 ! map stage (3) ll = 1 ! llaa = ll ll = ll + pp*pp + pp ! llbb = ll ll = ll + pp*pp ! llcc = ll ll = ll + pp*pp ! llsc = ll ll = ll + pp ! if ( ll.gt.llilu ) go to 9500 ! ! ! call wopen (lint,10,0,ierr) call openms (lint,s(llint),kint,0) call CPU_TIME (ta) call blkaqp (n,lmat,lint,pp,qq,p,q,s(lla),s(llaq)) call CPU_TIME (tb) tblk1 = tb - ta ! ! ! call wopen (llu,100,0,ierr) call openms (llu,s(llilu),klu,0) call CPU_TIME (ta) call blkapp (n,lint,llu,pp,qq,p,q,s(llbqp),s(llbpp)) call CPU_TIME (tb) tblk2 = tb - ta ! ! ! call closms (lint) call CPU_TIME (ta) call blkfac (n,llu,pp,p,s(llaa),s(llbb),s(llcc),s(llsc),ierh) call CPU_TIME (tb) tblk3 = tb - ta ! ! ! if ( lprblk ) & &write (6,6004) tblk1,tblk2,tblk3 6004 format ('0 ==== timing for bkfact ===== ' & & ,/,' 1st stage blocking ',f12.6 & & ,/,' 2nd stage blocking ',f12.6 & & ,/,' l-u factorization ',f12.6 ) go to 2000 ! direct factorization 1000 continue ! direct code ===================== write (6,6000) 6000 format (' direct (i.e., unblocked) option not available') CALL AbortPanair('bkfact') go to 9999 ! 2000 continue go to 9999 ! error returns 9100 continue ierh = 1 go to 9999 9200 continue ierh = 2 go to 9999 9300 continue ierh = 3 go to 9999 9400 continue ierh = 4 go to 9999 9500 continue ierh = 5 go to 9999 ! 9999 continue nhdat(1) = ierh ier = ierh if ( ier.ne.0 ) write (6,6401) ier 6401 format ('0 ===== error code from bkfact ===== ',i5) call writms (llu,nhdat,6,1, -1,0) call closms (llu) return END subroutine bkfact ! **deck bkfclu subroutine bkfclu (s,ns,n,nrhs, pp,qq,llu, lprnt,nhdat,ier) implicit double precision (a-h,o-z) dimension s(ns), nhdat(6) integer pp, qq, p logical lprnt ! ! perform a blocked lu factorization of a matrix already blocked ! into blocks of nominal size (pp x qq) ! !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk ! !call facdat ! /facdat/ common /facdat/ ierh, nsh, nh, nrhsh, pph, qqh integer pph, qqh !end facdat !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx ! lprblk = lprnt ierh = 0 if ( ns.le.n ) goto 9100 ! insert code here to force an override ! of the blksze choice of pp and qq if ( lprblk ) & &write (6,6400) ns,n,nrhs,pp,qq 6400 format ('0 ***** bkfclu ***** ns',i8,' n',i4 & & ,' nrhs',i3,' pp',i4,' qq',i4 ) ! nsh = ns nh = n nrhsh = nrhs pph = pp qqh = qq call ifera (ierh,nhdat,6) if ( pp.eq.0 ) goto 9200 ! p = number of row/column blocks p = (n+pp-1)/pp klu = p*p + 2 ! map stage (1) ll = 1 ! llilu = ll ll = ll + klu ! llaa = ll ll = ll + ityprc*( pp*pp + pp ) ! llbb = ll ll = ll + ityprc*( pp*pp ) ! llcc = ll ll = ll + ityprc*( pp*pp ) ! llsc = ll ll = ll + ityprc*( pp ) ! last1 = ll-1 if ( last1.gt.ns ) goto 9300 ! call wopen (llu,100,0,ierr) call openms (llu,s(llilu),klu,0) ! call CPU_TIME (ta) call blkfac (n,llu,pp,p,s(llaa),s(llbb),s(llcc),s(llsc),ierh) call CPU_TIME (tb) tblk1 = tb - ta ! if ( lprblk ) & &write (6,6004) tblk1 6004 format ('0 ==== timing for bkfclu ===== ' & & ,/,' l-u factorization ',f12.6 ) goto 9999 ! error returns 9100 continue ierh = 1 goto 9999 9200 continue ierh = 2 goto 9999 9300 continue ierh = 3 goto 9999 ! 9999 continue nhdat(1) = ierh ier = ierh if ( ier.ne.0 ) write (6,6401) ier 6401 format ('0 ===== error code from bkfclu ===== ',i5) call writms (llu,nhdat,6,1, -1,0) call closms (llu) return END subroutine bkfclu ! **deck bkmove subroutine bkmove (a,b,m,n,na,nb) implicit double precision (a-h,o-z) ! ! move an mxn array from a(na,n) to b(nb,n) ! dimension a(na,n),b(nb,n) do 100 i=1,n call dcopy(m,a(1,i),1,b(1,i),1) 100 continue return END subroutine bkmove ! **deck bkslvt subroutine bkslvt (s,ns,n,nrhs,llu,lrhs,lbn,lans, lprnt,nhdat,ier) implicit double precision (a-h,o-z) dimension s(ns), nhdat(6) logical lprnt ! ! organize the solution of the transpose system of linear equations ! given the LU factorization computed by bkfact on unit llu. ! this routine is essentially the dual routine to bksolv and ! shares much of its structure with bksolv. ! !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt !call facdat ! /facdat/ common /facdat/ ierh, nsh, nh, nrhsh, pph, qqh integer pph, qqh !end facdat !call cmsolv ! /cmsolv/ ! data for 'blk' pkg to do in-memory solution common /cmsolv/ bxcmsv, ppsv, llbxsv, nrhssv !end cmsolv logical lprblk integer pp, qq, p, q ! logical bxcmsv integer ppsv ! lprblk = lprnt call ifera (nhdat,ierh,6) if ( ierh.ne.0 ) CALL AbortPanair('bkslvt') if ( ns.lt.nsh ) call a502wr ('bkslvt' & & ,'attempt to solve singular system') pp = pph qq = qqh p = (n+pp-1)/pp q = (n+qq-1)/qq if ( qq.eq.0 ) goto 1000 ! ll = 1 ! llilu = ll klu = p*p + 2 ll = ll + klu ! llibn = ll nbrhs = (nrhs+pp-1)/pp nbpp = min(pp,nrhs) ll = ll + p*nbrhs + 1 kbn = p*nbrhs + 1 ! lla = ll ll = ll + (pp*pp + pp)*ityprc ! llbpm = ll ll = ll + pp*nbpp*ityprc ! w = (a,bpm), size: pp*pp+pp + pp*nbp nw = pp*pp + pp + pp*nbpp !--- nw = pp*pp + pp !--- call outlin ('nbrhs,nw',2,nbrhs,nw) ! llxpm = ll ll = ll + pp*nbpp*ityprc ! llb = ll ll = ll + nrhs*ityprc ! if ( ll.gt.ns ) go to 9000 bxcmsv = .false. if ( ll + nrhs*n*ityprc .gt. ns ) go to 400 goto 400 ! put rhs into memory buffer when enoug ! space is available bxcmsv = .true. ppsv = pp !----- llbxsv = loc(s(ll)) nrhssv = nrhs ll = ll + nrhs*n*ityprc ! ! 400 continue ! ! rewind lrhs call openms (llu,s(llilu),klu,0) if ( .not. bxcmsv ) call openms (lbn,s(llibn),kbn,0) call CPU_TIME (ta) call blkrhs (n,nrhs, lrhs,lbn, s(llb),s(llbpm),pp) call CPU_TIME (tb) tblk4 = tb - ta ! ! ! call CPU_TIME (ta) call blksvt (n,nrhs, llu,lbn, s(llbpm),s(llxpm),s(lla),pp) call CPU_TIME (tb) tblk5 = tb - ta ! ! ! rewind lans call CPU_TIME (ta) call blkans (n,nrhs, lans,lbn, s(llb),s(llxpm),pp, s(lla),nw) call CPU_TIME (tb) tblk6 = tb - ta ! ! ! if ( lprblk ) & &write (6,6004) tblk4, tblk5, tblk6 6004 format ('0 ==== timing for bkslvt ===== ' & & ,/,' 1st stage blocking ',f12.6 & & ,/,' forward/back substitute',f12.6 & & ,/,' 2nd stage blocking ',f12.6 & & ) rewind lans rewind lrhs call closms (llu) if ( .not.bxcmsv ) call closms (lbn) go to 2000 ! ! ! 1000 continue call a502er ('bkslvt','direct solver not yet implemented') go to 2000 ! ! ! 2000 continue return ! ! ! 9000 continue write (6,6000) pp,qq,p,q,nrhs,ll,ns 6000 format (' bkslvt: pp',i5,' qq',i5,' p',i5,' q',i5 & & ,' nrhs',i5,' ll',i10,' ns',i10) call a502er ('bkslvt','not enough scratch memory') END subroutine bkslvt ! **deck bksolv subroutine bksolv (s,ns,n,nrhs,llu,lrhs,lbn,lans, lprnt,nhdat,ier) implicit double precision (a-h,o-z) dimension s(ns), nhdat(6) logical lprnt !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk !call facdat ! /facdat/ common /facdat/ ierh, nsh, nh, nrhsh, pph, qqh integer pph, qqh !end facdat integer pp, qq, p, q ! !call cmsolv ! /cmsolv/ ! data for 'blk' pkg to do in-memory solution common /cmsolv/ bxcmsv, ppsv, llbxsv, nrhssv !end cmsolv logical bxcmsv integer ppsv ! lprblk = lprnt call ifera (nhdat,ierh,6) if ( ierh.ne.0 ) CALL AbortPanair('bksolv') if ( ns.lt.nsh ) call a502wr ('bksolv' & & ,'attempt to solve singular system') pp = pph qq = qqh p = (n+pp-1)/pp q = (n+qq-1)/qq if ( qq.eq.0 ) goto 1000 ! ll = 1 ! llilu = ll klu = p*p + 2 ll = ll + klu ! llibn = ll nbrhs = (nrhs+pp-1)/pp nbpp = min(pp,nrhs) ll = ll + p*nbrhs + 1 kbn = p*nbrhs + 1 ! lla = ll ll = ll + pp*pp + pp ! llbpm = ll ll = ll + pp*nbpp ! w = (a,bpm), size: pp*pp+pp + pp*nbp nw = pp*pp + pp + pp*nbpp !--- nw = pp*pp + pp !--- call outlin ('nbrhs,nw',2,nbrhs,nw) ! llxpm = ll ll = ll + pp*nbpp ! llb = ll ll = ll + nrhs ! if ( ll.gt.ns ) go to 9000 bxcmsv = .false. if ( ll+nrhs*n .gt. ns ) go to 400 goto 400 ! put rhs into memory buffer when enoug ! space is available bxcmsv = .true. ppsv = pp !----- llbxsv = loc(s(ll)) nrhssv = nrhs ll = ll + nrhs*n ! ! 400 continue ! ! rewind lrhs call openms (llu,s(llilu),klu,0) if ( .not. bxcmsv ) call openms (lbn,s(llibn),kbn,0) call CPU_TIME (ta) call blkrhs (n,nrhs, lrhs,lbn, s(llb),s(llbpm),pp) call CPU_TIME (tb) tblk4 = tb - ta ! ! ! call CPU_TIME (ta) call blkslv (n,nrhs, llu,lbn, s(llbpm),s(llxpm),s(lla),pp) call CPU_TIME (tb) tblk5 = tb - ta ! ! ! rewind lans call CPU_TIME (ta) call blkans (n,nrhs, lans,lbn, s(llb),s(llxpm),pp, s(lla),nw) call CPU_TIME (tb) tblk6 = tb - ta ! ! ! if ( lprblk ) & &write (6,6004) tblk4, tblk5, tblk6 6004 format ('0 ==== timing for bksolv ===== ' & & ,/,' 1st stage blocking ',f12.6 & & ,/,' forward/back substitute',f12.6 & & ,/,' 2nd stage blocking ',f12.6 & & ) rewind lans rewind lrhs call closms (llu) if ( .not.bxcmsv ) call closms (lbn) go to 2000 ! ! ! 1000 continue call a502er ('bksolv','direct solver not yet implemented') go to 2000 ! ! ! 2000 continue return ! ! ! 9000 continue write (6,6000) pp,qq,p,q,nrhs,ll,ns 6000 format (' bksolv: pp',i5,' qq',i5,' p',i5,' q',i5 & & ,' nrhs',i5,' ll',i10,' ns',i10) call a502er ('bksolv','not enough scratch memory') END subroutine bksolv ! **deck blbfun subroutine blbfun (sv,tv, bl) implicit double precision (a-h,o-z) dimension bl(2,2) ! ! for (s,t) coordinates on an isoparametric elements, generate ! bilinear basis functions according to the scheme: ! ! ^ t ! (1,1) [1] +------|------+ [2] (1,2) ! | | | ! | | | ! s <---------+ | ! | | ! | | ! (2,1) [4] +------+------+ [3] (2,2) ! ! bl(1,1) = (1.d0+sv)*(1.d0+tv)*.25d0 bl(1,2) = (1.d0-sv)*(1.d0+tv)*.25d0 bl(2,2) = (1.d0-sv)*(1.d0-tv)*.25d0 bl(2,1) = (1.d0+sv)*(1.d0-tv)*.25d0 ! return END subroutine blbfun ! **deck blcal subroutine blcal(blcp,bl) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * for each grid point blccal calculates the dependence of * ! * doublet strength at that point on the surrounding 16 * ! * singularity parameters of the doublet analysis spline. * ! * blccal also calculates the dependence of doublet strength * ! * at the two adjacent edge midpoints in the increasing * ! * column and row directions on their surrounding 12 singularity* ! * parameters. blcal takes this information for four panel * ! * grid corner points and calculates the dependence of the * ! * 9 canonical panel doublet values on the 25 neighboring * ! * singularity parameters. the major task is to transform the * ! * local singularity parameter indexing for each grid and * ! * midpoint to the indexing system of the panel. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bl argument output matrix relating 9 canonical * ! * panel doublet values to 25 * ! * surrounding doublet * ! * singularity parameters * ! * * ! * blcp argument input dependence of doublet strength* ! * at panel corner points and * ! * neighboring edge midpoints * ! * on surrounding doublet * ! * singularity parameters * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension blcp(3,16,4),bl(9,25) call zero(bl,225) !c ! * calculate dependence of panel center canonical doublet value * ! * on neighboring 25 singularity parameters * ! bl(9,13)=1.d0 !c ! * calculate dependence of panel corner canonical doublet values* ! * on neighboring 25 singularity parameters * ! do 300 lcp=1,4 call mnmod(lcp,2,mc,nc) !c ! * switch to corner index in counterclockwise direction * ! lcpp=2*mc-1+iabs(mc-nc) do 200 i=1,16 call mnmod(i,4,mi,nj) k=(mc+mi-1)+5*(nc+nj-2) bl(lcpp,k)=blcp(1,i,lcp) 200 continue 300 continue !c ! * calculate dependence of panel edge midpoint canonical doublet* ! * values on neighboring 25 singularity parameters * ! do 400 i=1,12 call mnmod(i,4,m4,n4) call mnmod(i,3,m3,n3) k5=m4+5*n4 k6=m3+5*n3+1 k7=m4+5*n4+1 k8=m3+5*n3-4 bl(5,k5)=blcp(2,i,1) bl(6,k6)=blcp(3,i,3) bl(7,k7)=blcp(2,i,2) bl(8,k8)=blcp(3,i,1) 400 continue return END subroutine blcal ! **deck blccal subroutine blccal(m,n,nm,nn,zm,z,b) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to calculate matrices relating doublet strength at a grid * ! * point and at the two adjacent edge midpoints in the * ! * increasing row and column directions to doublet singularity * ! * parameters in the neighborhood of the grid point. the * ! * singularity parameters are assumed to be associated with the * ! * standard doublet type 12 locations. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * the code between statements 199 and 399 calculates * ! * the dependence of doublet strength at an interior grid point * ! * on the 16 neighboring doublet singularity parameters. for * ! * this purpose a local tangent plane corrdinate system is * ! * constructed with the grid point as the origin. then the * ! * singularity parameter points are projected onto the tangent * ! * plane and a standard 6-coefficient quadratic distribution is* ! * fit to these points by the method of weighted least squares. * ! * the dependence of the constant coefficient of the * ! * distribution on the neighboring singularity parameters is * ! * then the desired result. * ! * the code between statements 399 and 600 calculates the * ! * dependence of doublet strength at the midpoint between the * ! * given grid point and the grid point in the same row but next * ! * column on the 12 neighboring singularity parameters in the * ! * same manner as above. the code between statements 600 and 900* ! * calculates the dependence of doublet strength at the midpoint* ! * between the given grid point and the grid point in the same * ! * column but next row on the 12 neighboring singularity * ! * parameters in the same manner as above. * ! * the initial code up to statement 199 calculates the * ! * dependence of doublet strength at edge grid and midpoints * ! * on neighboring doublet singularity parameters. here however, * ! * values of doublet strength are allowed to depend * ! * only on network edge singularity parameters. for this purpose* ! * each edge is parameterized by arc length and a standard one- * ! * dimensional weighted least squares fit based on arc length * ! * as a variable is used. for a network edge midpoint the * ! * associated doublet value is simply the value of the doublet * ! * singularity parameter at that point * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * ae -local- - - - - dependence of doublet value at* ! * edge grid point on 2 adjacent * ! * doublet parameters on each * ! * side of grid point * ! * * ! * ak /lsqfs/ -local- ak(l,k)=dependence of lth * ! * taylor series coefficient of * ! * least square distribution on * ! * function value at kth point. * ! * * ! * amr orthogonal matrix transforming* ! * from global coordinates to * ! * tangent plane coordinates * ! * * ! * amrt inverse of amr * ! * * ! * b argument output b(1,k) is the dependence of * ! * doublet strength at given grid* ! * point on kth out of 16 * ! * neighboring singularity * ! * parameters. * ! * b(2,k) is the dependence of * ! * doublet strength at midpoint * ! * between given grid point and * ! * grid point in same row but * ! * next column on kth out of 12 * ! * neighboring singularity * ! * parameters * ! * b(3,k) is the dependence of * ! * doublet strength at midpoint * ! * between given grid point and * ! * grid point in same column but * ! * next row on kth out of 12 * ! * neighboring singularity * ! * parameters * ! * * ! * de -local- - - - - lengths of 2 adjacent edge * ! * segments on each side of given* ! * edge grid point * ! * * ! * deltf -local- - - - - size of weight on closest * ! * values for least square fit * ! * * ! * m argument input network row index of given * ! * grid point * ! * * ! * n argument input network column index of given * ! * grid point * ! * * ! * nm argument input number of rows of grid * ! * points in network * ! * * ! * nn argument input number of columns of grid * ! * points in network * ! * * ! * no /lsqfs/ -local- order of least square fit * ! * =1 linear * ! * =2 quadratic * ! * * ! * npk /lsqfs/ -local- total number of points, * ! * the function values at which * ! * are to be interpolated by * ! * weighted least square fit * ! * * ! * we -local- - - - - least square weights for each * ! * of four values involved in * ! * one-dimensional least square * ! * fit. (we(2) and we(3) are * ! * assumed infinite by subroutine* ! * edgls.) * ! * * ! * wtk /lsqfc/ -local- least square weights for * ! * each point in zk * ! ! * z argument input array containing 16 singular- * ! * ity parameter locations in * ! * neighborhood of given grid * ! * point, lying in intersection * ! * of 4 adjacent singularity par-* ! * ameter rows and columns. (if * ! * given grid point lies near * ! * network edge and there are no * ! * adjacent rows or columns of * ! * grid points the last row or * ! * column is substituted.) * ! * * ! * zk /lsqsfc/ -local- local coordinates of points, * ! * the function values at which * ! * are to be interpolated by * ! * weighted least square fit * ! * zm argument input array containing 25 grid * ! * points in neighborhood of * ! * given grid point. zm(l,3,3) is* ! * given grid point and remainder* ! * of array contains 24 closest * ! * points in grid sense. (if * ! * given grid point lies near * ! * network edge and there are no * ! * adjacent rows or columns of * ! * grid points the last row or * ! * column is substituted.) * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! logical ident !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call lsqsfc ! /lsqsfc/ common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk !end lsqsfc dimension zm(3,5,5),z(3,4,4),b(3,16) dimension amr(9),amrt(9),ze(3,3,3),de(4),ae(4),we(4),w(3) data deltf /1000.d0/ weight(w1,w2,w3)=1.d0+amachm*(1.d0-(w1*compd(1)+w2*compd(2)+ & &w3*compd(3))/sqrt(w1**2+w2**2+w3**2)) amachm=.5d0*(1.d0-sbetam)*amach call zero(b,48) no=2 !c ! * if given grid point is in interior of network branch to 199 * ! if((m.ne.1).and.(m.ne.nm).and.(n.ne.1).and.(n.ne.nn)) go to 199 !c ! * if given grid point is in first or last column branch to 100 * ! if((n.eq.1).or.(n.eq.nn)) go to 100 k23=3 if(m.eq.1) k23=2 !c ! * given grid point is in first or last row * ! !c ! * determine arc lengths of adjacent intervals along edge * ! do 25 j=1,4 call distnc(zm(1,3,j),zm(1,3,j+1),de(j)) call pident(zm(1,3,j),zm(1,3,j+1),ident) if(ident) de(j)=0.d0 call vadd(z(1,k23,j),-1.d0,zm(1,3,3),w,3) wmag = sqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) we(j)=1.d0 if(wmag.gt.0.d0) we(j) =weight(w(1),w(2),w(3)) 25 continue !c ! * employ one-dimensional least square fit algorithm * ! call edgls(de,we,ae) do 50 k=1,4 k4=4*(k-1) if(m.eq.1) b(1,k4+2)=ae(k) if(m.eq.nm) b(1,k4+3)=ae(k) 50 continue go to 399 100 continue k23=3 if(n.eq.1) k23=2 !c ! * given grid point is in first or last column * ! !c ! * determine arc lengths of adjacent intervals along edge * ! do 125 i=1,4 call distnc(zm(1,i,3),zm(1,i+1,3),de(i)) call pident(zm(1,i,3),zm(1,i+1,3),ident) if(ident) de(i)=0.d0 call vadd(z(1,i,k23),-1.d0,zm(1,3,3),w,3) wmag = sqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) we(i)=1.d0 if(wmag.gt.0.d0) we(i) =weight(w(1),w(2),w(3)) 125 continue !c ! * employ one-dimensional least square fit algorithm * ! call edgls(de,we,ae) do 150 k=1,4 if(n.eq.1) b(1,k+4)=ae(k) if(n.eq.nn) b(1,k+8)=ae(k) 150 continue go to 399 199 continue !c ! * given grid point lies in interior of network * ! !c ! * set number of singularity parameters on which doublet value * ! * at point is dependent * ! npk=16 !c ! * calculate transformation matrices to and from local tangent * ! * plane coordinates * ! call msrotm(zm,5,5,3,3,amr) call trans(amr,amrt,3,3) do 200 k=1,16 call mnmod(k,4,i,j) !c ! * project adjacent singularity parameter points onto tangent * ! * plane * ! call lproj(amrt(7),zm(1,3,3),z(1,i,j),zk(1,k)) !c ! * compute local coordinates of projected singularity parameter * ! * points * ! call unipan(amr,zm(1,3,3),zk(1,k),zk(1,k)) call vadd(z(1,i,j),-1.d0,zm(1,3,3),w,3) wmag = sqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) wtk(k)=1.d0 if(wmag.gt.0.d0) wtk(k)=weight(w(1),w(2),w(3)) !c ! * weight closest points heavily * ! if((k.eq.6).or.(k.eq.7).or.(k.eq.10).or.(k.eq.11)) & &wtk(k)=deltf !c ! * ignore extreme points * ! if((k.eq.1).or.(k.eq.4).or.(k.eq.13).or.(k.eq.16)) wtk(k)=0.d0 200 continue !c ! * calculate least square fit * ! call lsqsg do 300 k=1,npk 300 b(1,k)=ak(1,k) 399 continue !c ! * set number of singularity parameters on which doublet value * ! * at point is dependent * ! npk=12 !c ! * if grid point lies in last column these computations are not * ! * required * ! if(n.eq.nn) go to 600 !c ! * if grid point lies in first or last column edge midpoint * ! * coincides with singularity parameter location * ! if(m.eq.1) b(2,6)=1.d0 if(m.eq.nm) b(2,7)=1.d0 if((m.eq.1).or.(m.eq.nm)) go to 600 !c ! * compute local grid defining tangent plane * ! do 400 l=1,3 do 400 i=1,3 do 400 j=1,3 aaajm1 = j-1 400 ze(l,i,j)=zm(l,i+1,3)+.5d0*aaajm1*(zm(l,i+1,4)-zm(l,i+1,3)) !c ! * calculate transformation matrices to and from local tangent * ! * plane coordinates * ! call msrotm(ze,3,3,2,2,amr) call trans(amr,amrt,3,3) do 500 k=1,12 call mnmod(k,4,i,j) !c ! * project adjacent singularity parameter points onto tangent * ! * plane * ! call lproj(amrt(7),ze(1,2,2),z(1,i,j+1),zk(1,k)) !c ! * compute local coordinates of projected singularity parameter * ! * points * ! call unipan(amr,ze(1,2,2),zk(1,k),zk(1,k)) call vadd(z(1,i,j+1),-1.d0,ze(1,2,2),w,3) wmag = sqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) wtk(k)=1.d0 if(wmag.gt.0.d0) wtk(k)=weight(w(1),w(2),w(3)) !c ! * weight closest points heavily * ! if((j.eq.2).and.((i.eq.2).or.(i.eq.3))) wtk(k)=deltf 500 continue !c ! * calculate least square fit * ! call lsqsg do 550 k=1,npk 550 b(2,k)=ak(1,k) 600 continue !c ! * if grid point lies in first row these computations are not * ! * required * ! if(m.eq.nm) go to 900 !c ! * if grid point lies in first or last row edge midpoint * ! * coincides with singularity parameter location * ! if(n.eq.1) b(3,5)=1.d0 if(n.eq.nn) b(3,8)=1.d0 if((n.eq.1).or.(n.eq.nn)) go to 900 !c ! * compute local grid defining tangent plane * ! do 700 l=1,3 do 700 i=1,3 do 700 j=1,3 aaaim1 = i-1 700 ze(l,i,j)=zm(l,3,j+1)+.5d0*aaaim1*(zm(l,4,j+1)-zm(l,3,j+1)) !c ! * calculate transformation matrices to and from local tangent * ! * plane coordinates * ! call msrotm(ze,3,3,2,2,amr) call trans(amr,amrt,3,3) do 800 k=1,12 call mnmod(k,3,i,j) !c ! * project adjacent singularity parameter points onto tangent * ! * plane * ! call lproj(amrt(7),ze(1,2,2),z(1,i+1,j),zk(1,k)) !c ! * compute local coordinates of projected singularity parameter * ! * points * ! call unipan(amr,ze(1,2,2),zk(1,k),zk(1,k)) call vadd(z(1,i+1,j),-1.d0,ze(1,2,2),w,3) wmag = sqrt(w(1)*w(1)+w(2)*w(2)+w(3)*w(3)) wtk(k)=1.d0 if(wmag.gt.0.d0) wtk(k)=weight(w(1),w(2),w(3)) !c ! * weight closest points heavily * ! if((i.eq.2).and.((j.eq.2).or.(j.eq.3))) wtk(k)=deltf 800 continue !c ! * calculate least square fit * ! call lsqsg do 850 k=1,npk 850 b(3,k)=ak(1,k) 900 continue return END subroutine blccal ! **deck blkabi subroutine blkabi (a,m, b,n, ip,s) implicit double precision (a-h,o-z) dimension a(m,1), b(n,1), ip(1), s(m,1) ! ! ! ! do 100 j = 1,n if ( j.gt.1 ) call hsmvp3 (m,j-1, a,1,m, b(1,j),1, a(1,j),1) sc = 1.d0/b(j,j) call dscal (m,sc,a(1,j),1) 100 continue do 200 j = n,1,-1 if ( j.lt.n ) call hsmvp3 (m,n-j, a(1,j+1),1,m, b(j+1,j),1 & & ,a(1,j ),1) 200 continue ! do 300 j = 1,n call dcopy (m, a(1,j),1, s(1,ip(j)),1) 300 continue call dcopy (m*n, s,1, a,1) return END subroutine blkabi ! **deck blkaic subroutine blkaic (irowra,aic,wic,nwic ,ityprc,nsngu,krowsa,krowta& & ,lint,indint,llu,indllu) implicit double precision (a-h,o-z) dimension aic(1), wic(nwic) dimension indint(1:*), indllu(1:*) ! ! Enter a row of the AIC/U matrix into a partially blocked array ! wic. At any given time, wic contains data for a partially ! filled row sub-block of size krowt (nominally krowt). When ! the array wic is filled with the data for a given row subblock, ! that data is written out to unit lint using the record numbers ! indicated by the diagram below, which also describes the ! blocking strategy. ! ! icolx: 0 1 2 ! krows krowt ! irowx irowz <- krowsa -> <- krowsa -> <-kcolf-> ! | ^ ^ | ------------ ------------ -------- ! | | | v | \ | | | ! | | krowta 0 | \ 1 | 2 | 3 | ! V | | | \ | | | ! | v ------------ ------------ -------- ! | ^ ------------ ------------ -------- ! | | | \ | | | ! 0 krowsa krowta 1 | 4\ | 5 | 6 | ! | | | \ | | | ! | v ------------ ------------ -------- ! | ^ ------------ ------------ -------- ! | krowtf 2 | 7 \| 8 | 9 | ! v v ------------ ------------ -------- ! ^ ^ ------------ ------------ -------- ! | | | | \ | | ! | krowta 0 | 1 | \ 2 | 3 | ! | | | | \ | | ! | v ------------ ------------ -------- ! | ^ ------------ ------------ -------- ! | | | | \ | | ! 1 krowsa krowta 1 | 4 | 5\ | 6 | ! | | | | \ | | ! | v ------------ ------------ -------- ! | ^ ------------ ------------ -------- ! | krowtf 2 | 7 | 8 \| 9 | ! v v ------------ ------------ -------- ! ^ ^ ------------ ------------ -------- ! | | | | | \ | ! | krowta 0 | 1 | 2 | \ 3 | ! | | | | | \ | ! 2 krowsf v ------------ ------------ -------- ! | ^ ------------ ------------ -------- ! | krowtf 1 | 4 | 5 | 6 \ | ! v v ------------ ------------ -------- ! ! Within a row sub-block, the data organization in the array wic ! is indicated by the following diagram: ! ! ------------- ------------- --------- ! | ==========> +-==========> +-======> | ! | ==== 1 ===> | ==== 2 ===> | == 3 => | ! | ==========>-+ ==========>-+ ======> | ! ------------- ------------- --------- ! ! llu i*4 in unit number for blocked aic matrix ! lint i*4 in unit number for intermediate blocking file ! ! aic r*8 in row of aic matrix to be included into wic ! wic r*8 i/o buffer used for blocking of the aic matrix ! nwic i*4 in size of wic, max( 2*krowsa*krowsa + krowsa, ! krowta*nsngu ) ! ! irowra i*4 in cumulative row count [0..nsngu-1] ! irowsa i*4 loc cumulative block row count [0..krows-1] ! irowta i*4 loc cumulative subblock row count [0..krowt-1] ! ! krowsa i*4 in nominal block row size [255] ! krowta i*4 in nominal subblock row size [17] ! ! krows i*4 loc current block row size ! krowsf i*4 loc size of last row block in matrix ! krowt i*4 loc current subblock row size ! krowtf i*4 loc size of last row subblock in current block ! ! irowx i*4 loc current row-block index ! nrowx i*4 loc upper limit value for irowx ! ! irowz i*4 loc current row-subblock index ! nrowz i*4 loc upper limit value for irowz ! ! icolx i*4 loc column block index ! ncolx i*4 loc upper limit value for icolx ( = nrowx) ! kcol i*4 loc column block size (nominally = krowsa) ! kcolf i*4 loc size of last column block ( = krowsf) ! ! ityprc i*4 in ityprc = 1 (real), 2 (complex) ! check scratch memory nwicx = ityprc*max( nsngu*krowta, 2*krowsa*krowsa + krowsa ) if ( nwic.lt.nwicx ) call a502er ('blkaic','nwic < nwicx') ! get row block (irowsa) and ! sub-block (irowta) cum. counts irowsa = mod(irowra,krowsa) irowta = mod(irowsa,krowta) ! get row block index and size irowx = irowra/krowsa nrowx = (nsngu-1)/krowsa krowsf = nsngu - nrowx*krowsa krows = krowsa if ( irowx.eq.nrowx ) krows = krowsf ! get row sub-block index and size irowz = irowsa/krowta nrowz = (krows-1)/krowta krowtf = krows - nrowz*krowta krowt = krowta if ( irowz.eq.nrowz ) krowt = krowtf ! get final column block size ncolx = (nsngu-1)/krowsa kcolf = nsngu - ncolx*krowsa ! get initial subblock size kcol = krowsa if ( ncolx.eq.0 ) kcol = kcolf ! copy aic row into wic buffer laic = 1 lwicb = 1 do 100 icolx = 0,ncolx kcol = krowsa if ( icolx.eq.ncolx ) kcol = kcolf incaic = ityprc*kcol lwic = lwicb + ityprc*kcol*irowta call dcopy (incaic, aic(laic),1, wic(lwic),1) laic = laic + incaic lwicb = lwicb + incaic*krowt 100 continue ! if subblock is full, write it out if ( irowta.lt.(krowt-1) ) goto 210 ! lwic = 1 do 200 icolx = 0,ncolx kcol = krowsa if ( icolx.eq.ncolx ) kcol = kcolf irec = irowz*(ncolx+1) + icolx + 1 kblksz = ityprc*kcol*krowt call writmd (lint,wic(lwic),kblksz,irec,-1,0) lwic = lwic + kblksz 200 continue if ( lwic.gt.(nwic+1) ) call a502er ('blkaic-1','nwic too small') ! if block has been filled, read ! all the records and rewrite to ! unit llu 210 continue if ( irowsa.lt.(krows-1) ) goto 410 do 400 icolx = 0,ncolx kcol = krowsa if ( icolx.eq.ncolx ) kcol = kcolf lwic = 1 do 300 irowz = 0,nrowz krow = krowta if ( irowz.eq.nrowz ) krow = krowtf irec = irowz*(ncolx+1) + icolx + 1 kblksz = ityprc*krow*kcol call readmd (lint,wic(lwic),kblksz,irec) lwic = lwic + kblksz 300 continue if(lwic.gt.(nwic+1)) call a502er ('blkaic-2','nwic too small') ! put the matrix of size (krows x kcol) ! out to unit llu llurec = irowx + icolx*(ncolx+1) + 2 krow = krowsa if ( irowx.eq.nrowx ) krow = krowsf ! lwic = ityprc*krow*kcol + 1 if (ityprc.eq.1) & & call mcopy (krow,kcol, wic,kcol,1, wic(lwic),1,krow) if (ityprc.eq.2) & & call mccopy (krow,kcol, wic,kcol,1, wic(lwic),1,krow) kllusz = ityprc*krow*kcol ! allocate space for permutation vector if ( irowx.eq.icolx ) kllusz = kllusz + ityprc*krow call writmd (llu,wic(lwic),kllusz,llurec,-1,0) ! lwic = lwic + kllusz if(lwic.gt.(nwic+1)) call a502er ('blkaic-3','nwic too small') 400 continue ! 410 continue return END subroutine blkaic ! **deck blkans subroutine blkans (n,m, lans,lbn, b,bpm,pp, w,nw) implicit double precision (a-h,o-z) dimension w(nw) integer pp dimension bpm(1), b(1) !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk integer ppl, p dimension time(5), kevent(5), koprns(5), xnsecs(5) INTRINSIC:: CPU_TIME !------------------------------------------------------------------------------- call zero (time,5) call jzero (kevent,5) call jzero (koprns,5) call CPU_TIME (t1) ! p = (n + pp - 1)/pp ppl = n - (p-1)*pp nrw = nw/m ncw = m nbrhs = (m + pp - 1)/pp do 200 ip = 1,p ! number of rows in b's ip-th row block nr = pp if ( ip.eq.p ) nr = ppl ! number of row blocks of size <= nrw ! needed to handle nr rows npass = (nr+nrw-1)/nrw lb = 1 do 100 ipass = 1,npass ! number of rows in w for this pass nrwx = nrw if ( ipass.eq.npass ) nrwx = nr - (ipass-1)*nrw jp = ip lw = 1 do 50 ibrhs = 1,nbrhs ! number of columns in the block of b ! to be read ncb = pp if ( ibrhs.eq.nbrhs ) ncb = m - pp*(nbrhs-1) call CPU_TIME (ta) call blkrbx (lbn,bpm,nr*ncb,jp) call CPU_TIME (tb) time(1) = time(1) + tb-ta kevent(1)= kevent(1) + 1 koprns(1)= koprns(1) + nr*ncb ! copy rows [lb..lb+nrwx-1] into w, ! transposing on the fly call mcopy (nrwx,ncb, bpm(lb),1,nr, w(lw),m,1) lw = lw + ncb jp = jp + p 50 continue ! now write out the full rows stored in lw = 1 do 80 i = 1,nrwx call CPU_TIME (ta) call wtbuf (lans,w(lw),m) call CPU_TIME (tb) time(2) = time(2) + tb-ta kevent(2)= kevent(2) + 1 koprns(2)= koprns(2) + m lw = lw + m 80 continue lb = lb + nrwx 100 continue 200 continue call CPU_TIME (t2) tval = t2 - t1 if ( lprblk ) & &write (6,6001) tval 6001 format ('0 ***** blkans total time ',f12.6) do 600 i = 1,2 time(i) = max( time(i), 1.d-12) koprns(i)= max ( koprns(i), 1) xnsecs(i) = time(i) * 1.d9 / koprns(i) 600 continue if ( lprblk ) & &write (6,6002) (i,time(i),koprns(i),kevent(i),xnsecs(i),i=1,2) 6002 format ('0 blkans timing and operation data ' & & ,/, (2x,i2,1h., f12.6,i14,i6,f12.6) ) return END subroutine blkans ! **deck blkapp subroutine blkapp (n,lint,llu,kpp,kqq,kp,kq,aqp,app) implicit double precision (a-h,o-z) dimension aqp(1), app(kpp,kpp) integer pp,qq,p,q !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk dimension time(5), kevent(5), koprns(5), xnsecs(5) INTRINSIC:: CPU_TIME !------------------------------------------------------------------------------- call zero (time,5) call jzero (kevent,5) call jzero (koprns,5) call CPU_TIME (t1) ! ! pp = kpp qq = kqq p = kp q = kq ! ! ! nrowl = n - (q-1)*qq ncoll = n - (p-1)*pp nrl = ncoll ncl = ncoll jrec = 0 ! do 400 ip = 1,p irow = 0 itot = 0 do 300 iq = 1,q nrow = qq if ( iq.eq.q ) nrow = nrowl ncol = pp if ( ip.eq.p ) ncol = ncoll nw = nrow*ncol irec = ip + (iq-1)*p nwx = nw call CPU_TIME (ta) call readmd (lint,aqp,nwx,irec) call CPU_TIME (tb) time(1) = time(1) + tb-ta kevent(1)= kevent(1) + 1 koprns(1)= koprns(1) + nwx lqp = 1 do 200 iqq = 1,nrow irow = irow + 1 itot = itot + 1 call dcopy (ncol,aqp(lqp),1, app(irow,1),pp) lqp = lqp + ncol if (irow.lt.pp .and. itot.lt.n) go to 200 irow = 0 jrec = jrec + 1 ja = (jrec-1)/p + 1 ia = jrec - (ja-1)*p nr = pp if ( ia.eq.p ) nr = nrl nc = pp if ( ja.eq.p ) nc = ncl nw = nr*nc if ( ia.eq.ja ) nw = nw + nr call CPU_TIME (ta) call blkmsw (llu, app,pp,nr,nc, nw, jrec+1) call CPU_TIME (tb) time(2) = time(2) + tb-ta kevent(2)= kevent(2) + 1 koprns(2)= koprns(2) + nw 200 continue 300 continue 400 continue ! ! call CPU_TIME (t2) tval = t2 - t1 if ( lprblk ) & &write (6,6001) tval 6001 format ('0 ***** blkapp total time ',f12.6) do 600 i = 1,2 time(i) = max( time(i), 1.d-12) koprns(i)= max ( koprns(i), 1) xnsecs(i) = time(i) * 1.d9 / koprns(i) 600 continue if ( lprblk ) & &write (6,6002) (i,time(i),koprns(i),kevent(i),xnsecs(i),i=1,2) 6002 format ('0 blkapp timing and operation data ' & & ,/, (2x,i2,1h., f12.6,i14,i6,f12.6) ) return END subroutine blkapp ! **deck blkaqp subroutine blkaqp (n,lmat,lint,pp,qq,p,q,a,aq) implicit double precision (a-h,o-z) dimension a(1), aq(1) integer pp,qq,p,q !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk dimension time(5), kevent(5), koprns(5), xnsecs(5) INTRINSIC:: CPU_TIME !------------------------------------------------------------------------------- call zero (time,5) call jzero (kevent,5) call jzero (koprns,5) call CPU_TIME (t1) ! ! ! ir2 = 0 do 500 iq = 1,q ir1 = ir2 + 1 ir2 = min (ir2+qq,n) nrow = qq if ( iq.eq.q ) nrow = n - (q-1)*qq do 200 ir = ir1,ir2 nx = n call CPU_TIME (ta) call readmd (lmat,a,nx,ir) call CPU_TIME (tb) time(1) = time(1) + tb-ta kevent(1)= kevent(1) + 1 koprns(1)= koprns(1) + nx do 100 ip = 1,p ncol = pp if ( ip.eq.p ) ncol = n - (p-1)*pp laq = (ip-1)*nrow*pp + 1 + ncol*(ir-ir1) la = (ip-1)*pp + 1 call dcopy (ncol, a(la),1, aq(laq),1) 100 continue 200 continue do 300 ip = 1,p laq = (ip-1)*nrow*pp + 1 ncol = pp if ( ip.eq.p ) ncol = n - (p-1)*pp nw = nrow*ncol irec = ip + p*(iq-1) call CPU_TIME (ta) call writmd (lint,aq(laq),nw,irec, -1,0) call CPU_TIME (tb) time(2) = time(2) + tb-ta kevent(2)= kevent(2) + 1 koprns(2)= koprns(2) + nw 300 continue 500 continue ! ! call CPU_TIME (t2) tval = t2 - t1 if ( lprblk ) & &write (6,6001) tval 6001 format ('0 ***** blkaqp total time ',f12.6) do 600 i = 1,2 time(i) = max( time(i), 1.d-12) koprns(i)= max ( koprns(i), 1) xnsecs(i) = time(i) * 1.d9 / koprns(i) 600 continue if ( lprblk ) & &write (6,6002) (i,time(i),koprns(i),kevent(i),xnsecs(i),i=1,2) 6002 format ('0 blkaqp timing and operation data ' & & ,/, (2x,i2,1h., f12.6,i14,i6,f12.6) ) return END subroutine blkaqp ! **deck blkdcr subroutine blkdcr (a,ip,n,na,ier,amin,s) implicit double precision (a-h,o-z) dimension a(na,n), ip(n) dimension s(1) integer p ! ier = 0 do 10 i = 1,n ip(i) = i 10 continue ! ! do 100 k = 1,n ier = k if ( k.gt.1 ) & & call hsmvp3 (n+1-k,k-1, a(k,1),1,na, a(1,k),1, a(k,k),1) p = idamax(n-k+1, a(k,k), 1) +k-1 ! *** p = k if ( p.eq.k ) go to 20 call dswap (n, a(p,1),na, a(k,1),na) isv = ip(p) ip(p) = ip(k) ip(k) = isv 20 continue if ( k.gt.1 .and. k.lt.n ) & & call hsmvp3 (n-k,k-1, a(1,k+1),na,1, a(k,1),na, a(k,k+1),na) ! ** x call mxmacs (a(k,1),1,na, a(1,k+1),1,na, a(k,k+1),1,na ! ** x ,1,k-1,n-k) if ( a(k,k).eq.0.d0 ) goto 1000 ainv = 1.d0/a(k,k) if ( k.lt.n ) call dscal (n-k,ainv,a(k+1,k),1) 100 continue ! ! ier = 0 ! ! ! amin = abs(a(1,1)) amax = amin kmin = 1 kmax = 1 do 110 k = 2,n if ( amin .gt. abs(a(k,k)) ) kmin = k if ( kmin.eq.k ) amin = abs(a(k,k)) if ( amax .lt. abs(a(k,k)) ) kmax = k if ( kmax.eq.k ) amax = abs(a(k,k)) 110 continue if ( amin .lt. 1.d-8*amax ) ier = kmin if ( amin .lt. 1.d-8*amax ) go to 1000 return ! ! ! 1000 continue k = ier call zero (s,n) call outvcx ('pivot col',n+1-k,a(k,k)) call dcopy (n+1-k, a(k,k),na, s(k),1) do 1200 j = 1,k-1 call daxpy (n+1-j, a(k,j), a(j,j),na, s(j),1) 1200 continue write (6,6001) k, ip(k), (a(k,j),j=1,n) 6001 format ('0 error in blkdcr. row k =',i6,' after factorization' & & ,' original row index = ',i6,' entries: (1,k-1)=multipliers,' & & ,' (k,n)=row of u' ,/, (2x, 1p,10e12.4) ) write (6,6002) (s(j),j=1,n) 6002 format ('0 row before factorization was :',/,(2x,1p,10e12.4)) write (6,6003) (ip(j),j=1,n) 6003 format ('0 pivot vector (original row indices)',/,(2x,10i12)) write (6,6004) (a(j,j),j=1,n) 6004 format ('0 diagonals of u:' ,/,(2x,1p,10e12.4) ) ier = ip(k) return END subroutine blkdcr ! **deck blkfac subroutine blkfac (n,llu,pp,p, a,b,c,s, ier) implicit double precision (a-h,o-z) dimension a(1), b(1), c(1), s(1) integer pp,p,ppl !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk dimension time(20), kevent(20), koprns(20), xnsecs(20) INTRINSIC:: CPU_TIME !------------------------------------------------------------------------------- call zero (time,20) call jzero (kevent,20) call jzero (koprns,20) call CPU_TIME (t1) ! ! ! ppl = n - (p-1)*pp do 1000 k = 1,p call CPU_TIME (ta) write (0,'('' blkfac, stage '',2i6,f12.3)') k,p,ta do 200 j = k,p nrkj = pp if ( k.eq.p ) nrkj = ppl nckj = pp if ( j.eq.p ) nckj = ppl nwkj = nrkj*nckj if ( j.eq.k ) nwkj = nwkj + nrkj irkj = k + (j-1)*p + 1 call CPU_TIME (ta) call readmd (llu,a,nwkj,irkj) call CPU_TIME (tb) time(1) = time(1) + tb-ta kevent(1)= kevent(1) + 1 koprns(1)= koprns(1) + nwkj do 100 l = 1,k-1 nrkl = nrkj nckl = pp nwkl = nrkl*nckl irkl = k + (l-1)*p + 1 call CPU_TIME (ta) call readmd (llu,b,nwkl,irkl) call CPU_TIME (tb) time(2) = time(2) +tb-ta kevent(2)= kevent(2) + 1 koprns(2)= koprns(2) + nwkl ! nrlj = pp nclj = nckj nwlj = nrlj*nclj irlj = l + (j-1)*p + 1 call CPU_TIME (ta) call readmd (llu,c,nwlj,irlj) call CPU_TIME (tb) time(3) = time(3) + tb-ta kevent(3)= kevent(3) + 1 koprns(3)= koprns(3) + nwlj ! call CPU_TIME (ta) call hsmmp3 (nrkj,pp,nckj, b,1,nrkl, c,1,nrlj & & ,a,1,nrkj) call CPU_TIME (tb) time(4) = time(4) + tb-ta kevent(4)= kevent(4) + 1 koprns(4)= koprns(4) + 2*nrkj*pp*nckj 100 continue if ( k.ne.j ) go to 150 lpiv = nrkj**2 + 1 call CPU_TIME (ta) call blkdcr (a,a(lpiv), nrkj,nrkj, ier,amin,s) call CPU_TIME (tb) time(5) = time(5) + tb-ta kevent(5)= kevent(5) + 1 koprns(5)= koprns(5) + (2*nrkj*nrkj*nrkj)/3 if ( ier.eq.0 ) go to 150 write (6,6004) k,pp,ier 6004 format ('0 ***** errror detected in blkfac ***** ' & &,/,20x,'block number =',i5,' block size =',i5 & & ,' row in block =',i5 ) ier = ier + (k-1)*pp return 150 continue call CPU_TIME (ta) call writmd (llu,a,nwkj,irkj,-1,0) call CPU_TIME (tb) time(6) = time(6) + tb-ta kevent(6)= kevent(6) + 1 koprns(6)= koprns(6) + nwkj 200 continue ! ! ! do 400 i = k+1,p nrik = pp if ( i.eq.p ) nrik = ppl ncik = pp if ( k.eq.p ) ncik = ppl nwik = nrik*ncik irik = i + (k-1)*p + 1 call CPU_TIME (ta) call readmd (llu,c,nwik,irik) call CPU_TIME (tb) time(7) = time(7) + tb-ta kevent(7)= kevent(7) + 1 koprns(7)= koprns(7) + nwik do 300 l = 1,k-1 nril = nrik ncil = pp nwil = nril*ncil iril = i + (l-1)*p + 1 call CPU_TIME (ta) call readmd (llu,a,nwil,iril) call CPU_TIME (tb) time(8) = time(8) + tb-ta kevent(8)= kevent(8) + 1 koprns(8)= koprns(8) + nwil ! nrlk = pp nclk = ncik nwlk = nrlk*nclk irlk = l + (k-1)*p + 1 call CPU_TIME (ta) call readmd (llu,b,nwlk,irlk) call CPU_TIME (tb) time(9) = time(9) + tb-ta kevent(9)= kevent(9) + 1 koprns(9)= koprns(9) + nwlk ! call CPU_TIME (ta) call hsmmp3 (nrik,pp,ncik, a,1,nril, b,1,nrlk & & ,c,1,nrik) call CPU_TIME (tb) time(10) = time(10) + tb-ta kevent(10)= kevent(10) + 1 koprns(10)= koprns(10) + 2*nrik*pp*ncik 300 continue nwkk = pp*pp + pp irkk = k + (k-1)*p + 1 call CPU_TIME (ta) call readmd (llu,a,nwkk,irkk) call CPU_TIME (tb) time(11) = time(11) + tb-ta kevent(11)= kevent(11) + 1 koprns(11)= koprns(11) + nwkk lpiv = pp*pp + 1 call CPU_TIME (ta) call blkabi (c,nrik, a,pp, a(lpiv), b) call CPU_TIME (tb) time(12) = time(12) + tb-ta kevent(12)= kevent(12) + 1 koprns(12)= koprns(12) + 2*nrik*pp*pp call CPU_TIME (ta) call writmd (llu,c,nwik,irik,-1,0) call CPU_TIME (tb) time(13) = time(13) + tb-ta kevent(13)= kevent(13) + 1 koprns(13)= koprns(13) + nwik 400 continue 1000 continue ! ! ! call CPU_TIME (t2) tval = t2 - t1 if ( lprblk ) & &write (6,6003) tval 6003 format ('0 ***** blkfac total time ',f12.6) do 1100 i = 1,13 time(i) = max( time(i), 1.d-12) koprns(i)= max ( koprns(i), 1) xnsecs(i) = 1.d9 * time(i) / koprns(i) 1100 continue ! ! ! tfloat = time(4) + time(5) + time(10) + time(12) nfloat = koprns(4) + koprns(5) + koprns(10) + koprns(12) xmflop = nfloat/(1.d6*tfloat) if ( lprblk ) & &write (6,6001) tfloat,nfloat,xmflop 6001 format (' blkfac timing:',f12.6,' fp oprns:',i12 & & ,' mflops:',f12.6 ) if ( lprblk ) & &write (6,6002) (i,time(i),koprns(i),kevent(i),xnsecs(i),i=1,13) 6002 format ('0 blkfac timing and operation data ' & & ,/, (2x,i2,1h., f12.6,i14,i6,f12.6) ) return END subroutine blkfac ! **deck blkmsw subroutine blkmsw (lmat, a,na,m,n, nw, irec) implicit double precision (a-h,o-z) dimension a(1) ! ! ! if ( na.eq.m ) go to 110 l = m + 1 ij = na + 1 do 100 j = 2,n call dcopy (m, a(ij),1, a(l),1) l = l + m ij = ij + na 100 continue ! 110 continue call writmd (lmat,a,nw,irec, -1,0) return END subroutine blkmsw ! **deck blkmxw subroutine blkmxw (lmat, a,na,m,n, nw, irec) implicit double precision (a-h,o-z) dimension a(1) ! ! ! if ( na.eq.m ) go to 110 l = m + 1 ij = na + 1 do 100 j = 2,n call dcopy (m, a(ij),1, a(l),1) l = l + m ij = ij + na 100 continue ! 110 continue call blkwbx (lmat,a,nw,irec, -1,0) return END subroutine blkmxw ! **deck blkrbx subroutine blkrbx (lunit,a,na,irec) implicit double precision (a-h,o-z) dimension a(na) !call cmsolv ! /cmsolv/ ! data for 'blk' pkg to do in-memory solution common /cmsolv/ bxcmsv, ppsv, llbxsv, nrhssv !end cmsolv logical bxcmsv integer ppsv ! !----- pointer (llbxsv,b(1)) dimension b(1) if ( bxcmsv ) go to 100 call readmd (lunit,a,na,irec) return ! 100 continue iadd = (irec-1)*ppsv*nrhssv + 1 call dcopy (na, b(iadd),1, a,1) return END subroutine blkrbx ! **deck blkrhs subroutine blkrhs (n,m, lrhs,lbn, b,bpm,pp) implicit double precision (a-h,o-z) integer pp dimension b(1), bpm(pp,m) !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk integer p ! dimension time(5), kevent(5), koprns(5), xnsecs(5) INTRINSIC:: CPU_TIME !------------------------------------------------------------------------------- call zero (time,5) call jzero (kevent,5) call jzero (koprns,5) call CPU_TIME (t1) ! ! ! p = (n+pp-1)/pp nbrhs = (m + pp - 1)/pp ip = 0 do 200 ibrhs = 1,nbrhs lb = 1 + pp*(ibrhs-1) rewind lrhs nc = pp if ( ibrhs .eq. nbrhs ) nc = m - pp*(ibrhs-1) irow = 0 itot = 0 do 100 i = 1,n call CPU_TIME (ta) read (lrhs) (b(j),j=1,m) call CPU_TIME (tb) time(1) = time(1) + tb-ta kevent(1)= kevent(1) + 1 koprns(1)= koprns(1) + m irow = irow + 1 itot = itot + 1 call dcopy (nc, b(lb),1, bpm(irow,1),pp) if ( irow.lt.pp .and. itot.lt.n ) go to 100 ip = ip + 1 nr = irow nw = nr*nc call CPU_TIME (ta) call blkmxw (lbn, bpm,pp,nr,nc, nw, ip) call CPU_TIME (tb) time(2) = time(2) + tb-ta kevent(2)= kevent(2) + 1 koprns(2)= koprns(2) + nw irow = 0 100 continue 200 continue call CPU_TIME (t2) tval = t2 - t1 if ( lprblk ) & &write (6,6001) tval 6001 format ('0 ***** blkrhs total time ',f12.6) do 600 i = 1,2 time(i) = max( time(i), 1.d-12) koprns(i)= max ( koprns(i), 1) xnsecs(i) = time(i) * 1.d9 / koprns(i) 600 continue if ( lprblk ) & &write (6,6002) (i,time(i),koprns(i),kevent(i),xnsecs(i),i=1,2) 6002 format ('0 blkrhs timing and operation data ' & & ,/, (2x,i2,1h., f12.6,i14,i6,f12.6) ) return END subroutine blkrhs ! **deck blksit subroutine blksit (n,a,ip,b) implicit double precision (a-h,o-z) dimension a(n,n), ip(n), b(n) ! ! calculate x = a(-t)*b and return x in b ! do 100 i = 1,n if ( i.gt.1 ) call vips (b,1, a(1,i),1, i-1, b(i)) b(i) = b(i)/a(i,i) 100 continue ! nm1 = n - 1 do 200 i = nm1,1,-1 call vips (b(i+1),1, a(i+1,i),1, n-i, b(i)) 200 continue ! call ukysrd (n,b,ip) ! return END subroutine blksit ! **deck blkslv subroutine blkslv (n,m, llu,lbn, bpm,xpm,a,pp) implicit double precision (a-h,o-z) integer pp dimension bpm(1), xpm(1), a(1) !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk integer p,ppl dimension time(20), kevent(20), koprns(20) INTRINSIC:: CPU_TIME !------------------------------------------------------------------------------- call zero (time,20) call jzero (kevent,20) call jzero (koprns,20) call CPU_TIME (t1) ! ! ! p = (n+pp-1)/pp ppl = n - (p-1)*pp nbrhs = (m + pp - 1)/pp do 850 ibrhs = 1,nbrhs ipbias = (ibrhs-1)*p ncb = pp if ( ibrhs .eq. nbrhs ) ncb = m - pp*(ibrhs-1) ! do 400 ip = 2,p nr = pp if ( ip.eq.p ) nr = ppl nw = nr*ncb call CPU_TIME (ta) call blkrbx (lbn,bpm,nw,ip+ipbias) call CPU_TIME (tb) time(1) = time(1) + tb-ta kevent(1)= kevent(1) + 1 koprns(1)= koprns(1) + nw do 300 jp = 1,ip-1 nrx = pp ncx = ncb nwx = nrx*ncx call CPU_TIME (ta) call blkrbx (lbn,xpm,nwx,jp+ipbias) call CPU_TIME (tb) time(2) = time(2) + tb-ta kevent(2)= kevent(2) + 1 koprns(2)= koprns(2) + nwx ! nra = nr nca = pp nwa = nra*nca irec = ip + (jp-1)*p + 1 call CPU_TIME (ta) call readmd (llu,a,nwa,irec) call CPU_TIME (tb) time(3) = time(3) + tb-ta kevent(3)= kevent(3) + 1 koprns(3)= koprns(3) + nwa call CPU_TIME (ta) call hsmmp3 (nr,nca,ncb, a,1,nra, xpm,1,nrx, bpm,1,nr) call CPU_TIME (tb) time(4) = time(4) + tb-ta kevent(4)= kevent(4) + 1 koprns(4) = koprns(4) + 2*nr*nca*ncb 300 continue call CPU_TIME (ta) call blkwbx (lbn,bpm,nw,ip+ipbias, -1,0) call CPU_TIME (tb) time(5) = time(5) + tb-ta kevent(5)= kevent(5) + 1 koprns(5)= koprns(5) + nw 400 continue ! ! ! do 800 ip = p,1,-1 nr = pp if ( ip.eq.p ) nr = ppl nw = nr*ncb call CPU_TIME (ta) call blkrbx (lbn,bpm,nw,ip+ipbias) call CPU_TIME (tb) time(6) = time(6) + tb-ta kevent(6)= kevent(6) + 1 koprns(6)= koprns(6) + nw do 700 jp = ip+1,p nrx = pp if ( jp.eq.p ) nrx = ppl ncx = ncb nwx = nrx*ncx call CPU_TIME (ta) call blkrbx (lbn,xpm,nwx,jp+ipbias) call CPU_TIME (tb) time(7) = time(7) + tb-ta kevent(7)= kevent(7) + 1 koprns(7)= koprns(7) + nwx nra = nr nca = pp if ( jp.eq.p ) nca = ppl nwa = nra*nca irec = ip + (jp-1)*p + 1 call CPU_TIME (ta) call readmd (llu,a,nwa,irec) call CPU_TIME (tb) time(8) = time(8) + tb-ta kevent(8)= kevent(8) + 1 koprns(8)= koprns(8) + nwa ! ! call CPU_TIME (ta) call hsmmp3 (nr,nca,ncb, a,1,nra, xpm,1,nrx, bpm,1,nr) call CPU_TIME (tb) time(9) = time(9) + tb-ta kevent(9)= kevent(9) + 1 koprns(9) = koprns(9) + 2*nr*nca*ncb 700 continue irec = ip + (ip-1)*p + 1 nwa = nr*nr + nr call CPU_TIME (ta) call readmd (llu,a,nwa,irec) call CPU_TIME (tb) time(10) = time(10) + tb-ta kevent(10)= kevent(10) + 1 koprns(10)= koprns(10) + nwa lpiv = nr*nr + 1 call CPU_TIME (ta) call blksvn (nr,a,a(lpiv), bpm,xpm,ncb) call CPU_TIME (tb) time(11) = time(11) + tb-ta kevent(11)= kevent(11) + 1 koprns(11) = koprns(11) + 2*nr*nr*ncb ! call CPU_TIME (ta) call blkwbx (lbn,bpm,nw,ip+ipbias, -1,0) call CPU_TIME (tb) time(12) = time(12) + tb-ta kevent(12)= kevent(12) + 1 koprns(12)= koprns(12) + nw 800 continue ! 850 continue ! ! call CPU_TIME (t2) tval = t2 - t1 if ( lprblk ) & &write (6,6001) tval 6001 format ('0 ***** blkslv total time ',f12.6) do 900 i = 1,12 time(i) = max( time(i), 1.d-12) koprns(i)= max ( koprns(i), 1) xmflop = koprns(i)/( 1.d6 * time(i) ) xnsec = 1.d9 * time(i) / koprns(i) if ( lprblk ) & & write (6,6002) i, time(i), koprns(i), kevent(i), xnsec, xmflop 6002 format (2x,i2,1h.,f12.6,i12,i6,2f12.6) 900 continue return END subroutine blkslv ! **deck blkstn subroutine blkstn (n,a,ip, b,x,m) implicit double precision (a-h,o-z) dimension a(n,n), ip(n), b(n,m), x(n,m) ! ! t ! solve the m systems: A x(*,1:m) = b(*,1:m) ! ! if ( m.lt.10 ) go to 600 ! ! do 300 i = 1,n if ( i.gt.1 ) & & call hsmvp3 (m,i-1, b,n,1, a(1,i),1, b(i,1),n) ainv = 1.d0/a(i,i) call dscal (m, ainv, b(i,1),n) 300 continue ! do 500 i = n,1,-1 if ( i.lt.n ) & & call hsmvp3 (m,n-i, b(i+1,1),n,1, a(i+1,i),1, b(i,1),n) 500 continue ! do 550 i = 1,n ipi = ip(i) do 520 j = 1,m x(ipi,j) = b(i,j) 520 continue 550 continue call dcopy (m*n, x,1, b,1) ! return ! ! special code for small values of m (m<10) ! 600 continue do 1000 j = 1,m ! do 800 i = 1,n if ( i.gt.1 ) & & b(i,j) = b(i,j) - ddot(i-1, a(1,i),1, b(1,j),1) b(i,j) = b(i,j)/a(i,i) 800 continue ! do 900 i = n,2,-1 fac = -b(i,j) call daxpy (i-1, fac, a(i,1),n, b(1,j),1) 900 continue ! do 950 i = 1,n x(ip(i),1) = b(i,j) 950 continue call dcopy (n, x,1, b(1,j),1) ! 1000 continue return END subroutine blkstn ! **deck blksv1 subroutine blksv1 (n,a,ip,b) implicit double precision (a-h,o-z) dimension a(n,n), b(n), ip(n) ! call keysrd (n,b,ip) do 100 i = 2,n call vips (b,1, a(i,1),n, i-1,b(i)) 100 continue ! do 200 i = n,1,-1 if ( i.lt.n ) call vips (b(i+1),1, a(i,i+1),n, n-i, b(i)) b(i) = b(i)/a(i,i) 200 continue return END subroutine blksv1 ! **deck blksvn subroutine blksvn (n,a,ip, b,x,m) implicit double precision (a-h,o-z) dimension a(n,n), ip(n), b(n,m), x(n,m) ! ! ! if ( m.lt.10 ) go to 600 ! ! do 100 i = 1,n ipi = ip(i) do 50 j = 1,m x(i,j) = b(ipi,j) 50 continue 100 continue call dcopy (m*n, x,1, b,1) ! do 300 i = 2,n ! *** call mxmacs (a(i,1),1,n, b,1,n, b(i,1),1,n, 1,i-1,m) call hsmvp3 (m,i-1, b,n,1, a(i,1),n, b(i,1),n) 300 continue ! do 500 i = n,1,-1 if ( i.lt.n ) & & call hsmvp3 (m,n-i, b(i+1,1),n,1, a(i,i+1),n, b(i,1),n) ainv = 1.d0/a(i,i) do 400 j = 1,m b(i,j) = ainv*b(i,j) 400 continue 500 continue return ! ! ! 600 continue do 1000 j = 1,m ! do 700 i = 1,n x(i,1) = b(ip(i),j) 700 continue call dcopy (n, x,1, b(1,j),1) ! do 800 i = 2,n ! *** call vips (b(1,j),1, a(i,1),n, i-1, b(i,j) ) fac = -b(i-1,j) call daxpy (n+1-i, fac, a(i,i-1),1, b(i,j),1) 800 continue ! do 900 i = n,1,-1 ! *** if ( i.lt.n ) call vips (b(i+1,j),1, a(i,i+1),n, n-i,b(i,j)) b(i,j) = b(i,j)/a(i,i) fac = -b(i,j) if ( i.gt.1 ) call daxpy (i-1, fac, a(1,i),1, b(1,j),1) 900 continue 1000 continue return END subroutine blksvn ! **deck blksvt subroutine blksvt (n,m, llu,lbn, bpm,xpm,a,pp) implicit double precision (a-h,o-z) integer pp dimension bpm(1), xpm(1), a(1) ! ! solve the block transposed system: ! ! t ! [ A(1,1) ] ! t t ! [ A(1,2) A(2,2) ] ! t t t ! [ A(1,3) A(2,3) A(3,3) ] * ! ! [ . . . . . . . . . . . . . . . . ] ! t t t t ! [ A(1,p) A(2,p) A(3,p) . . . A(p,p) ] ! ! ! t t t ! [ I A(2,1) A(3,1) . . . . A(p,1) ] [x(1)] [b(1)] ! t t ! [ I A(3,2) . . . . A(p,2) ] [x(2)] [b(2)] ! t ! [ I . . . . A(p,3) ]*[x(3)] =[b(3)] ! ! [ . . . . . . . . . . . . . . . ] ! ! [ I ] [x(p)] [b(p)] ! !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk integer p,ppl dimension time(20), kevent(20), koprns(20) ! ! call zero (time,20) call jzero (kevent,20) call jzero (koprns,20) call CPU_TIME (t1) ! ! ! p = (n+pp-1)/pp ppl = n - (p-1)*pp nbrhs = (m + pp - 1)/pp do 850 ibrhs = 1,nbrhs ipbias = (ibrhs-1)*p ncb = pp if ( ibrhs .eq. nbrhs ) ncb = m - pp*(ibrhs-1) ! do 400 ip = 1,p nr = pp if ( ip.eq.p ) nr = ppl nw = nr*ncb call CPU_TIME (ta) call blkrbx (lbn,bpm,nw,ip+ipbias) call CPU_TIME (tb) time(1) = time(1) + tb-ta kevent(1)= kevent(1) + 1 koprns(1)= koprns(1) + nw do 300 jp = 1,ip-1 ! read x(jp) [ pp x ncb ] nrx = pp ncx = ncb nwx = nrx*ncx call CPU_TIME (ta) call blkrbx (lbn,xpm,nwx,jp+ipbias) call CPU_TIME (tb) time(2) = time(2) + tb-ta kevent(2)= kevent(2) + 1 koprns(2)= koprns(2) + nwx ! read A(jp,ip) [ pp x nr ] nca = nr nra = pp nwa = nra*nca irec = jp + (ip-1)*p + 1 call CPU_TIME (ta) call readmd (llu,a,nwa*ityprc,irec) call CPU_TIME (tb) time(3) = time(3) + tb-ta kevent(3)= kevent(3) + 1 koprns(3)= koprns(3) + nwa call CPU_TIME (ta) if ( ityprc.eq.1 ) & & call hsmmp3 (nr,nra,ncb, a,nra,1, xpm,1,nrx, bpm,1,nr) if ( ityprc.eq.2 ) & & call hcmmp3 (nr,nra,ncb, a,nra,1, xpm,1,nrx, bpm,1,nr) call CPU_TIME (tb) time(4) = time(4) + tb-ta kevent(4)= kevent(4) + 1 koprns(4) = koprns(4) + 2*nr*nca*ncb 300 continue ! irec = ip + (ip-1)*p + 1 nwa = nr*nr + nr call CPU_TIME (ta) call readmd (llu,a,nwa*ityprc,irec) call CPU_TIME (tb) time(10) = time(10) + tb-ta kevent(10)= kevent(10) + 1 koprns(10)= koprns(10) + nwa lpiv = nr*nr + 1 call CPU_TIME (ta) call blkstn (nr,a,a(lpiv), bpm,xpm,ncb) call CPU_TIME (tb) time(11) = time(11) + tb-ta kevent(11)= kevent(11) + 1 koprns(11) = koprns(11) + 2*nr*nr*ncb ! call CPU_TIME (ta) call blkwbx (lbn,bpm,nw,ip+ipbias, -1,0) call CPU_TIME (tb) time(5) = time(5) + tb-ta kevent(5)= kevent(5) + 1 koprns(5)= koprns(5) + nw 400 continue ! ! ! do 800 ip = p-1,1,-1 nr = pp if ( ip.eq.p ) nr = ppl nw = nr*ncb call CPU_TIME (ta) call blkrbx (lbn,bpm,nw,ip+ipbias) call CPU_TIME (tb) time(6) = time(6) + tb-ta kevent(6)= kevent(6) + 1 koprns(6)= koprns(6) + nw do 700 jp = ip+1,p ! read x(jp) nrx = pp if ( jp.eq.p ) nrx = ppl ncx = ncb nwx = nrx*ncx call CPU_TIME (ta) call blkrbx (lbn,xpm,nwx,jp+ipbias) call CPU_TIME (tb) time(7) = time(7) + tb-ta kevent(7)= kevent(7) + 1 koprns(7)= koprns(7) + nwx ! read A(jp,ip) [ pp x nr ] or ! [ ppl x nr ] nca = nr nra = pp if ( jp.eq.p ) nra = ppl nwa = nra*nca irec = jp + (ip-1)*p + 1 call CPU_TIME (ta) call readmd (llu,a,nwa*ityprc,irec) call CPU_TIME (tb) time(8) = time(8) + tb-ta kevent(8)= kevent(8) + 1 koprns(8)= koprns(8) + nwa ! ! call CPU_TIME (ta) if ( ityprc.eq.1 ) & & call hsmmp3 (nr,nra,ncb, a,nra,1, xpm,1,nrx, bpm,1,nr) if ( ityprc.eq.2 ) & & call hcmmp3 (nr,nra,ncb, a,nra,1, xpm,1,nrx, bpm,1,nr) call CPU_TIME (tb) time(9) = time(9) + tb-ta kevent(9)= kevent(9) + 1 koprns(9) = koprns(9) + 2*nr*nca*ncb 700 continue ! call CPU_TIME (ta) call blkwbx (lbn,bpm,nw,ip+ipbias, -1,0) call CPU_TIME (tb) time(12) = time(12) + tb-ta kevent(12)= kevent(12) + 1 koprns(12)= koprns(12) + nw 800 continue ! 850 continue ! ! call CPU_TIME (t2) tval = t2 - t1 if ( lprblk ) & &write (6,6001) tval 6001 format ('0 ***** blksvt total time ',f12.6) do 900 i = 1,12 time(i) = max( time(i), 1.d-12) koprns(i)= max ( koprns(i), 1) xmflop = koprns(i)/( 1.d6 * time(i) ) xnsec = 1.d6 * time(i) / koprns(i) if ( lprblk ) & & write (6,6002) i, time(i), koprns(i), kevent(i), xnsec, xmflop 6002 format (2x,i2,1h.,f12.6,i12,i12,2f12.6) 900 continue return END subroutine blksvt ! **deck blksze subroutine blksze (si,ni,nxi, ppi,qqi,qval) implicit double precision (a-h,o-z) integer si,ni,nxi, ppi,qqi,qval(1) ! !call blkprt ! /blkprt/ ! print flag for 'blk' pkg, out-of-core solver common /blkprt/ lprblk !end blkprt logical lprblk ! ! integer pmax, pmin, qmax, qmin, s, n, nx, pp, qq, p, q integer qdmin, qdmax, qcmin, qcmax, ppx, qqx, ppz, qqz ! ! ! ppi = 0 qqi = 0 s = si - 100 n = ni nx = nxi if ( s.le.n ) go to 900 call jzero (qval,n) if ( n*(n+nx) .gt. s ) go to 100 ! =========== force out of core solution ================= go to 100 ! in core solution is possible ppi = n qqi = 0 go to 900 ! 100 continue call jzero (qval,n) xn = n xs = s xsb = s - n d = 1.d0 - 12.d0* (xn/xs)**2 if ( d.le.0.d0 ) go to 900 pmax = sqrt( s*( 1.d0+sqrt(d) )/6.d0 ) pmin = sqrt( s*( 1.d0-sqrt(d) )/6.d0 ) pmax = max ( 1, min ( n,pmax)) pmin = max ( 1, min ( n,pmin)) if ( pmax.ne.n ) pmax = pmax - mod(pmax-1,4) if ( pmax .lt. pmin ) go to 900 ppx = 0 ioreqz = 1.d9 ! ntest = 0 do 300 pp = pmax,pmin,-4 xpp = pp p = (n+pp-1)/pp ne = 3*pp*pp + p*p+2 + 2*pp ! find a bound on scratch req'd of bkso nrhs = n+10 nbrhs = (nrhs+pp-1)/pp neslv = 3*pp*pp + pp + nrhs + 3 + p*p + p*nbrhs ne = max( ne, neslv) if ( ne.gt.s ) go to 300 d = xpp*( xs - (xn/xpp)**2 - pp**2 ) if ( d.le.0.d0 ) go to 300 qdmin = (n*n)/d qdmin = max ( 1, min (n, qdmin) ) d = 1.d0 - 4.d0*xn*xn*xn/(xpp*xsb*xsb) if ( d.le.0.d0 ) go to 300 d = sqrt(d) qcmin = xsb*(1.d0-d)/(2.d0*xn) qcmax = xsb*(1.d0+d)/(2.d0*xn) if ( qcmin.gt.qcmax ) go to 300 qmin = max ( qcmin, qdmin) qmax = min ( qcmax, pp) if ( qmin.gt.qmax ) go to 300 do 200 qq = qmax,qmin,-1 ntest = ntest + 1 q = (n+qq-1)/qq nc = p*q+1 + n*(qq+1) nd = p*q+1 + p*p+2 + pp*pp + qq*pp if ( nd.gt.s ) go to 300 if ( nc.gt.s ) go to 200 ! qval(pp) = qq ioreq = q*p*2 + p*p + (2*p*p*p)/3 if ( ioreq .ge. ioreqz ) go to 150 ioreqz = ioreq ppz = pp qqz = qq 150 continue if ( ppx.ne.0 ) go to 160 ioreqx = ioreq ppx = pp qqx = qq 160 continue go to 300 ! 200 continue ! 300 continue ! ! ! if ( ppx.eq.0 ) go to 800 if ( lprblk ) & &write (6,6000) ppx, qqx, ioreqx, ppz, qqz, ioreqz, ntest, n 6000 format ('0 largest pp =',i5,' qq = ',i5,' ioreq = ',i7 & & ,/, ' best io pp =',i5,' qqz= ',i5,' ioreqz= ',i7,2i10) ! ! ! pmin = max (pmin,ppx-10) do 500 pp = ppx,ppx qq = qval(pp) if ( qq.eq.0 ) goto 500 p = (n+pp-1)/pp q = (n+qq-1)/qq nc = p*q+1 + n*(qq+1) nd = p*q+1 + p*p+2 + pp*pp + qq*pp ne = 3*pp*pp + p*p+2 + 2*pp ncde = max ( nc, nd, ne) if ( lprblk ) & & write (6,6100) pp, qq, p, q, nc, nd, ne, s, ncde 500 continue 6100 format (' pp',i4,' qq',i4,' p',i4,' q',i4,' nc',i6,' nd',i6 & & ,' ne',i6,' s',i6,' ncde',i6) ! ppi = ppx qqi = qqx ! 800 continue 900 continue return END subroutine blksze ! **deck blkwbx subroutine blkwbx (lunit,a,na,irec, k1,k2) implicit double precision (a-h,o-z) dimension a(na) !call cmsolv ! /cmsolv/ ! data for 'blk' pkg to do in-memory solution common /cmsolv/ bxcmsv, ppsv, llbxsv, nrhssv !end cmsolv logical bxcmsv integer ppsv ! !----- pointer (llbxsv,b(1)) dimension b(1) if ( bxcmsv ) go to 100 call writmd (lunit,a,na,irec, k1,k2) return ! 100 continue iadd = (irec-1)*ppsv*nrhssv + 1 call dcopy (na, a,1, b(iadd),1) return END subroutine blkwbx ! **deck block subroutine block implicit double precision (a-h,o-z) logical error !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call brwi parameter (nsbp=6) common/brwi/nbdq,nsb,nrb,ntb,nnb,nib((maxcp+nsbp-1)/nsbp+1) !end brwi !call crwi parameter (nscp=13) common/crwi/ncdq,nsc,nrc,ntc,nnc,nic((maxcp+nscp-1)/nscp+1) !end crwi !call srwi common/srwi/nsdq,nss,nrs,nts,nns,nis(maxpan+1) !end srwi !call vrwi common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp) !end vrwi !call yrwi common /yrwi/ ntyrwi, nnyrwi, nwyrwi(200), niyrwi(202) !end yrwi !ca vfgrwi ! /vfgrwi/ ! File for containing fine grid velocity data, 1 record/network ! ntvfg unit number [45] ! nnvfg number of records [nnett+1], 1 per nw + index record ! nivfg index array of dimension [mxnett+1] ! common /vfgrwi/ ntvfg, nnvfg, nivfg(mxnett+1) !end vfgrwi !ca vsprwi ! /vsprwi/ ! File for containing interior grid pt v-splines ! ntvsp unit number [46] ! nnvsp number of records [nnett+1], 1 per nw + index record ! nivsp index array of dimension [mxnett+1] ! common /vsprwi/ ntvsp, nnvsp, nivsp(mxnett+1) !end vsprwi !ca almrwi ! /almrwi/ ! File containing lambda fcns at panel centers, 1 record/network ! ntalm unit number [46] ! nnalm number of records [nnett+1], 1 per nw + index record ! nialm index array of dimension [mxnett+1] ! common /almrwi/ ntalm, nnalm, nialm(3*mxnett+1) !end almrwi !ca c2grwi ! /c2grwi/ ! File containing spline info for dsnfmc to generate surface ! velocity distributions from panel center velocity data. ! ! ntc2g unit number [49] ! nnc2g number of records [3*nnett+1], 3 per nw + index record ! nic2g index array of dimension [mxnett+1] ! common /c2grwi/ ntc2g, nnc2g, nic2g(5*mxnett+1) !end c2grwi !ca dcprwi ! /dcprwi/ ! File containing U&L d(cp)/d(n~) at panel centers, 1 record/network ! ntdcp unit number [47] ! nndcp number of records [nnett+1], 1 per nw + index record ! nidcp index array of dimension [mxnett+1] ! common /dcprwi/ ntdcp, nndcp, nidcp(mxnett+1) !end dcprwi !ca phxrwi ! /phxrwi/ ! File containing phx sensitivity influence coefficients ! ! ndqphx number of floating point words per record ! ntphx unit number [68] ! nnphx number of records [maxcp+1] ! niphx index array ! common /phxrwi/ ndqphx, ntphx, nnphx, niphx(maxcp+1) !end phxrwi !ca dsnrwi ! /dsnrwi/ ! File containing /pandsn/ data for a reference singularity set ! ! ndqdsn number of floating point words per record ! ntdsn unit number [67] ! nndsn number of records [maxpan+1] ! nidsn index array ! common /dsnrwi/ ndqdsn, ntdsn, nndsn, nidsn(maxpan+1) !end dsnrwi !call xrwi common /xrwi/ ntxrwi, nnxrwi, nwxrwi(200), nixrwi(202) !end xrwi !call irwi common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21) !end irwi !call xcntrl common /xcntrl/ icntrl,jcntrl !end xcntrl !call lamrwi common /lamrwi/ ntlam, nnlam, nilam(302) !end lamrwi common /bgnblk/ blk(1),nsbx, nrbx, nscx, nrcx !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call bcon common /bcon/ & & cu1,cl1,tu1(3),tl1(3),du1,dl1,bet1(4),nct1,nlopt1,nropt1,necpt1 & & ,klopt1,kldum1,betin1(4) & & ,cu2,cl2,tu2(3),tl2(3),du2,dl2,bet2(4),nct2,nlopt2,nropt2,necpt2 & & ,klopt2,kldum2,betin2(4) & & ,ndbcon !end bcon dimension cu1x(14), cu2x(14) equivalence (cu1,cu1x), (cu2,cu2x) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call curpan common/curpan/cpnorm(150) !end curpan !call fmcof common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof !end fmcof !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call pincl common/pincl/enx1,enx2,al1,al2 !end pincl !call solnt common/solnt/naic,nrhs,nans,nsc1,nsc2,nsc3,nsc4,iray(10),mtitle(5) !end solnt !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !... Visual Analyzer says that /index/ is different !... seems to be done to avoid name conflict with nts in both /index/ and /srwi/ ! common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & ! & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & ! & ,nmapca(151) & ! & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb common /index/ idumx(1506), ipot(150), nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !call indxsp common /indxsp/ nxsptt, nxspa(151), locxsp(1200) & & , ngsptt, ngspa(151), locgsp(1200) !end indxsp !call cm03 ! /cm03/ ! i/o units, unit position info, amp common /cm03/ iout, idmunt(5) !end cm03 !call cm05 ! /cm05/ ! case title info, used by ggp character*80 tid common /cm05/ tid !end cm05 !ca cinout ! /cinout/ common /cinout/ ntsin, ntsout !end cinout !call cm49 ! /cm49/ ! message number for old tinver package common/cm49/jobmes !end cm49 !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call cp2mcd ! /cp2mcd/: common region for list of all cp(second order) b.c.' ! jcncp2 = list of control points ! irwcp2 = list of aic rows ! inacp2 = list of corresponding entries in idcp2(1:3 parameter (maxcp2=1000) common /cp2mcd/ nbccp2, jcncp2(maxcp2), irwcp2(maxcp2) & & , inacp2(maxcp2) !end cp2mcd !call cp2aul ! /cp2aul/ = index for abutments having a cp(2nd order) ! matching condition. common /cp2aul/ ncp2ab, idcp2(3,50) & & , ablcp2(50), keycp2(50) integer ablcp2 !end cp2aul !call boundl ! /boundl/ common /boundl/ itapbl, ivcorr !end boundl !call titles common /titles/ title1(20),title2(20) character*4 title1, title2 !end titles !call datchk ! /datchk/ common/datchk/ndtchk !end datchk !call exdign ! /exdign/ common/exdign/nexdgn !end exdign !call factrd ! /factrd/ common /factrd/ ifact !end factrd !call nflowv ! * this common for calling overlay for off-body computation. ! * nflowv = 0 do not call (default value) ! * = 1 call ! * common /nflowv/ nflowv !end nflowv !call ofbod !** !** nof is the total number of offbody points generated by $xyz !** and $grids. !** common /ofbod/ nof !end ofbod !call kstmln !** !** this common is used to pass information to streamline !** overlay 14b. various global parameters are set in subroutine !** input !** !** nstmln - stream line computation flag !** = 0 no (default value) !** = 1 yes !** numpts - no of streamlines to be computed. maximum = 500 !** default = 0 !** hmin - absolute value of minimum step size allowed !** default = 0.0000001 !** hmax - absolute value of maximum step size allowed !** default = 10000.0 !** maxstm - maximum no. of integration points allowed per !** streamline. default = 1000 !** mxordr - maximum order allowed during integration. default=6 !** abserr - maximum error allowed in integration step !** default = 0.000001 !** mxarr1 - size of work array to be used. default = 10000 !** isprnt - print streamline file flag. !** = 1 print, = 0 doo not print (default) !** tpsl - type of streamline flag. !** =0.0 for mass flux. any other value gives !** velocity. !** tpoff - type of offbody point flag. !** = 0.0 for mass flux. any other value gives velocity. !** ntsmln - tape for streamline points. !** common /kstmln/ nstmln, numpts, hmin, hmax, maxstm, mxordr, & & abserr,mxarr1,isprnt,tpsl,tpoff,ntsmln & & , indvsl(4), ncassl !end kstmln !call lofdat common/lofdat/nloft,nslof,loft1,loft2,loft3 !end lofdat !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt ! I can't see any reason why /skrchs/ is in subroutine block. RLC !call skrchs !!! common/skrchs/cntq(512),bcdq(512),panq(1024) RLC !end skrchs ! force integer data type here to ! match r*4 in ctrns and btrns !!! integer cntq, bcdq, panq RLC !call symm common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym !end symm !call frwi common/frwi/nfdq,nsf,nrf,ntf,nref,ninf,nunf !end frwi !call bsqrwi common /bsqrwi/ nbsqdq, nsqb !end bsqrwi !call gsqrwi parameter (npagpx=400) common /gsqrwi/ nsqg, npagp, npngrp(npagpx), nspgrp(npagpx) & & , ndsgrp, nptgrp(npagpx) !end gsqrwi !call hsqrwi common /hsqrwi/ nsqh !end hsqrwi !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp !call lndblx ! /lndblx/ common /lndblx/ genwak(3,mxnett), slndbl(mxnett) & & , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett) !end lndblx !call nwlst common /cnwlst/ nwname(mxnett) character*10 nwname common /anwlst/ nnwlst !end nwlst !call chkpnt common /chkpnt/ nckaic, nckusp !end chkpnt !call epsff common /epsff/ eps1, eps2, eps3, eps4, eps5 & & , phc1, phc2, phc3 !end epsff common /mop3/dmop3( 3) common /mop5/dmop5( 2) common /mop6/dmop6(10) !call abtnew common /abtnew/ epsgeo, newabt, xtrint, xpidnt logical newabt logical xtrint logical xpidnt !end abtnew !call abtprt common /abtprt/ igeoin, igeout, nwxref, nwprop, iabutd & & , iabsum !end abtprt !call cp2flg ! /cp2flg/: newton iteration, lambda print and cp2 print flags common /cp2flg/ istcp2, iexcp2, nitcp2 !end cp2flg !call prtnor ! /prtnor/ common /prtnor/ nprten !end prtnor !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call agps ! common /agps/ jacase,iagpsf ! agpspc - all 3 components of the pressure coefficients on ! every panel for every case ! jacase - particular case being dealt with ! iagpsf - name of file having pressure data for agps plotting ! !end agps !call sginvc ! /sginvc/ common /sginvc/ eps,tol,q(6),v(96),b(36),qp(6),irank,mrank !end sginvc !call vicovr ! override vic specifications /vicovr/ common /vicovr/ nedflt(mxnett) ! /vicovr/ !end vicovr !call nwkrgn ! /nwkrgn/ region information for the upper/lower nw surfaces ! zctrgn(3,k) zctr for each network ! ntrgn total number of regions ! kinrgn(i) starting pointer in kptrgn for region i ! nsfrgn(i) number of surfaces bounding region i ! isfrgn(nlop) gives surface on which bc nlop is applied (1=u ! indrgn(1:2,k) region index for nw surfaces (1=u,2=l; k=nw-in ! kptrgn(2*nnett) equivalence class pointer structure for nw sur ! kbcrgn(k) error counter for 4/9 b.c.'s on nw k common /nwkrgn/ zctrgn(3,2,150) & & , ntrgn, kinrgn(100), nsfrgn(100), isfrgn(0:25) & & , indrgn(2,150), kptrgn(2*150) & & , kbcrgn(150) !end nwkrgn !ca dictms common /dictms/ nrecmx(100), llindx(100), ndirwr(100) & & , rwmstr & & , lldict, lldmax, indxms(2,800000) & & , buffms(512) integer buffms logical rwmstr !end dictms common /endblk/ bend ! ! * * * * * * * * * * * * ! ! fortran initialization is ! much more efficient on ! workstation machines iagpsf = 76 ! eps = 1.d-14 tol = 1.17d-38 ! ncs = 3 ncd = 9 ! /cm05/ error = .true. ! /cm49/ jobmes = 1 ! /cm03/ ntsin = 5 ntsout = 6 ! /solnt/ naic = 25 nrhs = 8 nans = 9 nsc1 = 10 nsc2 = 11 nsc3 = 12 nsc4 = 14 iray(1) = 190000 iray(2) = 27 iray(3) = 0 iray(4) = 9 iray(5) = 0 iray(6) = 19 iray(7) = 20 iray(8) = 12 iray(9) = 8 iray(10)= 0 ! /acase/ do 10 i = 1,4 alpha(i) = 0.d0 beta(i) = 0.d0 fsv(1,i) = 0.d0 fsv(2,i) = 0.d0 fsv(3,i) = 0.d0 fsvm(i) = 1.d0 10 continue nacase = 1 iacase = 1 ! /bcon/ do 20 i = 1,14 cu1x(i) = 0.d0 cu2x(i) = 0.d0 20 continue ! nct1 = 2 nlopt1 = 0 nropt1 = 0 necpt1 = 0 nct2 = 2 nlopt2 = 0 nropt2 = 0 necpt2 = 0 ! /brwi/ nbdq = locfcn(ndbcon) - locfcn(cu1) call dlocfx (nbdq) nbuffb = 512 nsb = nbuffb/nbdq nrb = 0 ntb = 1 ! /comprs/ amach = 0.d0 alpc = 0.d0 betc = 0.d0 ! /curpan/ do 30 i = 1,mxnett cpnorm(i) = 0.d0 30 continue ! /crwi/ ncdq = locfcn(ndcntq) - locfcn(zc(1)) call dlocfx (ncdq) nbuffc = 512 nsc = nbuffc/ncdq nrc = 0 ntc = 3 ! write msg about blocking of ntb,ntc if ( ntc.gt.0 ) goto 35 write (6,6001) nbuffb, nbdq, nsb, nsbp & & , nbuffc, ncdq, nsc, nscp 35 continue 6001 format ( & & ' blocking of bc and control pt data ' & & ,/,' data-type buff sz packet sz packets/buff (>= nom P/B)' & & ,/,' bndry-cond ',i6,' ',i6,' ',i6,' ',i6 & & ,/,' control-pt ',i6,' ',i6,' ',i6,' ',i6 & & ) ! /datchk/ ndtchk = 0 ! /fmcof/ xref = 0.d0 yref = 0.d0 zref = 0.d0 sref = 1.d0 bref = 1.d0 cref = 1.d0 dref = 1.d0 nprcof = 3 ! /kutta/ ! /index/ do 40 i = 1,mxnett ipot(i) = 0 40 continue nnwofb = 0 ! /ncons/ pi = 3.1415926535898d0 pi2 = 6.2831853071796d0 pi4i = 7.9577471545948d-2 twopi = 2.d0*pi pio2 = pi/2.d0 ! /prnt/ igeomp = 0 isingp = 0 icontp = -1 ibconp = 1 iedgep = 0 isings = 0 ipraic = 0 ipartp = 0 ioutpr = 1 ifmcpr = 1 iparts = 0 icostp = 0 iextrp = 0 ispmap = 0 icpmap = 0 ibcmap = 0 ! /frwi/ nfdq = 146 ntf = 16 nrf = 0 nsf = 7 nref = 247 ninf = 36 nunf = 27 ! /irwi/ nti = 15 nni = 21 ! /xrwi ntxrwi = 24 nnxrwi = 202 ! /yrwi/ ntyrwi = 38 nnyrwi = 202 ! /vfgrwi/ ntvfg = 45 nnvfg = mxnett + 1 ! /vsprwi/ ntvsp = 46 nnvsp = mxnett + 1 ! /almrwi/ ntalm = 47 nnalm = 3*mxnett + 1 ! /c2grwi/ ntc2g = 49 nnc2g = 5*mxnett + 1 ! /dcprwi/ ntdcp = 48 nndcp = mxnett + 1 ! /phxrwi/: aic sensitivities ndqphx = 3*maxpts ntphx = 68 nnphx = maxcp + 1 ! /dsnrwi/: panel data for dsn calc ndqdsn = 3*9 + 3*3*8 + 18*12*9 + 3*12*9 + 8 ntdsn = 67 nndsn = mxnett + 1 ! /pincl/ enx1 = 1.d0 enx2 = 1.d0 al1 = 0.d0 al2 = 0.d0 ! /srwi/ nsdq = 1024 nts = 2 ! /symm/ nsymm = 0 nisym = 0 ! Added by Martin Hegedus, 4/21/09 njsym = 0 ! Added by Martin Hegedus, 4/21/09 misym = 0 mjsym = 0 ! /lamrwi/ ntlam = 26 nnlam = 302 ! /vrwi/ ntv = 4 ! /exdign/ nexdgn = 0 ! /gsqrwi/ nsqg = 31 ! /bsqrwi/ nsqb = 32 ! /hsqrwi/ nsqh = 14 ! /chkpnt/ nckaic = 0 nckusp = 0 ! /epsff/ eps1 = 12.d0 eps2 = 4.d0 eps3 = 2.5d0 eps4 = .75d0 eps5 = .45d0 phc1 = .174d0 phc2 = .572d0 phc3 = 1.100d0 ! /lofdat/ nloft = 0 ! /nflowv/ nflowv = 0 ! /kstmln/ nstmln = 0 numpts = 0 hmin = 0.0000001d0 hmax = 10000.d0 maxstm = 1000 mxordr = 6 abserr = 0.000001d0 mxarr1 = 10000 isprnt = 0 tpsl = 0.d0 ntsmln = 33 ! /rrwi/ ! /ofbod/ nof = 0 ! ! /boundl/ ! itapbl = 0 ivcorr = 0 ! ! ! /titles/ ! ! do 50 i = 1,20 title1(i) = ' ' title2(i) = ' ' 50 continue title1(1) = 'pilo' title1(2) = 't co' title1(3) = 'de ' title2(1) = 'your' title2(2) = ' nam' title2(3) = 'e ' ! /abtnew/ epsgeo = 0.d0 newabt = .false. xtrint = .false. ! /abtprt/ igeoin = 1 igeout = 0 nwxref = 0 nwprop = 0 iabutd = 0 iabsum = 1 ! /cp2flg/ istcp2 = 1 iexcp2 = 0 nitcp2 = 15 ! /factrd/ ifact = 0 ! /prtnor/ nprten = 0 ! /vicovr/ do 60 i = 1,mxnett nedflt(i) = 0 60 continue ! ! ! ! next do fortran initialization and ensure consistency ! nnb=(maxcp+nsbp-1)/nsbp+1 nnc=(maxcp+nscp-1)/nscp+1 nns=maxpan+1 nnv=maxcp+2 ! /cm05/ rwmstr = .false. ! /solnt/ iray(2) = 27 iray(4) = nans iray(6) = 19 iray(7) = 20 iray(8) = nsc3 iray(9) = nrhs ! /matprp/ call icopy (2*mxnett, 0,0, matnet,1) nprop = 0 call dcopy (11, 1.d0,0, tratio,0) call dcopy (11, 1.d0,0, pratio,0) call dcopy (11, 1.d0,0, dratio,1) call dcopy (11, 1.d0,0, vfmat,1) call dcopy (11, 1.d0,0, wfmat,1) call dcopy (11, 1.d0,0, cpfmat,1) call dcopy (11, 1.d0,0, gcnmat,1) call dcopy (11, 1.d0,0, pcnmat,1) call dcopy (11, 1.d0,0, rcnmat,1) qratio(0) = 'air ' ! /lndblx/ nlndbl = 0 iwkfil = 1 call icopy (mxnett, 0,0, ilndbl,1) call dcopy (mxnett, 0.d0,0, slndbl,1) call icopy (mxnett, 0,0, idsvfw,1) return ! END subroutine block ! **deck bmark subroutine bmark (label) implicit double precision (a-h,o-z) character*(*) label write (6,6001) label 6001 format ('0*b*',a8) return END subroutine bmark ! **deck bqbfun subroutine bqbfun (s,t, phi,phis,phit) implicit double precision (a-h,o-z) dimension phi(9), phis(9), phit(9), ds(3), dt(3), bs(3), bt(3) ! compute biquadratic basis function phi for an isoparametric ! h-p panel and, in addition, the s and t derivatives of ! these basis functions, phis and phit . ! bs(1) = .5d0*s*(s+1.d0) bs(2) = 1.d0-s*s bs(3) = .5d0*s*(s-1.d0) ! bt(1) = .5d0*t*(t+1.d0) bt(2) = 1.d0-t*t bt(3) = .5d0*t*(t-1.d0) ! ds(1) = s + .5d0 ds(2) = -2.d0*s ds(3) = s - .5d0 ! dt(1) = t + .5d0 dt(2) = -2.d0*t dt(3) = t - .5d0 ! phi (1) = bs(1)*bt(1) phi (5) = bs(2)*bt(1) phi (2) = bs(3)*bt(1) phi (8) = bs(1)*bt(2) phi (9) = bs(2)*bt(2) phi (6) = bs(3)*bt(2) phi (4) = bs(1)*bt(3) phi (7) = bs(2)*bt(3) phi (3) = bs(3)*bt(3) ! phis(1) = ds(1)*bt(1) phis(5) = ds(2)*bt(1) phis(2) = ds(3)*bt(1) phis(8) = ds(1)*bt(2) phis(9) = ds(2)*bt(2) phis(6) = ds(3)*bt(2) phis(4) = ds(1)*bt(3) phis(7) = ds(2)*bt(3) phis(3) = ds(3)*bt(3) ! phit(1) = bs(1)*dt(1) phit(5) = bs(2)*dt(1) phit(2) = bs(3)*dt(1) phit(8) = bs(1)*dt(2) phit(9) = bs(2)*dt(2) phit(6) = bs(3)*dt(2) phit(4) = bs(1)*dt(3) phit(7) = bs(2)*dt(3) phit(3) = bs(3)*dt(3) ! return END subroutine bqbfun ! **deck btrns subroutine btrns(jc,bcd) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to retrieve boundary condition defining quantities * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * the information is retrieved via subroutine trns * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bcd argument output boundary condition defining * ! * quantity block for given * ! * control point jc * ! * * ! * bcdq /skrchs/ in/output buffer containing multiple * ! * blocks of boundary condition * ! * defining quantities * ! * jc argument input index identifying given * ! * control point * ! * * ! * nbdq /brwi/ input number of boundary condition * ! * defining quantities per block * ! * * ! * nib /brwi/ input index array for ntb * ! * * ! * nnb /brwi/ input length of nib * ! * * ! * nrb /brwi/ input current record in buffer * ! * * ! * nsb /brwi/ input number of boundary condition * ! * defining quantity blocks in * ! * buffer * ! * * ! * ntb /brwi/ input file on which boundary * ! * condition defining quantity * ! * blocks are stored * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call brwi parameter (nsbp=6) common/brwi/nbdq,nsb,nrb,ntb,nnb,nib((maxcp+nsbp-1)/nsbp+1) !end brwi !call skrchs common/skrchs/cntq(512),bcdq(512),panq(1024) !end skrchs dimension bcd(1) !c ! * retrieve the information via trns * ! call trns(bcd,bcdq,nbdq,nsb,nrb,ntb,nib,jc) return END subroutine btrns ! **deck btrnsf subroutine btrnsf(jc,nb) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * transfer either first or second boundary condition defining * ! * quantities for given control point from mass storage to * ! * common block /bcond/ * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * jc argument input index identifying given * ! * control point * ! * * ! * nb argument input =1 first boundary condition * ! * defining quantities desired* ! * =2 second boundary condition * ! * defining quantities desired* ! * * ! * nbin /bcond/ output boundary condition flag * ! * =1 values refer to first * ! * boundary condition at * ! * control point * ! * =2 values refer to second * ! * boundary condition at * ! * control point * ! * nbcd2 -local- - - - - number of defining quantities * ! * per boundary condition * ! * * ! * nbdq /brwi/ input total number of first and * ! * second boundary condition * ! * defining quantities per * ! * control point * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call brwi parameter (nsbp=6) common/brwi/nbdq,nsb,nrb,ntb,nnb,nib((maxcp+nsbp-1)/nsbp+1) !end brwi !call bcon common /bcon/ & & cu1,cl1,tu1(3),tl1(3),du1,dl1,bet1(4),nct1,nlopt1,nropt1,necpt1 & & ,klopt1,kldum1,betin1(4) & & ,cu2,cl2,tu2(3),tl2(3),du2,dl2,bet2(4),nct2,nlopt2,nropt2,necpt2 & & ,klopt2,kldum2,betin2(4) & & ,ndbcon !end bcon !call bcond common /bcond/ & & cu,cl,tu(3),tl(3),du,dl,bet(4),nct,nlopt,nropt,necpt & & ,klopt,kldum,betin(4) & & ,nbin !end bcond !c ! * retrieve boundary condition defining quantities for control * ! * point jc from mass storage and place in common block /bcon/. * ! call btrns(jc,cu1) nbcd2=nbdq/2 !c ! * transfer desired first or second boundary condition defining * ! * quantities from common block /bcon/ to common block /bcond/. * ! if(nb.eq.1) call icopy (nbcd2,cu1,1,cu,1) if(nb.eq.2) call icopy (nbcd2,cu2,1,cu,1) nbin=nb return END subroutine btrnsf ! **deck bxycal subroutine bxycal (amr,zorig,zsp, zloc,wt) implicit double precision (a-h,o-z) dimension amr(3,3), zorig(3), zsp(3), zloc(3) ! ! calculate the local coordinates for a singularity parameter lo ! (using length preserving projection to the selected tangent pl ! and the corresponding least squares fitting weight. ! !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs dimension zd(3), zdp(3) ! zd(1) = zsp(1) - zorig(1) zd(2) = zsp(2) - zorig(2) zd(3) = zsp(3) - zorig(3) ! zdsq = zd(1)**2 + zd(2)**2 + zd(3)**2 enzd = amr(3,1)*zd(1) + amr(3,2)*zd(2) + amr(3,3)*zd(3) ! zdp(1) = zd(1) - amr(3,1)*enzd zdp(2) = zd(2) - amr(3,2)*enzd zdp(3) = zd(3) - amr(3,3)*enzd ! zdpsq = zdp(1)**2 + zdp(2)**2 + zdp(3)**2 fac = sqrt(zdsq/zdpsq) zdp(1) = fac*zdp(1) zdp(2) = fac*zdp(2) zdp(3) = fac*zdp(3) ! zloc(1) = amr(1,1)*zdp(1) + amr(1,2)*zdp(2) + amr(1,3)*zdp(3) zloc(2) = amr(2,1)*zdp(1) + amr(2,2)*zdp(2) + amr(2,3)*zdp(3) zloc(3) = amr(3,1)*zdp(1) + amr(3,2)*zdp(2) + amr(3,3)*zdp(3) ! wt = 1.d0 if ( amach.lt.1.d0 ) go to 950 ! zdcmp = zd(1)*compd(1) + zd(2)*compd(2) + zd(3)*compd(3) wt = 1.d0 + amach*( 1.d0 - zdcmp/sqrt(zdsq) ) ! 950 continue return END subroutine bxycal ! **deck camber subroutine camber(kn,npct,nyst,ncen,ntrl) implicit double precision (a-h,o-z) !call propre !c !******************************************************************* ! ! note ! ! ! A502 was developed by: ! ! The Boeing Company ! Boeing Commercial Airplanes ! Aerodynamics Research Group ! ! Individuals who have contributed to its development ! include: ! ! Forrester T. Johnson ! F. Edward Ehlers ! Michael A. Epton ! Larry L. Erickson (NASA) ! Paul E. Rubbert ! Gary R. Saaris ! Edward N. Tinoco ! ! !c !*********************************************************************** ! !end propre !****** ! purpose to generate the z coordinate for network mesh points of a ! desired 3-d cambered wing through interpolation ! ! input calling sequence ! kn - network no. ! npct - number of x/c(s) at which z/c(s) will be defined ! nyst - number of y stations at which z/c(s) will be de- ! fined ! ncen - number of mesh points of wing network along center ! -line ! ntrl - =1 single mean line for all span stations ! =2 varying camber and twist with span ! common block ! /index/ - nm,nn,nza, ! /mspnts/ - zm ! /skrch1/ - sc,xpc,ypc,zpc ! ! output common block ! /mspnts/ - zm ! ! discussion the routine performs the following steps. step 1 find ! the straight line representing trailing edge. step 2 ! obtain and store x and y coordinates of mesh points on ! leading edge. step 3 compute local chord length at each ! y station. step 4 use linear interpolation to obtain z ! coordinate for the given mesh points. at step 4, the cod ! -e uses one-dimensional linear interpolation for single ! mean line cambered wing and used two-dimensional linear ! interpolation for wing with varying camber and twist. ! it should be observed that when preprocessor $quadrila- ! teral is used to generate a flat wing before calling this ! routine, corner no. 1 is to be at apex and side no. 1 is ! to be along the center line. !****** !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call area1 common/area1/sc(3,200),xpc(200),ypc(200),xpnt(500),ypnt(500), & & nle,nrf,nrv,inat,insd,inatf,jnat,jnsd,zpc(50,50), & & xle(100),yle(100),cln(100) !end area1 !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts ! ! obtain accumulated sum of mesh points for ! all previous networks, row and column num- ! bers kzm = nza(kn) nrow = nm(kn) ncol = nn(kn) nzm = nrow*ncol ! ! find the straight line representing trail- ! ing edge if(ncen.ne.0) go to 10 x1 = sc(1,2) y1 = sc(2,2) x2 = sc(1,3) y2 = sc(2,3) go to 20 10 ijk = (ncen-1)*nrow+1 x1 = zm(1,ijk) y1 = zm(2,ijk) x2 = sc(1,ncol) y2 = sc(2,ncol) 20 dy = y2 - y1 fm = (x2 - x1)/dy fb = (y2*x1 - y1*x2)/dy ! ! obtain and store x and y coordinates of ! mesh points on leading edge if(ncen.ne.0) go to 60 call iscal(sc,ics) insd = 4 if(ics.eq.4) insd = 3 if(insd.ne.1.and.insd.ne.3) go to 40 nle = ncol i = 1 if(insd.eq.3) i = nrow kzmi = kzm+i-nrow do 30 j=1,nle ji = kzmi+j*nrow call dcopy (3,zm(1,ji),1,sc(1,j),1) 30 continue go to 70 40 nle = nrow i = ncol if(insd.eq.4) i = 1 kzmi = kzm+(i-1)*nrow do 50 j=1,nle ji = kzmi+j call dcopy (3,zm(1,ji),1,sc(1,j),1) 50 continue go to 70 60 nle = ncen 70 continue do 80 i=1,nle xle(i) = sc(1,i) yle(i) = sc(2,i) 80 continue ! ! compute local chord length at each y sta- ! tion do 90 i=1,nle cln(i) = fm*yle(i) + fb - xle(i) 90 continue ! ! perform linear interpolation to obtain z ! coordinate for the given mesh points if(ntrl.ne.1) go to 120 ! ! for the case of single mean line for all ! span stations do 110 i=1,nzm yi = zm(2,kzm+i) call intp1(yi,yle,xle,nle,xi) call intp1(yi,yle,cln,nle,ci) if(ci.eq.0.d0) go to 100 xcl = (zm(1,kzm+i) - xi)/ci if(xcl.le.0.d0.or.xcl.ge.1.d0) go to 100 call intp1(xcl,xpc,zpc,npct,zcl) zm(3,kzm+i) = zcl*ci go to 110 100 zm(3,kzm+i) = 0.d0 110 continue go to 150 ! ! for the case of varying camber and twist ! with span 120 continue do 140 i=1,nzm yi = zm(2,kzm+i) call intp1(yi,yle,xle,nle,xi) call intp1(yi,yle,cln,nle,ci) if(ci.lt.1.0d-4) go to 130 xcl = 0.5d0 if(ci.ne.0.d0) xcl = (zm(1,kzm+i) - xi)/ci call intp2(yi,xcl,ypc,xpc,zpc,nyst,npct,50,50,zcl) zm(3,kzm+i) = zcl*ci go to 140 130 zm(3,kzm+i) = zpc(nyst,1)*ci 140 continue ! 150 continue return END subroutine camber ! **deck cbet subroutine cbet(bet,nbin) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to allow the user to input right hand side boundary condition* ! * values which are functions of control point dependent * ! * quantities. values coded in this routine will be substituted * ! * into any boundary condition with nropt=5. current control * ! * point defining quantities are stored in common block /cntrq/.* ! * the current control point can be identified by its location * ! * zc or by its network kc and cumulative control point grid * ! * index for that network jzc. if both boundary conditions at a * ! * given control point use the option nropt= 5 it will be * ! * necessary to distinguish the first from the second, and for * ! * this one can use the flag nbin * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bet argument output array containing specified * ! * (possibly multiple) right * ! * hand side values * ! * * ! * alpc /comprs/ input compressibility direction * ! * angle of attack * ! * * ! * alpha /acase/ input angles of attack * ! * * ! * amach /acase/ input freestream mach number * ! * * ! * beta /acase/ input angles of sideslip * ! * * ! * betc /comprs/ input compressibility direction * ! * angle of sideslip * ! * * ! * betams /comprs/ input 1.-(freestream mach number)**2* ! * * ! * compd /comprs/ input compressibility direction * ! * vector * ! * * ! * fsv /acase) input (multiple) freestream velocity* ! * vectors * ! * * ! * nacase /acase/ input number of freestream cases * ! * * ! * nbin argument input boundary condition flag * ! * =1 values refer to first * ! * boundary condition at * ! * control point * ! * =2 values refer to second * ! * boundary condition at * ! * control point * ! * * ! * zc /cntrq/ input control point position in * ! * global coordinates * ! * * ! * znc /cntrq/ input upper surface normal at * ! * control point (in global * ! * coordinates) * ! * * ! * ipc /cntrq/ input index of panel on which * ! * control point zc lies * ! * * ! * icc /cntrq/ input sub-panel on which zc lies * ! * * ! * jzc /cntrq/ input cumulative row/column index * ! * of zc in network kc * ! * * ! * kc /cntrq/ input network on which zc lies * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs dimension bet(4) return END subroutine cbet ! **deck ccaln subroutine ccaln (p,ics,c, nsidex, ndegp1 ) implicit double precision (a-h,o-z) dimension p(3,1), c(1) dimension e(100) nside = nsidex ndeg = ndegp1 - 1 if ( ndeg.gt.8 ) go to 100 call panmom (nside,ics,p,ndeg,c,ndeg+1,e,ndeg+2) return 100 write (6,110) 110 format (' ndegx .gt. 8 in ccaln ') stop END subroutine ccaln ! **deck ccof subroutine ccof(cu,cl,tu,tl,du,dl,nct,nbin) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to allow the user to input left hand side boundary condition * ! * coefficients which are functions of control point dependent * ! * quantities. values coded in this routine will be substituted * ! * into any boundary condition with nlopt=10. current control * ! * point defining quantities are stored in common block /cntrq/.* ! * the current control point can be identified by its location * ! * zc or by its network kc and cumulative control point grid * ! * index for that network jzc. if both boundary conditions at a * ! * given control point use the option nlopt=10 it will be * ! * necessary to distinguish the first from the second, and for * ! * this one can use the flag nbin * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * * ! * alpc /comprs/ input compressibility direction * ! * angle of attack * ! * * ! * alpha /acase/ input angles of attack * ! * * ! * amach /acase/ input freestream mach number * ! * * ! * beta /acase/ input angles of sideslip * ! * * ! * betc /comprs/ input compressibility direction * ! * angle of sideslip * ! * * ! * betams /comprs/ input 1.-(freestream mach number)**2* ! * * ! * cl argument output boundary condition coefficient* ! * of lower surface perturbation * ! * normal mass flux * ! * * ! * compd /comprs/ input compressibility direction * ! * vector * ! * * ! * cu argument output boundary condition coefficient* ! * of upper surface perturbation * ! * normal mass flux * ! * * ! * dl argument output boundary condition coefficient* ! * of lower surface perturbation * ! * potential * ! * * ! * du argument output boundary condition coefficient* ! * of upper surface perturbation * ! * potential * ! * fsv /acase) input (multiple) freestream velocity* ! * vectors * ! * * ! * nacase /acase/ input number of freestream cases * ! * * ! * nbin argument input boundary condition flag * ! * =1 values refer to first * ! * boundary condition at * ! * control point * ! * =2 values refer to second * ! * boundary condition at * ! * control point * ! * * ! * nct argument output boundary condition left hand * ! * side coefficient descriptor * ! * =1 non-zero normal mass flux * ! * coefficients only * ! * =2 general coefficients * ! * =4 non-zero potential * ! * coefficients only * ! * * ! * tl argument output boundary condition coefficient* ! * vector of lower surface per- * ! * turbation tangential velocity * ! * * ! * tu argument output boundary condition coefficient* ! * vector of upper surface per- * ! * turbation tangential velocity * ! * * ! * zc /cntrq/ input control point position in * ! * global coordinates * ! * * ! * znc /cntrq/ input upper surface normal at * ! * control point (in global * ! * coordinates) * ! * * ! * ipc /cntrq/ input index of panel on which * ! * control point zc lies * ! * * ! * icc /cntrq/ input sub-panel on which zc lies * ! * * ! * jzc /cntrq/ input cumulative row/column index * ! * of zc in network kc * ! * * ! * kc /cntrq/ input network on which zc lies * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs dimension tu(3),tl(3),slot(5),kwall(5) return END subroutine ccof ! **deck chlfac subroutine chlfac (n,a, s) implicit double precision (a-h,o-z) dimension a(n,n), s(n) ! a(1,1) = 1.d0/a(1,1) do 400 i = 2,n do 100 k = 1,i-1 s(k) = a(k,k)*a(k,i) 100 continue do 200 j = i,n a(i,j) = a(i,j) - ddot (i-1, s,1, a(1,j),1) 200 continue call dcopy (i-1, s,1, a(1,i),1) a(i,i) = 1.d0/a(i,i) 400 continue return END subroutine chlfac ! **deck chlslv subroutine chlslv (n,a, b) implicit double precision (a-h,o-z) dimension a(n,n), b(n) ! do 100 i = 2,n b(i) = b(i) - ddot (i-1, b,1, a(1,i),1) 100 continue do 200 i = 1,n b(i) = a(i,i)*b(i) 200 continue do 300 j = n,2,-1 call daxpy (j-1, -b(j), a(1,j),1, b,1) 300 continue return END subroutine chlslv ! **deck circ subroutine circ(k) implicit double precision (a-h,o-z) character*90 qline !call propre !c !******************************************************************* ! ! note ! ! ! A502 was developed by: ! ! The Boeing Company ! Boeing Commercial Airplanes ! Aerodynamics Research Group ! ! Individuals who have contributed to its development ! include: ! ! Forrester T. Johnson ! F. Edward Ehlers ! Michael A. Epton ! Larry L. Erickson (NASA) ! Paul E. Rubbert ! Gary R. Saaris ! Edward N. Tinoco ! ! !c !*********************************************************************** ! !end propre ! purpose - to generate a body network having a circular cross- ! section !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons dimension xs(300),z(300),r(300),th(100) !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser !call inp3 common /inp3/ ntsin,ntsout !end inp3 ra=pi/180.d0 read (ntsin,'( a )') qline read(qline,4000,err=9950) anopt, iduser(k) 4000 format(e10.0,60x,a) write(6, 5075) k, iduser(k) 5075 format(5x,25hnetwork # being processed,i4,66x,a,/) nopt=anopt read (ntsin,'( a )') qline read (qline,5000,err=9950) em m = em nm(k)=m do 15 i1 = 1,m,3 i2 = min (m,i1+2) read (ntsin,'( a )') qline read(qline,5000,err=9950)(xs(i),r(i),i=i1,i2) 15 continue if (nopt) 40,40,20 20 continue do 25 i1 = 1,m,6 i2 = min(m,i1+5) read (ntsin,'( a )') qline read(qline,5000,err=9950)(z(i),i=i1,i2) 25 continue go to 80 40 do 60 i = 1,m 60 z(i) = 0.d0 80 continue read (ntsin,'( a )') qline read (qline,5000,err=9950) en n = en nn(k)=n do 85 i1 = 1,n,6 i2 = min(n,i1+5) read (ntsin,'( a )') qline read(qline,5000,err=9950)(th(i),i=i1,i2) 85 continue do 90 j = 1,n st = sin(th(j)*ra) ct = cos(th(j)*ra) do 90 i = 1,m iv = (j-1)*m + i+nza(k) zm(1,iv) = xs(i) zm(2,iv) = r(i)*ct zm(3,iv) = z(i) + r(i)*st 90 continue nza(k+1)=nza(k)+n*m return ! ! read error handling ! 9950 continue write (6,9960) 'circ', qline, ((lll,lll=1,10),kkk=1,8) 9960 format (' read error occurred in subroutine ',a & & ,/,' INPUT LINE:',a90 & & ,/,' columns:',80i1,4x,'line # (see list of a502 input)' ) call a502er ('circ',' program failure due to ill-formatted data') return ! ! *** format statements *** 5000 format(6e10.0) END subroutine circ ! **deck closms subroutine closms (lun) ! ! close a unit that is a fake readms/writms file ! idea for later implementation: reserve formal ! records 1 and 2 for the index array ! !call dictms common /dictms/ nrecmx(100), llindx(100), ndirwr(100) & & , rwmstr & & , lldict, lldmax, indxms(2,800000) & & , buffms(512) integer buffms logical rwmstr !end dictms ! nind = nrecmx(lun) lliudx = llindx(lun) call writms (lun,indxms(1,lliudx+1),2*nind,nind, -1,97531) call upkims (lbkind,nbkind,indxms(1,lliudx+nind)) buffms(1) = nind buffms(2) = ndirwr(lun) buffms(3) = lbkind buffms(4) = nbkind if ( rwmstr ) then write (6,6001) (buffms(k),k=1,4) 6001 format (' closms, file header being written',4i6) endif write (7,6002) lun, (buffms(k),k=1,4) 6002 format (' closms on unit',i3,' header record:',4i8) write (lun,rec=1) buffms ! close (lun) return END subroutine closms ! **deck cmab subroutine cmab (b,a,c, n,l,m) implicit double precision (a-h,o-z) ! ! interface to hsmmp1 using the obsolete entry point, cmab ! dimension a(1), b(1), c(1) call hsmmp1 (m,l,n, a,1,m, b,1,l, c,1,m) return END subroutine cmab ! **deck cmngrd subroutine cmngrd (knet,mcp,ncp) implicit double precision (a-h,o-z) ! compute the c.p. mesh limits for a (possibly) composite networ ! the number of c.p."s in a network is equal to mcp*ncp !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !------------------------------------------------------------------------------- mcp = nm(knet) + 1 ncp = nn(knet) + 1 if ( nts(knet).ne.0 ) go to 950 ! doublet alone ntdk = ntd(knet) if ( ntdk.eq.8.or.ntdk.eq.10.or.ntdk.eq.18.or.ntdk.eq.20 ) & & mcp = 1 if ( ntdk.eq.10 .or. ntdk.eq.20 ) ncp = 1 ! 950 continue return END subroutine cmngrd ! **deck cmpied subroutine cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz) implicit double precision (a-h,o-z) dimension nedmpa(601), nza(151), nm(150), nn(150) ! given an edge mesh point index, compute its ! global mesh point index. nedgt = 4*nnett call ibsrch (nedmpa, nedgt+1, kmp, kedg) if ( kmp.ge.nedmpa(kedg)+1 .and. kmp.le.nedmpa(kedg+1) ) & & go to 200 write (6,'(1x,a10,1x, 1i12)') & & 'kmp',kmp call abtmsg ('kmp not there, cmpied') call abtend ('abort from Cmpied') 200 continue call mnmod (kedg,4,ksd,knet) call edgind (ksd,nm(knet),nn(knet), kzedg,kncedg,kncint,knedg) kzedg = kzedg + nza(knet) imp = kmp - nedmpa(kedg) kz = kzedg + (imp-1)*kncedg return END subroutine cmpied ! **deck cmpscl subroutine cmpscl (bs,c,v,w) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * scale a given vector in the compressibility direction by the * ! * compressibility factor. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * obvious * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bs argument input compressibility scale factor * ! * * ! * c argument input compressibility direction * ! * vector * ! * * ! * v argument input given vector * ! * * ! * w argument output resultant scaled vector * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension c(3),v(3),w(3) f=(bs-1.d0)*(v(1)*c(1)+v(2)*c(2)+v(3)*c(3))/ & &(c(1)*c(1)+c(2)*c(2)+c(3)*c(3)) call vadd(v,f,c,w,3) return END subroutine cmpscl ! **deck cnv2lo subroutine cnv2lo (n,ikywrd, lkywrd) implicit double precision (a-h,o-z) character*(*) lkywrd, ikywrd ! ! convert a standard a502 style keyword into a LOWER ! case version of itself. it does not matter whether the input ! is lower or upper case, cnv2lo should get it right no matter what ! character*26 ucase, lcase character*1 chkk ! actual installation would use following code to protect l.c. data lcase /'abcdefghijklmnopqrstuvwxyz'/ !--- data lcase /'abcdefghijklmnopqrstuvwxyz'/ data ucase /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ ! lkywrd = ikywrd ! do 300 ipos = 1,n chkk = ikywrd(ipos:ipos) do 200 ialfa = 1,26 ichkk = ialfa if ( chkk.eq.ucase(ialfa:ialfa) ) goto 240 200 continue goto 260 ! 240 continue lkywrd(ipos:ipos) = lcase(ichkk:ichkk) ! 260 continue 300 continue ! return END subroutine cnv2lo ! **deck cnv2lu subroutine cnv2lu (n,ikywrd, lkywrd,ukywrd) implicit double precision (a-h,o-z) character*(*) ukywrd, lkywrd, ikywrd ! ! convert a standard a502 style keyword into both LOWER and UPPER ! case versions of itself. it does not matter whether the input ! is lower or upper case, cnv2lu should get it right no matter what ! character*26 ucase, lcase character*1 chkk ! actual installation would use following code to protect l.c. data lcase /'abcdefghijklmnopqrstuvwxyz'/ !--- data lcase /'abcdefghijklmnopqrstuvwxyz'/ data ucase /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ ! ukywrd = ikywrd lkywrd = ikywrd ! do 300 ipos = 1,n chkk = ikywrd(ipos:ipos) do 200 ialfa = 1,26 ichkk = ialfa if ( chkk.eq.ucase(ialfa:ialfa) ) goto 240 if ( chkk.eq.lcase(ialfa:ialfa) ) goto 240 200 continue goto 260 ! 240 continue ukywrd(ipos:ipos) = ucase(ichkk:ichkk) lkywrd(ipos:ipos) = lcase(ichkk:ichkk) ! 260 continue 300 continue ! return END subroutine cnv2lu ! **deck cnv2up subroutine cnv2up (n,ikywrd, ukywrd) implicit double precision (a-h,o-z) character*(*) ukywrd, ikywrd ! ! convert a standard a502 style keyword into an UPPER ! case version of itself. it does not matter whether the input ! is lower or upper case, cnv2up should get it right no matter what ! character*26 ucase, lcase character*1 chkk ! actual installation would use following code to protect l.c. data lcase /'abcdefghijklmnopqrstuvwxyz'/ !--- data lcase /'abcdefghijklmnopqrstuvwxyz'/ data ucase /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ ! ukywrd = ikywrd ! do 300 ipos = 1,n chkk = ikywrd(ipos:ipos) do 200 ialfa = 1,26 ichkk = ialfa if ( chkk.eq.lcase(ialfa:ialfa) ) goto 240 200 continue goto 260 ! 240 continue ukywrd(ipos:ipos) = ucase(ichkk:ichkk) ! 260 continue 300 continue ! return END subroutine cnv2up ! **deck cnvxhl subroutine cnvxhl (q,nq,ics,p,np) implicit double precision (a-h,o-z) ! cnvxhl computes the convex hull of a polygon given by ! q(1:3,j), j = 1,nq, j>ics. it is assumed that the polygon ! is given in positive orientation, that is the outside of the ! polygon lies to the right as the corners are traversed in the ! order 1, 2, . . . , n. dimension q(3,nq), p(2,np) dimension ind(40) ! np = nq if ( nq.le.0 .or. nq.gt.40 ) go to 800 ! copy geometry into working array, p, ! taking care to delete a collapsed sid call mcopy (2,nq, q,1,3, p,1,2) if ( ics.eq.0 ) go to 10 if ( ics.ne.np ) call mcopy (2,nq-ics, q(1,ics+1),1,3 & & , p(1,ics),1,2) np = np - 1 ! init. npd = tot # of pts deleted 10 continue npd = 0 ! top of recursive loop 50 continue ! find non-convex corners in current ! polygon npdx = 0 im1 = np do 100 i = 1,np ind(i) = 0 ip1 = mod(i,np) + 1 arg = ( p(1,i)-p(1,im1) ) * ( p(2,ip1)-p(2,i) ) & & - ( p(2,i)-p(2,im1) ) * ( p(1,ip1)-p(1,i) ) if ( arg .gt. 0.d0 ) go to 90 ind(i) = 1 npd = npd + 1 npdx = npdx + 1 90 continue im1 = i 100 continue if ( npdx .eq. 0 ) go to 250 ! eliminate concave corners npn = 0 do 200 i = 1,np if ( ind(i).ne.0 ) go to 200 npn = npn + 1 p(1,npn)= p(1,i) p(2,npn)= p(2,i) 200 continue np = npn if ( npn.gt.2 ) go to 50 ! no points eliminated this pass, ! return if no concave corners ! were found on any pass 250 continue if ( npd.gt.0 ) goto 800 ! normal exit 700 continue return ! error condition: dump inputs, ! set np=0 and return. 800 continue write (6,810) nq,np,npd 810 format (' error in cnvxhl. nq, np, npd =',3i10) nqx = max ( 3, min ( nq,40) ) call outmat ('q',3,3,nqx,q) call outmat ('p',3,3,nqx,p) np = 0 return ! END subroutine cnvxhl ! **deck comfix subroutine comfix (line) implicit double precision (a-h,o-z) character*80 line ! ! blank out the string line at and after the 1st comment symbol ! ! line i ch the character string for which comments are ! 'fixed' ! ! michael epton, 30 november 1988 ! ! find the first appearance of a commen ! symbol jmax = 0 do 100 j = 1,80 if ( line(j:j).eq.'=' .or. line(j:j).eq.'!' ) goto 110 jmax = j 100 continue 110 continue ! clear it out, at and beyond the cmt s do 200 j = jmax+1,80 line(j:j) = ' ' 200 continue return END subroutine comfix ! **deck compip subroutine compip(u,v,c,bs,w) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * calculate compressible inner product of two vectors u and v. * ! * this inner product is defined as (u,hv) where h is a matrix * ! * which takes a given vector and scales its component in the * ! * compressibility direction (vector c) by the compressibility * ! * scale factor (bs). * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * obvious * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * bs argument input compressibility scale factor * ! * * ! * c argument input compressibility direction * ! * vector * ! * * ! * u argument input first vector * ! * * ! * v argument input second vector * ! * * ! * w argument output compressible inner product of * ! * u and v * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension u(3),v(3),c(3) w=(1.d0-bs)*(u(1)*c(1)+u(2)*c(2)+u(3)*c(3))*(v(1)*c(1)+v(2)*c(2) & &+v(3)*c(3))/(c(1)*c(1)+c(2)*c(2)+c(3)*c(3)) & &+bs*(u(1)*v(1)+u(2)*v(2)+u(3)*v(3)) return END subroutine compip ! **deck contrl subroutine contrl (kn,nt,nm,nn,nc,nca,nbca,nmapca,npa & & ,mcpnet,ncpnet,zm & & ,za,tauemp,ia,mapbc,mapc & & ,locfg,iamapc,key,keyinv & & ,nedmpa,nfsga,kfdseg,nedaba,ifsgai & & ,mcmpai,mtchab,kempec,nbraia,kfdsgn,iedgtp & & ) implicit double precision (a-h,o-z) dimension zm(3,nm,nn) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to compute control point defining quantities for each * ! * network * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * the routine calculates control point defining quantities for * ! * a given network and stores them on a file. first the * ! * control point locations are computed and ordered using the * ! * subroutines gcpcal and grdind respectively. panel center * ! * control points are then withdrawn slightly from the panel * ! * center to avoid numerical difficulty in evaluating influence * ! * coefficients here since this point is a vertex of the four * ! * interior subpanels. control points lying on the network * ! * edges or corners are classified into two types depending upon* ! * whether their function is to perform doublet edge matching * ! * across a network edge or enforce specified potential or * ! * velocity boundary conditions. in the latter case the control * ! * points are withdrawn slightly from the edges or corners for * ! * the same reason as above. auxiliary quantities including the * ! * panel normal at the control point, the indicies of the * ! * network, panel and sub-panel on which the control point lies,* ! * etc. are computed. these quantities taken together * ! * form the control point defining quantities and are stored * ! * on file 3. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * cp /pandq/ input nine canonical panel points * ! * (includes corner points,edge * ! * midpoints and center) * ! * * ! * en /pandq/ input unit normal (in global * ! * coordinates) to each plane * ! * surface of panel. first four * ! * vectors are normals to outer * ! * triangles and fifth is normal * ! * to inner parallelogram * ! * * ! * ia /skrch1/ -local- index array for control point * ! * grid za * ! * * ! * * ! * icc /cntrq/ output sub-panel on which zc lies * ! * * ! * icontp /prnt/ input control point diagnostic * ! * print flag * ! * * ! * icrchr /skrch1/ input network corner control * ! * point characterization * ! * = 0 no control point * ! * = 1 to 4 * ! * control point matches * ! * doublet strength along * ! * abutment to which side * ! * 1 to 4 belongs * ! * = 5 control point forces * ! * doublet strength to * ! * vanish * ! * = 6 control point retains * ! * original boundary * ! * conditions * ! * * ! * ipc /cntrq/ output panel on which the control * ! * point lies * ! * * ! * isdchr /skrch1/ input network edge control point * ! * characterization * ! * = 0 no control points * ! * = 1 to 4 * ! * control points match * ! * doublet strength along * ! * abutment to which side * ! * 1 to 4 belongs * ! * = 5 control points force * ! * doublet strength to * ! * vanish * ! * = 6 control points retain * ! * original boundary * ! * conditions * ! * * ! * jcn /cntrq/ output overall index of control point* ! * whose defining quantities are * ! * currently in common block * ! * /cntrq/ * ! * * ! * jzc /cntrq/ output cumulative row/column index * ! * of zc in network kc * ! * * ! * kc /cntrq/ output network on which zc lies * ! * * ! * kn argument input network number * ! * * ! * l -local- - - - - index of loop over coordinates* ! * * ! * m -local- - - - - index of loop over network * ! * control point rows * ! * * ! * nca argument input number of control points * ! * in previous networks * ! * * ! * nc argument output number of distinct control * ! * points on network * ! * * ! * nm argument input number of rows of network * ! * corner point grid * ! * * ! * nma -local- - - - - number of rows of control * ! * points * ! * * ! * nna -local- - - - - number of columns of control * ! * points * ! * * ! * nn argument input number of columns of * ! * network corner point grid * ! * * ! * npa argument input number of panels in previous * ! * networks * ! * * ! * nt argument input network type * ! * * ! * n -local- - - - - index of loop over control * ! * point columns * ! * * ! * za /skrch1/ -local- global coordinates of network * ! * control point locations * ! * * ! * zc /cntrq/ output global coordinates of control * ! * point * ! * * ! * * ! * zdc /cntrq/ output control point function flag * ! * =0. panel center control * ! * point with specified * ! * boundary conditions * ! * =-1. network edge control * ! * point with specified * ! * boundary conditions * ! * =1. to 4. * ! * network edge control * ! * point used to match * ! * doublet strength across * ! * respective network edge * ! * 1. to 4. * ! * * ! * zm argument input coordinates of network * ! * corner points * ! * * ! * znc /cntrq/ output upper surface normal at * ! * control point (in global * ! * coordinates) * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !call indxsp common /indxsp/ nxsptt, nxspa(151), locxsp(1200) & & , ngsptt, ngspa(151), locgsp(1200) !end indxsp ! ! FORMAL PARAMETER DECLARATIONS (FORMERLY /SKRCH1/) ! dimension za(3,maxcp), tauemp(mxempt) & & , ia(maxcp), mapbc(maxcp), mapc(maxcp) & & , locfg(maxcp), iamapc(maxcp) & & , key(maxcp), keyinv(maxcp) & & , nedmpa(4*mxnett+1), nfsga(4*mxnett+1) & & , kfdseg(4*mxfdsg),nedaba(mxnabt+1),ifsgai(2,mxfdsg)& & , mcmpai(mxfdsg), mtchab(4,mxnabt), kempec(mxempt) & & , nbraia(mxnai), kfdsgn(mxfdsg) & & , iedgtp(4*mxnett) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !ca nwlst common /cnwlst/ nwname(mxnett) character*10 nwname common /anwlst/ nnwlst !end nwlst ! dimension nwsdpt(4) dimension zctemp(3) character*2 kutlab ! data delta /.01d0/ ! ! ! nma = nm + 1 nna = nn + 1 call gcpcal (nm,nn,zm, nma,nna,za) call grdind (nma,nna,za, ia,nia) nc = 0 ica = nbca do 400 jcp = 1,ncpnet do 300 icp = 1,mcpnet ifn = max ( 1, min ( 2*nm-1, 2*(icp-1) )) jfn = max ( 1, min ( 2*nn-1, 2*(jcp-1) )) ica = ica + 1 lfngrd = ifn + (jfn-1)*(2*nm-1) lzagrd = icp + (jcp-1)*nma lcpgrd = icp + (jcp-1)*mcpnet ! kcpgrd = lcpgrd if ( icp.le.1 ) go to 20 if ( ia(lzagrd) .eq. ia(lzagrd-1) ) kcpgrd = lcpgrd - 1 20 continue if ( jcp.le.1 ) go to 40 if ( ia(lzagrd) .eq. ia(lzagrd-nma) ) kcpgrd = lcpgrd - mcpnet 40 continue icn = lcpgrd + nbca icnp = kcpgrd + nbca if ( icn .eq. icnp ) go to 100 locfg(lcpgrd) = 100000 + lfngrd iamapc(lcpgrd)= -iabs( iamapc( kcpgrd ) ) go to 300 100 continue nc = nc + 1 locfg(lcpgrd) = lfngrd iamapc(lcpgrd) = nc 300 continue 400 continue ncreg = nc ncnaif= mcpnet*ncpnet nxsp1 = nxspa(kn) + 1 nxsp2 = nxspa(kn+1) ! do 500 l = nxsp1,nxsp2 call icopy (4, locxsp(4*(l)-3),1, nwsdpt,1) lfngrd = nwsdpt(4) nc = nc + 1 ncnaif = ncnaif + 1 locfg(ncnaif) = lfngrd iamapc(ncnaif)= nc 500 continue ! call jshell (ncnaif,locfg,key) call ukysrt (ncnaif,locfg,key) do 600 icnew = 1,nc icold = iamapc( key(icnew) ) keyinv(icold) = icnew 600 continue ! ! store basic c.p. indices in the mapc ! array. if a naive c.p. is not a basi ! c.p., mapc contains -(alt. basic cp ! for the basic c.p. that is equivalent ! to the naive c.p. do 700 icnaif = 1,ncnaif icold = iamapc(icnaif) jcbsc = keyinv( iabs( icold ) ) + nca if ( icold .lt. 0 ) jcbsc = -jcbsc icn = icnaif + nmapca mapc(icn) = jcbsc ica = icnaif + nbca mapbc(ica) = jcbsc 700 continue ! if ( icontp.eq.0 ) go to 710 write (6,9000) kn write (6,9002) 710 continue do 800 icnew = 1,nc call zero (zc,8) call jzero (ipc,22) icnaif = key(icnew) icold = iamapc( icnaif ) lfngrd = locfg( icnaif ) call mnmod (lfngrd,2*nm-1,ifn,jfn) icn = icnaif + nmapca jcn = mapc(icn) kc = kn ijfgc = lfngrd if ( icnaif .gt. mcpnet*ncpnet ) go to 770 ! regular control points icp = (ifn+3)/2 if ( ifn.eq.1 ) icp = 1 jcp = (jfn+3)/2 if ( jfn.eq.1 ) jcp = 1 lcpgrd = icp + (jcp-1)*mcpnet lzagrd = icp + (jcp-1)*nma jzc = lzagrd ipan = min ( max ( icp,2), nm) - 1 jpan = min ( max ( jcp,2), nn) - 1 ipc = ipan + (jpan-1)*(nm-1) + npa call strns (ipc,cp) if ( mod(ifn,2).ne.0 .or. mod(jfn,2).ne.0 ) go to 750 ! panel center, regular control point call dcopy (3, za(1,lzagrd),1, zc,1) call xxadj (cp(1,9),cp(1,5),cp(1,8),delta,zc) call surpro (zc,zc,icc) ireg = min (icc,5) call dcopy (3, en(1,ireg),1, znc,1) zdc = 0.d0 go to 790 ! edge or corner, regular control point 750 continue call dcopy (3, za(1,lzagrd),1, zc,1) call cpabt (ifn,jfn,kn, kabmtc,kfsgc,tauc,znc,nedg,ksd,idcpmc & & ,nedmpa,nfsga,kfdseg,nedaba,ifsgai,mcmpai & & ,mtchab,kempec,nbraia,kfdsgn,tauemp,iedgtp) if ( kabmtc .ne. 0 ) go to 760 ! zdc = -1.d0 call zcadj call surpro (zc,zc,icc) ireg = min (icc,5) call dcopy (3, en(1,ireg),1, znc,1) go to 790 ! 760 continue if ( kabmtc .lt. 0 ) zdc = 8 + ksd if ( kabmtc .gt. 0 ) zdc = ksd if ( kabmtc .gt. 0 .and. nedg .eq. 1 ) zdc = 5 call zcadj call surpro (zc,zctemp,icc) ireg = min (icc,5) if ( kabmtc.gt.0 ) call dcopy (3, en(1, ireg),1, znc,1) go to 790 ! ! ! ! extra control point 770 continue lxsp = nxspa(kn) + icnaif - mcpnet*ncpnet jzc = -lxsp icrs = (ifn+1)/2 jcrs = (jfn+1)/2 ipan = min ( icrs, nm-1) jpan = min ( jcrs, nn-1) ipc = ipan + (jpan-1)*(nm-1) + npa call strns (ipc,cp) call dcopy (3, zm(1,icrs,jcrs),1, zc,1) call cpabt (ifn,jfn,kn, kabmtc,kfsgc,tauc,znc,nedg,ksd,idcpmc & & ,nedmpa,nfsga,kfdseg,nedaba,ifsgai,mcmpai & & ,mtchab,kempec,nbraia,kfdsgn,tauemp,iedgtp) if ( kabmtc .ne. 0 ) go to 780 ! zdc = -1.d0 call zcadj call surpro (zc,zc,icc) ireg = min (icc,5) call dcopy (3, en(1,ireg),1, znc,1) go to 790 ! 780 continue if ( kabmtc .lt. 0 ) zdc = 8 + ksd if ( kabmtc .gt. 0 ) zdc = ksd if ( kabmtc .gt. 0 .and. nedg .eq. 1 ) zdc = 5 call zcadj call surpro (zc,zctemp,icc) ireg = min (icc,5) if ( kabmtc.gt.0 ) call dcopy (3, en(1,ireg),1, znc,1) go to 790 790 continue call mnmod (ijfgc,2*nm-1,ifn,jfn) izdc = zdc kutlab = ' ' if ( kabmtc.lt.0 ) kutlab = 'tk' if ( kabmtc.lt.0 .and. idcpmc.eq.2 ) kutlab = 't2' if ( kabmtc.lt.0 .and. idcpmc.eq.3 ) kutlab = 'ti' if ( icontp.eq.0 ) go to 795 write (6,9001) jcn,icn & & , zc, znc, kutlab & & , kc, ipc, icc, jzc, ifn, jfn, izdc, kabmtc, kfsgc, tauc 795 continue call ictrns (jcn,zc) 800 continue if ( icontp.lt.2 ) go to 950 write (6,'(1x,a10,1x, 7i12)') & & 'contrl,nw',kn,nt,nm,nn,nc,nxsp1,nxsp1 call outmti ('mapc',mcpnet,mcpnet,ncpnet,mapc(nmapca+1)) lx = nmapca + ncpnet*mcpnet + 1 call outvci ('xtra-map',nxsp2-nxsp1+1,mapc(lx)) 950 continue return 9000 format ('0 control points for network :',i4) 9001 format (1x,2i5 & & , 3f12.6, 3f11.6, 1x, a2 & & ,1x,i3,1x,i5,1h.,i1, i5,i4,i4, i5,i5,i5, f7.4 ) 9002 format (1x,' jc jc/naive' & & , 15x, 'zc', 17x, 14x, 'znc', 16x & & ,' nw panel.sp jzc ifn jfn izdc abut fseg tau' ) END subroutine contrl ! **deck cost subroutine cost (rtem) implicit double precision (a-h,o-z) dimension rtem(16) INTRINSIC:: CPU_TIME !------------------------------------------------------------------------------- call CPU_TIME (ta) rtem(1) = ta return END subroutine cost ! **deck cpabt subroutine cpabt (ifn,jfn,kn, kabmtc,kfsg,tauc,znc,nedg,ksd,idcpmc& & ,nedmpa,nfsga,kfdseg,nedaba,ifsgai,mcmpai & & ,mtchab,kempec,nbraia,kfdsgn,tauemp,iedgtp & & ) implicit double precision (a-h,o-z) dimension znc(3), nedmpa(1), nfsga(1), kfdseg(1), nedaba(1) & & , ifsgai(2,1), mcmpai(1), mtchab(4,1), kempec(1) & & , nbraia(1), kfdsgn(1), tauemp(1) & & , iedgtp(1) ! given the nw index kn and the fine grid indices (ifn,jfn) of ! a control point, determine the abutment kabmtc for which ! the control point performs matching (if any). if the control ! point does perform matching, find nedg the number of edges ! in the abutment, ksd the nw side index across which matching ! is performed and, for vorticity matching (kabmtc.lt.0), the ! downstream vector t-kutta (znc) used in forming the matching ! condition. !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt dimension dz1(3), dz2(3) dimension dz(3) ! nmk = nm(kn) nnk = nn(kn) if ( ifn.eq.1 ) go to 10 if ( jfn.eq.2*nnk-1 ) go to 20 if ( ifn.eq.2*nmk-1 ) go to 30 if ( jfn.eq.1 ) go to 40 call errmsg ('edge control pt not on edge') ! ! edge 1 10 continue kpt = (jfn+2)/2 kedg = 4*(kn-1) + 1 i1 = 1 j1 = max ( jfn/2, 1) i2 = 1 j2 = j1 + 1 kz1 = j1 kz2 = j2 go to 50 ! ! edge 2 20 continue kpt = (ifn+2)/2 kedg = 4*(kn-1) + 2 i1 = max ( ifn/2, 1) j1 = nnk i2 = i1 + 1 j2 = nnk kz1 = i1 kz2 = i2 go to 50 ! ! edge 3 30 continue kpt = (2*nnk + 2 - jfn) / 2 kedg = 4*(kn-1) + 3 i2 = nmk j2 = max ( jfn/2, 1) i1 = nmk j1 = j2 + 1 kz1 = max ( (2*nnk-jfn)/2, 1) kz2 = kz1 + 1 go to 50 ! ! edge 4 40 continue kpt = (2*nmk + 2 - ifn) / 2 kedg = 4*(kn-1) + 4 i2 = max ( ifn/2, 1) j2 = 1 i1 = i2 + 1 j1 = 1 kz1 = max ( (2*nmk-ifn)/2, 1) kz2 = kz1 + 1 go to 50 ! 50 continue if ( iedgtp(kedg) .le. 0 ) go to 900 if ( iedgtp(kedg) .ge. 2 ) go to 70 ! edge type = 1 (collapsed) ! check that neighboring edges have typ ksdx = kedg - 4*(kn-1) ksdprv = mod(ksdx+2,4) + 1 ksdnxt = mod(ksdx,4) + 1 kdgprv = ksdprv + 4*(kn-1) kdgnxt = ksdnxt + 4*(kn-1) if ( iedgtp(kdgprv).ge.2 .and. iedgtp(kdgnxt).ge.2 ) go to 70 write (6,'(1x,a10,1x, 10i12)') & & 'cpabt/clps',kn,ifn,jfn,ksdx & & ,kedg,iedgtp(kedg) & & ,kdgprv,iedgtp(kdgprv) & & ,kdgnxt,iedgtp(kdgnxt) call a502ms ('cpabt' & & ,'adjacent collapsed edges detected ') go to 900 ! 70 continue call edgmpi (kedg,kpt,nedmpa, kmp) call fsgcmp (kmp,nedmpa,nfsga,kfdseg,nnett,kfsg1,kfsg2) !--- call xsgcmp (kmp,nedmpa,nfsga,kfdseg,nnett !--- x ,kfsg1x,kfsg2x) kfsg1x = kfsg1 kfsg2x = kfsg2 if ( mod(ifn,2).eq.1 .and. mod(jfn,2).eq.1 ) go to 200 ! edge interior control point if ( kfsg1x.ne.kfsg1 ) then write (7,8002) iabint,kfsg1,kfsg1x,kfsg2,kfsg2x & & , (kfdseg(l+4*kfsg1 -2),l=1,3) & & , (kfdseg(l+4*kfsg1x-2),l=1,3) endif 8002 format (' fsgcmp error, cpabt-1, iabint,kfsg*:', 5i6 & & ,/ ,3x,3i4,3x,3i4 ) kfsg = kfsg1 iabt = iabs( kfdsgn( kfsg ) ) nedg = nedaba(iabt+1) - nedaba(iabt) call icopy (4, kfdseg(4*kfsg-3),1, kokseg,1) ksgn = isign( 1, kfdsgn(kfsg) ) if ( kz1 .eq. i1kseg ) tauk1 = (1-ksgn)/2 if ( kz2 .eq. i2kseg ) tauk2 = (1+ksgn)/2 call edgmpi ( kedseg,kz1,nedmpa, iedmp1) call edgmpi ( kedseg,kz2,nedmpa, iedmp2) if ( kz1.ne.i1kseg ) tauk1 = tauemp(iedmp1) if ( kz2.ne.i2kseg ) tauk2 = tauemp(iedmp2) tauc = max( 0.d0, min( 1.d0, .5d0*(tauk1+tauk2) )) jfsgmu = mtchab(1,iabt) jfsgwk = mtchab(2,iabt) jfsgvd = mtchab(3,iabt) idcpm = mtchab(4,iabt) ksd = kedg - 4*(kn-1) kabmtc = 0 if ( kfsg .eq. jfsgmu ) kabmtc = iabt if ( kfsg .eq. jfsgvd ) kabmtc = -iabt idcpmc = 0 if ( kfsg.eq.jfsgvd ) idcpmc = idcpm if ( kabmtc .ge. 0 ) go to 900 ! vorticity matching, define znc. l1 = i1 + (j1-1)*nmk + nza(kn) l2 = i2 + (j2-1)*nmk + nza(kn) if ( iextrp.eq.0 ) go to 90 write (6,'(1x,a10,1x, 10i12)') & & 'vor-mtch',jfsgvd,jfsgwk,i1,j1,l1,i2,j2,l2,kz1,kz2 90 continue call vadd (zm(1,l2), -1.d0, zm(1,l1), dz, 3) call cpip (dz,dz,dzsq) if ( dzsq .gt. 0.d0 ) go to 150 kabmtc = 0 go to 900 150 continue ! ! ! ! ! **** define znc ********* lfsg = jfsgwk lsgn = isign( 1, kfdsgn(lfsg) ) call icopy (4, kfdseg(4*lfsg-3),1, lokseg,1) lnet = (ledseg+3)/4 lsd = ledseg - (lnet-1)*4 ! find the point on the wake nw opposit ! the current control point. lz1 = i1lseg if ( lsgn.lt.0 ) lz1 = i2lseg taul1 = 0.d0 i1lsg1 = i1lseg + 1 do 180 lptx = i1lsg1,i2lseg lz2 = lptx if ( lsgn.lt.0 ) lz2 = i1lseg + i2lseg - lz2 call edgmpi ( ledseg,lz2,nedmpa, iedmp) taul2 = 1.d0 if ( lptx.lt.i2lseg ) taul2 = tauemp(iedmp) if ( tauc.ge.taul1 .and. tauc.le.taul2 ) go to 190 taul1 = taul2 lz1 = lz2 180 continue ! didn't find it. call errmsg ('missing opposing point for kutta cond') call outvci ('kokseg',4,kokseg) call outvci ('lokseg',4,lokseg) write (6,'(1x,a10,1x,f12.6,2i12,f12.6,2i12,f12.6,3i12)') & & 'useful',tauc, kz1,iedmp1,tauk1 & & ,kz2,iedmp2,tauk2, ksgn,lsgn,taul2 call a502ms ('cpabt', & & 'could not find opposing wake pt for kutta cond') return ! 190 continue call edgind (lsd,nm(lnet),nn(lnet), lzedg,lncedg,lncint,lnedg) lzedg = lzedg + nza(lnet) lz1 = lzedg + (lz1-1)*lncedg lz2 = lzedg + (lz2-1)*lncedg lw1 = lz1 + lncint lw2 = lz2 + lncint wgt1 = ( taul2 - tauc ) / ( taul2 - taul1 ) wgt2 = ( tauc - taul1 ) / ( taul2 - taul1 ) call vadd ( zm(1,lw1), -1.d0, zm(1,lz1), dz1, 3) call vadd ( zm(1,lw2), -1.d0, zm(1,lz2), dz2, 3) do 195 i = 1,3 znc(i) = wgt1*dz1(i) + wgt2*dz2(i) 195 continue call uvect (znc) go to 900 ! corner control point 200 continue if ( kfsg1x.ne.kfsg1 .or. kfsg2x.ne.kfsg2 ) then write (7,8001) iabint,kfsg1,kfsg1x,kfsg2,kfsg2x & & , (kfdseg(l+4*kfsg1 -2),l=1,3) & & , (kfdseg(l+4*kfsg1x-2),l=1,3) & & , (kfdseg(l+4*kfsg2 -2),l=1,3) & & , (kfdseg(l+4*kfsg2x-2),l=1,3) endif 8001 format (' fsgcmp error, cpabt, iabint,kfsg*:', 5i6 & & ,/ ,3x,3i4,3x,3i4,3x,3i4,3x,3i4 ) iabint = iabs( kempec(kmp) ) if ( iabint.le.0 ) go to 230 ibr1 = nbraia(iabint) + 1 ibr2 = nbraia(iabint+1) do 220 ibr = ibr1,ibr2 ibrsv = ibr if ( kfsg1.eq.ifsgai(1,ibr) .and. kfsg2.eq.ifsgai(2,ibr) ) & & go to 240 220 continue 230 continue call errmsg ('branch not found for a.i.') write (6,'(1x,a10,1x, 9i12)') & & 'cpabt/4',kn,ifn,jfn,kmp,iabint,ibr1,ibr2 & & ,kfsg1,kfsg2 CALL AbortPanair('cpabt') 240 continue ibr = ibrsv imatch = mcmpai(ibr) kfsg = 0 kabmtc = 0 if ( imatch.eq.1 ) kfsg = kfsg1 if ( imatch.eq.2 ) kfsg = kfsg2 if ( imatch.eq.3 ) zdc = -1.d0 if ( imatch.eq.4 ) zdc = 6.d0 if ( kfsg.eq.0 ) go to 900 iabt = iabs( kfdsgn(kfsg) ) kabmtc = iabt nedg = nedaba(iabt+1) - nedaba(iabt) call icopy (4, kfdseg(4*kfsg-3),1, kokseg,1) call mnmod (kedseg,4,ksd,knet) ksgn = isign( 1, kfdsgn(kfsg) ) if ( kfsg.eq.kfsg1 ) tauc = (1+ksgn)/2 if ( kfsg.eq.kfsg2 ) tauc = (1-ksgn)/2 900 continue return END subroutine cpabt ! **deck cpbcum subroutine cpbcum (lun,inirec,increc,nwpb,mxcls,ind,a & & ,b,nsngt,nrpb, c & & ,npagp,nspgrp & & ,kcp1,kcp2,nwv,nesum) implicit double precision (a-h,o-z) integer ind(mxcls), nwv(4,1) dimension a(1:*), b(1:*), c(1:*) ! --- dimension a(mxcls,1) ! --- dimension b(nsngt,nrpb), c(1) ! --- complex*16 a, b, c integer nspgrp(npagp) ! ! for the current control point block (kcp1:kcp2), read the ! influences of all of the panel groups through memory and ! accumulate the (panel group on c.p. block) influence into ! the array b containing the (configuration on c.p. block) ! influence. ! !ca gbnejc ! /gbnejc/ common /gbnejc/ icpgpk, icpbkk, ne, jc !end gbnejc !ca locinf ! /locinf/ common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i double precision rlocdm !end locinf !ca rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt ! lla = locfcn(a) llind = locfcn(ind) lldiff = lla - llind lldtru = kklocr*mxcls if ( lldiff .eq. lldtru ) goto 40 write (6,'('' cpbcum/err: '',6i12)') & & lla,llind,lldiff,lldtru,kklocr,mxcls call a502er ('cpbcum','addressing assumption violated') 40 continue ! add up number of aic rows in the ! current control point block. nesum = 0 do 100 icp = kcp1,kcp2 nesum = nesum + nwv(3,icp) 100 continue ! zero out accumulator array call dcopy (ityprc*nesum*nsngt, 0.d0,0, b,1) ! loop over panel groups, accumulating do 500 jpagp = 1,npagp irec = inirec + (jpagp-1)*increc nsp = nspgrp(jpagp) ! the following read assumes that ! loc(ind) + mxcls = loc(a) call readmd (lun,ind,nwpb,irec) if (ityprc.eq.1) call disct2(nsp,nesum ,a,mxcls ,ind ,b,nsngt) if (ityprc.eq.2) call zisct2(nsp,nesum ,a,mxcls ,ind ,b,nsngt) 500 continue ! for each control point in the current ! block, transpose the data and write ! out using vtrns lb = 1 do 700 icp = kcp1,kcp2 jc = nwv(4,icp) ne = nwv(3,icp) if ( ne.eq.0 ) goto 700 if (ityprc.eq.1) call mcopy (nsngt,ne ,b(lb),1,nsngt ,c,ne,1) if (ityprc.eq.2) call mccopy(nsngt,ne ,b(lb),1,nsngt ,c,ne,1) if ( jc.eq.ipraic ) then write (6,'('' dvdfs for jc = '',i5)') jc call outmtx ('pic',ne*ityprc,ne*ityprc,nsngt,c) endif call ivtrns (jc,ne,c) lb = lb + ityprc*ne*nsngt 700 continue ! return END subroutine cpbcum ! **deck cpbphx subroutine cpbphx (npt,nzmpt,kcpbk,iptgrp,phxgp,phx) implicit double precision (a-h,o-z) dimension phxgp(3,npt,kcpbk), phx(3,nzmpt,kcpbk) dimension iptgrp(npt) ! ! accumulate the phix sensitivity influence coefficients ! for the influence of a panel group upon a c.p. block into ! a buffer containing the total influence on the c.p. block ! do 400 ipt = 1,npt ifin = iptgrp(ipt) do 200 jcp = 1,kcpbk do 100 kk = 1,3 phx(kk,ifin,jcp) = phx(kk,ifin,jcp) + phxgp(kk,ipt,jcp) 100 continue 200 continue 400 continue return END subroutine cpbphx ! **deck cpcal subroutine cpcal (kmat,pva,f,bs,c,cp) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to calculate a set of pressure coefficients (cp) at a point * ! * given the total mass flux vector at the point (w), the * ! * freestream velocity vector (f), the compressibility factor * ! * (bs=1.-(mach number)**2) and the compressibility direction * ! * vector (c). * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * preferred velocity component (generally known as u-component)* ! * is defined as component in compressibility direction * ! * (rather than in freestream direction). * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * amach -local- - - - - freestream mach number * ! * * ! * bs argument input compressibility factor = * ! * 1.-(freestream mach number)**2* ! * * ! * c argument input compressibility direction * ! * vector * ! * * ! * cp argument output set of pressure coefficients * ! * cp(1)=linear * ! * cp(2)=slender body * ! * cp(3)=second order * ! * cp(4)=isentropic * ! * cp(5)=dummy for future formula* ! * * ! * f argument input freestream velocity vector * ! * * ! * pva argument input perturbation velocity vector * ! * including the free stream * ! * magnitude scaling factor * ! * * ! * pv -local- - - - - perturbation velocity vector * ! * * ! * pvf -local- - - - - component of pv in preferred * ! * (compressibility) direction * ! * * ! * pvs -local- - - - - square of magnitude of pv * ! * * ! * w argument input total mass flux vector at * ! * point * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs dimension pva(3), f(3), c(3), cp(5), pv(3) fmag=sqrt(f(1)**2+f(2)**2+f(3)**2) do 50 i=1,3 50 pv(i) = pva(i)/fmag call mxm (pv,1,pv,3,pvs,1) call mxm (f,1,pv,3,pvf,1) pvf=pvf/fmag amachs = 1.d0-bs cp(1) = -2.d0*pvf cp(2) = -2.d0*pvf - pvs + pvf**2 cp(3) = -2.d0*pvf - pvs + amachs*pvf**2 ! isentropic, v --> 0 fac = vfmat(kmat)**2 / tratio(kmat) cp(4) = 1.d0 - fac*( 1.d0 + 2.d0*pvf + pvs ) if ( amach.gt.0.d0 ) cp(4) = (1.42857142857d0/amachs) * & & ( pratio(kmat)*(max( 0.d0, 1.d0+.2d0*amachs*cp(4))**3.5d0)-1.d0) cp(5)=0.d0 rfac = cpfmat(kmat) do 100 i = 1,3 cp(i) = rfac*cp(i) 100 continue return END subroutine cpcal ! **deck cpcalx subroutine cpcalx (ksurf,ind,pv,cp,jacob,dcp) implicit double precision (a-h,o-z) logical jacob dimension pv(3), dcp(3) ! ! evaluate the pressure coefficient 'cp' for solution iacase ! (up to four solutions), returning the result in the variable ! cp. optionally (based on input l.jacob), ! produce a sensitivity vector for cp w.r.t. pert. v. ! ! input- ! ksurf = +knet, for upper surface, -knet, for lower surface ! ind = (1,2,3) = (linear,2nd order,isentropic) formula ! pv = perturbation velocity for nacase solutions ! jacob = logical variable directing generation of dcp ! output- ! cp = pressure coefficient (type specified by ind) for ! solution iacase (cf. /acase/) ! dcp = d(cp)/d(pv), pv = perturbation velocity. ! this is only calculated if jacob=.true. dimension pw(3) dimension vt(3) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp ! data amcrit /.01d0/ data gamma /1.4d0/ ! ia = iacase kn = iabs(ksurf) iuplo = (3-isign(1,ksurf))/2 kmat = matnet(iuplo,kn) rcon = cpfmat(kmat) amach2 = amach**2 fsvin2 = 1.d0/fsvm(ia)**2 ! pvs = ( pert-v / v-infinity )**2 call vip (pv,1, pv,1, 3, pvs) pvs = pvs * fsvin2 ! pvf = ( pert-v . v-fs-air )/ (v-inf call vip (pv,1, fsvhat(1,ia),1, 3, pvfhat) pvf = pvfhat/fsvm(ia) ! pw = ( i - amach**2 f f' / fmag**2 ) fac = amach2*pvfhat pw(1) = pv(1) - fac*fsvhat(1,ia) pw(2) = pv(2) - fac*fsvhat(2,ia) pw(3) = pv(3) - fac*fsvhat(3,ia) ! ind = 1 ==> linear ! ind = 2 ==> second order ! ind = 3 ==> isentropic go to (100,200,300), ind ! linear cp rule 100 continue cp = -2.d0*rcon*pvf if ( .not. jacob ) go to 500 fac = -2.d0*rcon*fsvin2 dcp(1) = fac*fsv(1,ia) dcp(2) = fac*fsv(2,ia) dcp(3) = fac*fsv(3,ia) go to 500 ! ! second order pressure rule 200 continue cp = rcon*( -2.d0*pvf - pvs + amach2 * pvf**2 ) if ( .not. jacob ) go to 500 fac = -2.d0*rcon*fsvin2 dcp(1) = fac*( fsv(1,ia) + pw(1) ) dcp(2) = fac*( fsv(2,ia) + pw(2) ) dcp(3) = fac*( fsv(3,ia) + pw(3) ) go to 500 ! 300 continue ! small mach number, isentropic scl = vfmat(kmat)**2 / tratio(kmat) cp = 1.d0 - scl*( 1.d0 + 2.d0*pvf + pvs ) if ( .not. jacob ) go to 400 fac = -2.d0*scl*fsvin2 dcp(1) = fac*( fsv(1,ia) + pv(1) ) dcp(2) = fac*( fsv(2,ia) + pv(2) ) dcp(3) = fac*( fsv(3,ia) + pv(3) ) ! general case, isentropic 400 continue if ( amach.lt.amcrit ) go to 500 hfac = (gamma-1.d0)*amach2*.5d0 exh = gamma/(gamma-1.d0) ex = 1.d0/(gamma-1.d0) ! cpmz = cp cp = (2.d0/(amach2*gamma))* & & (-1.d0+pratio(kmat)* (max(0.d0,1.d0+hfac*cpmz)**exh) ) if ( .not. jacob ) go to 500 dcpfac = pratio(kmat)*(max(0.d0,1.d0+hfac*cpmz)**ex) dcp(1) = dcpfac*dcp(1) dcp(2) = dcpfac*dcp(2) dcp(3) = dcpfac*dcp(3) go to 500 ! 500 continue return END subroutine cpcalx ! **deck cpetp subroutine cpetp(k,isd,iz1,iz2,z,izm) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts dimension z(3) nzak=nza(k) izmn=min (iz1,iz2) izmx=max (iz1,iz2) do 100 iz=izmn,izmx call mshind(isd,iz,1,nm(k),nn(k),kp) kp=nzak+kp call distnc(zm(1,kp),z,d) if(iz.eq.izmn) go to 50 if(d.gt.dmin) go to 100 50 dmin=d izm=iz 100 continue 900 return END subroutine cpetp ! **deck cpip subroutine cpip (u,v,uv) implicit double precision (a-h,o-z) dimension u(3), v(3) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs uv = betams * ( u(1)*v(1) + u(2)*v(2) + u(3)*v(3) ) + & & (1.d0-betams)*(u(1)*compd(1)+u(2)*compd(2)+u(3)*compd(3)) & & * (v(1)*compd(1)+v(2)*compd(2)+v(3)*compd(3)) return END subroutine cpip ! **deck cpnor subroutine cpnor(ip,zp,enp) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call lsqsfc ! /lsqsfc/ common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk !end lsqsfc !call mspnts common/mspnts/zm(3,maxpts) !end mspnts dimension zp(3),enp(3) dimension wk(3,16),z(3),en(3),ar(3,3),art(3,3),pc(3) dimension h(3,3),ht(3,3),u(3),v(3),w(3),zeta(16),cof(6),r0p(3) equivalence (u(1),ht(1,1)), (v(1),ht(1,2)), (w(1),ht(1,3)) data nit,delta,wt /20,1.d-8,1.d4/ do 2 k=1,nnett kp=k if(ip.le.npa(k+1)) go to 3 2 continue 3 ipk=ip-npa(kp) nmk=nm(kp) nnk=nn(kp) call mnmod(ipk,nmk-1,mp,np) npk=0 do 9 j=1,4 nj=min (max (np+j-2,1),nnk) do 8 i=1,4 mi=min (max (mp+i-2,1),nmk) npk=npk+1 wtk(npk)=1.d0 if(((i.eq.2).or.(i.eq.3)).and.((j.eq.2).or.(j.eq.3))) wtk(npk)=wt li=mi+nmk*(nj-1)+nza(kp) l1=mi+nza(kp) l2=l1+nmk l3=1+nmk*(nj-1)+nza(kp) l4=l3+1 do 7 l=1,3 zk(l,npk)=zm(l,li) if((nnk.eq.2).and.((j.eq.1).or.(j.eq.4))) & &zk(l,npk)=.5d0*(zm(l,l1)+zm(l,l2)) if((nmk.eq.2).and.((i.eq.1).or.(i.eq.4))) & &zk(l,npk)=.5d0*(zm(l,l3)+zm(l,l4)) 7 continue 8 continue 9 continue call dcopy (3*npk,zk,1,wk,1) nfltp=0 10 continue l1=mp+nmk*(np-1)+nza(kp) l2=l1+nmk l3=l2+1 l4=l1+1 do 50 i=1,3 u(i)=zm(i,l1)+zm(i,l4)-zm(i,l2)-zm(i,l3) v(i)=zm(i,l1)+zm(i,l2)-zm(i,l3)-zm(i,l4) pc(i)=.25d0*(zm(i,l1)+zm(i,l2)+zm(i,l3)+zm(i,l4)) 50 continue call cross(u,v,w) call cross(w,u,v) call uvect(u) call uvect(v) call uvect(w) call trans(ht,ar,3,3) do 170 it=1,nit do 100 k=1,npk call unipan(ar,pc,wk(1,k),zk(1,k)) zeta(k)=zk(3,k) 100 continue no=2 if(nfltp.eq.1) no=1 call lsqsf call mxm (ak,6,zeta,npk,cof,1) cof46=.5d0*abs(cof(4)-cof(6)) dp=sqrt(cof(5)**2+cof46**2) if(dp.eq.(0.d0)) spsi=0.d0 if(dp.ne.(0.d0)) spsi=sqrt(.5d0*abs(1.d0-cof46/dp)) if((cof(5)*(cof(4)-cof(6))).lt.(0.d0)) spsi=-spsi cpsi=sqrt(abs(1.d0-spsi**2)) art(1,1)=cpsi art(2,1)=-spsi art(3,1)=0.d0 art(1,2)=spsi art(2,2)=cpsi art(3,2)=0.d0 art(1,3)=0.d0 art(2,3)=0.d0 art(3,3)=1.d0 a=.5d0*(cof(4)*cpsi**2+cof(6)*spsi**2)+cof(5)*spsi*cpsi b=.5d0*(cof(4)*spsi**2+cof(6)*cpsi**2)-cof(5)*spsi*cpsi d=cof(2)*cpsi+cof(3)*spsi if(abs(d).lt.delta) d=0.d0 e=-cof(2)*spsi+cof(3)*cpsi if(abs(e).lt.delta) e=0.d0 ca=1.d0/sqrt(1.d0+d*d) sa=d*ca cb=1.d0/sqrt(1.d0+d*d+e*e) sb=e*cb cb=cb/ca ht(1,1)=ca ht(1,2)=0.d0 ht(1,3)=sa ht(2,1)=-sb*sa ht(2,2)=cb ht(2,3)=sb*ca ht(3,1)=-cb*sa ht(3,2)=-sb ht(3,3)=cb*ca call mxm (art,3,ar,3,h,3) call mxm (ht,3,h,3,ar,3) if((d.eq.0.d0).and.(e.eq.0.d0)) go to 175 170 continue if(nfltp.eq.1) go to 175 nfltp=1 go to 10 175 continue r0p(1)=0.d0 r0p(2)=0.d0 r0p(3)=cof(1) call mxm (r0p,1,ar,3,w,3) do 200 i=1,3 200 r0p(i)=pc(i)+w(i) call unipan(ar,r0p,zp,z) z(3)=a*z(1)*z(1)+b*z(2)*z(2) en(1)=-2.d0*a*z(1) en(2)=-2.d0*b*z(2) en(3)=1.d0 call mxm (en,1,ar,3,enp,3) call uvect(enp) return END subroutine cpnor ! **deck cpnor2 subroutine cpnor2 (kc,ipc,icc,zc,en) implicit double precision (a-h,o-z) dimension zc(3), en(3) ! ! compute a control point normal based upon baseline (unmodified ! by abutment adjustments) geometry. ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspntz common /mspntz/ zmzero (3,maxpts) !end mspntz dimension cp(3,9) ! ! compute the panel's row and column in ipk = ipc - npa(kc) nmk = nm(kc) nnk = nn(kc) call mnmod (ipk, nmk-1, ipan,jpan) ! ! get the locations of the panel's corn nzak = nza(kc) i1 = ipan + (jpan-1)*nmk + nzak i2 = i1 + nmk i3 = i2 + 1 i4 = i1 + 1 ! call dcopy (3, zmzero(1,i1),1, cp(1,1),1) call dcopy (3, zmzero(1,i2),1, cp(1,2),1) call dcopy (3, zmzero(1,i3),1, cp(1,3),1) call dcopy (3, zmzero(1,i4),1, cp(1,4),1) ! ! compute the remaining 9 std points do 100 is = 1,4 isp1 = mod(is,4) + 1 cp(1,is+4) = .5d0*( cp(1,is) + cp(1,isp1) ) cp(2,is+4) = .5d0*( cp(2,is) + cp(2,isp1) ) cp(3,is+4) = .5d0*( cp(3,is) + cp(3,isp1) ) 100 continue ! cp(1,9) = .5d0*( cp(1,5) + cp(1,7) ) cp(2,9) = .5d0*( cp(2,5) + cp(2,7) ) cp(3,9) = .5d0*( cp(3,5) + cp(3,7) ) if ( icc.gt.4 ) go to 150 ! control point on an outer triangle ic1 = icc ic2 = mod(icc,4)+1 ic3 = mod(icc+2,4)+1 call norcal (cp(1,ic1), cp(1,ic2), cp(1,ic3), en) go to 250 ! control point on inner parallelogram 150 continue call norcal (cp(1,9), cp(1,5), cp(1,6), en) ! 250 continue return END subroutine cpnor2 ! **deck cptls subroutine cptls(p1,p2,p,z,t) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * find closest point on line segment to given point. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * calculate point on line where vector to given point is * ! * orthogonal to vector along line. * ! * if resultant point lies outside segment choose closest * ! * endpoint. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * p1 argument input first endpoint of segment * ! * * ! * p2 argument input second endpoint of segment * ! * * ! * p argument input given point * ! * * ! * t argument output fraction of distance from p1 * ! * to p2 of the point z * ! * * ! * z argument output closest point on line segment * ! * to given point * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension p1(3),p2(3),p(3),z(3) !c ! * calculate point on line where vector to given point is * ! * orthogonal to vector along line. * ! call vadd(p2,-1.d0,p1,z,3) call mag(z,zmag) t=0.d0 if(zmag.gt.0.d0) & &t=((p(1)-p1(1))*z(1)+(p(2)-p1(2))*z(2)+(p(3)-p1(3))*z(3))/zmag**2 !c ! * if resultant point lies outside segment choose closest * ! * endpoint. * ! t=min(max(t,0.d0),1.d0) call vadd(p1,t,z,z,3) return END subroutine cptls ! **deck cross subroutine cross(a,b,c) implicit double precision (a-h,o-z) !***created on 76.056 w.o. no. 0 version ftj.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to compute the cross product of two vectors in three-space * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * a argument input first vector of the cross * ! * product * ! * * ! * b argument input second vector of the cross * ! * product * ! * * ! * c argument output cross product of the two * ! * input vectors * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension a(3),b(3),c(3) c(1)=a(2)*b(3)-a(3)*b(2) c(2)=a(3)*b(1)-a(1)*b(3) c(3)=a(1)*b(2)-a(2)*b(1) return END subroutine cross ! **deck cscal1 subroutine cscal1 (x,z,n) implicit double precision (a-h,o-z) ! apply the matrix g(x)(i,j) = x*delta(i,j) + (1-x)*c(i)*c(j) ! to a collection of 3-vectors, z(*,n) dimension z(3,n) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs xc = 1.d0 - x do 100 l = 1,n s = 0.d0 do 10 i = 1,3 10 s = s + compd(i)*z(i,l) do 20 i = 1,3 20 z(i,l) = x*z(i,l) + xc*compd(i)*s 100 continue return END subroutine cscal1 ! **deck cscal2 subroutine cscal2 (x,z,n) implicit double precision (a-h,o-z) ! apply the matrix h(x)(i,j) = delta(i,j) + (x-1)*c(i)*c(j) ! to the collection of vectors z(*,n) dimension z(3,n) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs xc = x-1.d0 do 100 l = 1,n s = 0.d0 do 10 i = 1,3 10 s = s + compd(i)*z(i,l) do 20 i = 1,3 20 z(i,l) = z(i,l) + xc*s*compd(i) 100 continue return END subroutine cscal2 ! **deck cstprt subroutine cstprt (title) implicit double precision (a-h,o-z) logical prtcst character*(*) title character*30 msg character*10 qtime !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt dimension result(128) parameter (ncmax=50) !call jobsum ! /jobsum/ common /jobsum/ nc, ncdum, tdata(12,ncmax) common /jobsch/ ttljob(ncmax) character*8 ttljob !end jobsum dimension item(16) dimension costf(7) dimension ttotal(9) character*8 titl8 double precision item data ta /0.d0/ data costf & & / 0.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & / data ccuap1 / .006d0 / ! nc = nc + 1 call CPU_TIME (tb) dt = tb - ta ta = tb call cost (item) call price (result) item(2) = result(15) item(3) = result(17) item(4) = result(21) item(5) = result(22) item(6) = result(28) item(7) = result(29) ccus = result(63) dolls = ccuap1 * ccus write (qtime,'( f10.3 )' ) tb ! initialz cpu time:123456.123 ! 123456789012345678901234567890 msg = ' cpu time: ' msg(21:30) = qtime msg(1:10) = title call remarx (msg) prtcst = icostp.eq.1 if ( .not. prtcst ) go to 500 titl8 = title write (6,8000) titl8, dt, tb, (item(i),i=1,7),ccus,dolls 8000 format (//,4x,a8,' elapsed time ', f20.12 & & ,/,12x ,' total time ', f20.12 & & ,/,12x ,' prut seconds ', f20.12 & & ,/,12x ,' cpu seconds ', f20.12 & & ,/,12x ,' cmp units ', f20.12 & & ,/,12x ,' disk req-s ', f20.12 & & ,/,12x ,' disk blocks ', f20.12 & & ,/,12x ,' ssd units ', f20.12 & & ,/,12x ,' ssd req-s ', f20.12 & & ,/,12x ,' cumulative ccus ', f20.12 & & ,/,12x ,' cum cost at p1 ', f20.12 & & ) 500 continue if ( nc.gt.ncmax ) return ttljob(nc) = title tdata (2,nc) = dt tdata (3,nc) = tb do 600 i = 1,7 600 tdata(i+3,nc) = item(i) tdata(11,nc) = ccus tdata(12,nc) = dolls return END subroutine cstprt ! **deck cstsum subroutine cstsum implicit double precision (a-h,o-z) !ca prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt parameter (ncmax=50) !ca jobsum ! /jobsum/ common /jobsum/ nc, ncdum, tdata(12,ncmax) common /jobsch/ ttljob(ncmax) character*8 ttljob !end jobsum dimension costf(7), ttotal(9) data costf & & / 0.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & , 1.d0 & & / data ccuap1 / .006d0 / ! ! ! ! ! nc = min (nc,ncmax) ! call dcopy (9, 0.d0,0, ttotal,1) do 750 ib = 2,nc i = nc + 2 - ib do 740 l = 4,12 tdata(l,i) = tdata(l,i) - tdata(l,i-1) 740 continue call daxpy (9, 1.d0, tdata(4,i),1, ttotal,1) 750 continue ! write (6,790) 790 format ('1 job cost summary by function '// & & ' function elapsed-t total-t prut-secs cpu-secs cmp-units', & & ' dsk-reqs dsk-blks ssd-units ssd-reqs fcn ccus $''s @ p1'/& & ' -------- -------- ------- ------- ------- -------', & & ' ------- ------- ------- ------- -------- -------') do 800 i = 1,nc write (6,810) ttljob(i), (tdata(l,i),l=2,12) 800 continue 810 format (1x,a8,9f10.2,f11.2,f10.2) write (6,820) ttotal 820 format(1x,'totals ',' (excl. line 1) ',7f10.2,f11.2,f10.2) ! ! ! write (6,850) 850 format (///' ccu estimates for the various cost components') ttotal(8) = 0.d0 do 900 i = 1,nc tdata(5,i) = costf(2)*tdata(5,i) tdata(6,i) = costf(3)*tdata(6,i) tdata(7,i) = costf(4)*tdata(7,i) tdata(8,i) = costf(5)*tdata(8,i) tdata(9,i) = costf(6)*tdata(9,i) tdata(10,i) = costf(7)*tdata(10,i) tdata(11,i) = tdata(5,i) & & + tdata(6,i) & & + tdata(7,i) & & + tdata(8,i) & & + tdata(9,i) & & + tdata(10,i) if ( i.ne.1 ) ttotal(8) = ttotal(8) + tdata(11,i) write (6,860) ttljob(i), (tdata(l,i),l=5,11) 860 format (1x,a8,30x,6f10.2,f11.2) 900 continue ! ttotal(2) = costf(2)*ttotal(2) ttotal(3) = costf(3)*ttotal(3) ttotal(4) = costf(4)*ttotal(4) ttotal(5) = costf(5)*ttotal(5) ttotal(6) = costf(6)*ttotal(6) ttotal(7) = costf(7)*ttotal(7) write (6,910) (ttotal(i),i=2,8) 910 format (1h0,'totals ',30x,6f10.2,f11.2) return END subroutine cstsum ! **deck ctpack subroutine ctpack (szc) implicit double precision (a-h,o-z) dimension szc(20) ! pack up the data in /cntrq/ into the 11 word data packet szc !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq call dcopy (20, zc,1, szc,1) return END subroutine ctpack ! **deck ctrns subroutine ctrns(jc,cdq) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to retrieve control point defining quantities * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * the information is retrieved via subroutine trns * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * cdq argument output control point defining * ! * quantity block for given * ! * control point jc * ! * cntq /skrchs/ in/output buffer containing multiple * ! * blocks of control point * ! * defining quantities * ! * * ! * * ! * jc argument input index identifying given * ! * control point * ! * * ! * ncdq /crwi/ input number of control point * ! * defining quantities per block * ! * * ! * nic /crwi/ input index array for ntc * ! * * ! * nnc /crwi/ input length of nic * ! * * ! * nrc /crwi/ input current record in buffer * ! * * ! * nsc /crwi/ input number of control point * ! * defining quantity blocks in * ! * buffer * ! * * ! * ntc /crwi/ input file on which control point * ! * defining quantity blocks are * ! * stored * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call crwi parameter (nscp=13) common/crwi/ncdq,nsc,nrc,ntc,nnc,nic((maxcp+nscp-1)/nscp+1) !end crwi !call skrchs common/skrchs/cntq(512),bcdq(512),panq(1024) !end skrchs dimension cdq(1) !c ! * transfer the information via trns * ! call trns(cdq,cntq,ncdq,nsc,nrc,ntc,nic,jc) return END subroutine ctrns ! **deck ctunpk subroutine ctunpk (szc) implicit double precision (a-h,o-z) dimension szc(20) !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq ! unpack the data packet szc into the common block /cntrq/ call dcopy (20, szc,1, zc,1) return END subroutine ctunpk ! **deck cublns subroutine cublns (n,fz,f1,alf,t) implicit double precision (a-h,o-z) dimension fz(n), f1(n) ! ! given a vector function of t: ! ! phi(t) = (1-t) fz + t**2 ( ( f1 - (1-alf)*fz )/alf**2 ) ! ! having the properties that: ! ! phi( 0 ) = fz ! d/dt phi( 0 ) = -fz ! phi(alf) = f1 ! ! find the global minimum of [ phi(t), phi(t) ], which is ! quartic in t. the derivative of this quartic is a cubic, whi ! may have up to 3 real zeroes, corresponding to 3 local extrema ! along the ray of the search direction. the value 't' returned ! by cublns gives the smallest value of these three possible ! local extrema. this is the global minimum of f**2 along the ! search direction provided. ! ! n i int dimension of fz, f1 ! fz i r*8 vector value of: phi(0) ! f1 i r*8 vector value of: phi(alf) ! alf i r*8 the value of t for which f1 gives the value ! t o r*8 the location of the global minimum of [phi,p ! ! michael epton, 30 november 1988 ! dimension d(0:3), wa(0:3), wb(0:3), wc(0:3) dimension y(3) dimension x(3), p(3) !call cp2flg ! /cp2flg/: newton iteration, lambda print and cp2 print flags common /cp2flg/ istcp2, iexcp2, nitcp2 !end cp2flg ! ! ! evaluate various useful inner product call vip (fz,1, fz,1, n,h00) call vip (fz,1, f1,1, n,h01) call vip (f1,1, f1,1, n,h11) ! fg = 0.d0 gg = 0.d0 do 10 i = 1,n gi = ( f1(i) - (1.d0-alf)*fz(i) )/alf**2 fg = fg + gi*fz(i) gg = gg + gi*gi 10 continue ! calculate the coefficients of ! [ phi(t), phi(t)] c4 = gg c3 = -2.d0*fg c2 = 2.d0*fg + h00 c1 = -2.d0*h00 c0 = h00 ! optional printout if ( iexcp2.lt.2 ) goto 15 write (6,'(1x,a10,1x, 1p,5e12.4)') & & 'cub/c0-4',c0,c1,c2,c3,c4 write (6,'(1x,a10,1x, 1p,3e12.4)') & & 'cub/hij',h00,h01,h11 write (6,'(1x,a10,1x, 1p,e12.4)') & & 'cub/alf',alf 15 continue ! coefficients of (d/dt) [ phi, phi] d(3) = 4.d0*c4 d(2) = 3.d0*c3 d(1) = 2.d0*c2 d(0) = c1 ! preset real parts of roots for later x(1) = 1.d38 x(2) = 2.d38 x(3) = 3.d38 dtest = abs(d(0)) + abs(d(1)) + abs(d(2)) if ( abs(d(3)) .gt. 1.d-8*dtest ) goto 100 ! d(3) .=. 0 if ( abs(d(2)).gt. 1.d-8*dtest ) goto 50 ! case: linear ! d(2) .=. 0, d(3) .=. 0 x(1) = -d(0)/d(1) if ( iexcp2.ge.2 ) write (6,'(1x,a10,1x, 1p,e12.4)') & & 'path 00',x(1) goto 200 ! case: quadratic ! d(2) # 0, d(3) .=. 0 50 continue disc = d(1)**2 - 4.d0*d(0)*d(2) if ( iexcp2.ge.2 ) write (6,'(1x,a10,1x, 1p,e12.4)') & & 'path 50',disc if ( disc.lt.0.d0 ) goto 200 x(1) = ( -d(1) - sign(1.d0,d(1))*sqrt(disc) )/(2.d0*d(0)) x(2) = d(0)/( d(2)*x(1) ) goto 200 ! case: true cubic ! d(3) # 0 100 continue np = 3 ier = 0 call etdprt (np,d, wa,wb,wc, x,y, ier) !======= call etprt (np,d, wa,wb,wc, x,y, ier) if ( ier.ne.0 ) then write (6,'(1x,a10,1x, 1p,10e12.4)') & & 'cublns/rt',ier, d(0),d(1),d(2),d(3) & & ,x(1),x(2),x(3), y(1),y(2) CALL AbortPanair('cublns') endif ! if ( iexcp2.lt.2 ) goto 120 conv = 0.d0 write (6,'(1x,a10,1x, 1p,6e12.4)') & & 'path 100',x(1),x(2),x(3),y(1),y(2),y(3) write (6,'(1x,a10,1x, 1p,5e12.4)') & & 'cv/proot',conv,d(0),d(1),d(2),d(3) 120 continue if ( y(1).ne.0.d0 ) x(1) = 4.d38 if ( y(2).ne.0.d0 ) x(2) = 4.d38 if ( y(3).ne.0.d0 ) x(3) = 4.d38 ! roots have been found. examine ! all actual roots for the global min. 200 continue pmin = 1.d38 kmin = 0 do 300 k = 1,3 if ( abs(x(k)).gt. 1.d36 ) goto 300 ! root k was a true root, evaluate the ! quartic polynomial at z = x(k), and ! check if it is global minimum so far. z = x(k) p(k) = c0 + z*( c1 + z*( c2 + z*( c3 + z*c4 ))) if ( abs(x(k)) .gt. 10.d0 ) goto 300 if ( abs(p(k)).gt.pmin ) goto 300 pmin = abs(p(k)) kmin = k 300 continue xmin = 0.d0 if ( kmin.ne.0 ) xmin = x(kmin) if ( iexcp2.lt.2 ) goto 320 write (6,'(1x,a10,1x, 1p,3e12.4)') & & 'cub/x',x(1),x(2),x(3) write (6,'(1x,a10,1x, 1p,3e12.4)') & & 'cub/p',p(1),p(2),p(3) write (6,'(1x,a10,1x, 1p,3e12.4)') & & 'cub/xmin',xmin,pmin,kmin 320 continue t = xmin ! ! ! return END subroutine cublns ! **deck cvip subroutine cvip (a,ia,b,ib,m,c) implicit double precision (a-h,o-z) complex*16 a(*), b(*), c ! ! fortran equivalent of the bcslib routine vip. ! this routine computes the inner product of two vectors, 'a' an ! these vectors are supplied to vip using first word address ! and word increment descriptions ! ! a i r*8 first vector ! ia i int increment through a ! b i r*8 second vector ! ib i int increment through b ! m i int length of inner product ! c o r*8 value of inner product ! ! michael epton, 30 november 1988 ! c = 0.d0 la = 1 lb = 1 do 10 i = 1,m c = c + a(la)*b(lb) la = la + ia lb = lb + ib 10 continue return END subroutine cvip ! **deck d2line subroutine d2line (z1,z2, dist) implicit double precision (a-h,o-z) dimension z1(6), z2(6) ! compute the minimum distance (squared) between two finite line dimension dz(3), en(3), v(3), t1(3), t2(3), t2x(3) data epsq / 1.d-20 / ! t1(1) = z1(4) t1(2) = z1(5) t1(3) = z1(6) ! t2(1) = z2(4) t2(2) = z2(5) t2(3) = z2(6) ! dz(1) = z2(1) - z1(1) dz(2) = z2(2) - z1(2) dz(3) = z2(3) - z1(3) ! dzt1 = dz(1)*t1(1) + dz(2)*t1(2) + dz(3)*t1(3) dzt2 = dz(1)*t2(1) + dz(2)*t2(2) + dz(3)*t2(3) t1t2 = t1(1)*t2(1) + t1(2)*t2(2) + t1(3)*t2(3) t1sq = t1(1)*t1(1) + t1(2)*t1(2) + t1(3)*t1(3) t2sq = t2(1)*t2(1) + t2(2)*t2(2) + t2(3)*t2(3) ! c1 = dzt1/t1sq gm1 = t1t2/t1sq ! c2 = -dzt2/t2sq gm2 = t1t2/t2sq ! if ( min(c1,c1+gm1).ge.1.d0 .or. max(c1,c1+gm1).le.0.d0 ) goto 500 if ( min(c2,c2+gm2).ge.1.d0 .or. max(c2,c2+gm2).le.0.d0 ) goto 500 ! en(1) = t1(2)*t2(3) - t1(3)*t2(2) en(2) = t1(3)*t2(1) - t1(1)*t2(3) en(3) = t1(1)*t2(2) - t1(2)*t2(1) ensq = en(1)**2 + en(2)**2 + en(3)**2 if ( ensq .lt. epsq*t1sq*t2sq ) go to 200 ! usual case, intersection possible ! in unit square and t1 not parallel ! to t2 v(1) = en(2)*dz(3) - en(3)*dz(2) v(2) = en(3)*dz(1) - en(1)*dz(3) v(3) = en(1)*dz(2) - en(2)*dz(1) ! tau1 = ( v(1)*t2(1) + v(2)*t2(2) + v(3)*t2(3) ) / ensq tau2 = ( v(1)*t1(1) + v(2)*t1(2) + v(3)*t1(3) ) / ensq ! check that close passage actually occ ! in the unit square if ( tau1.le.0.d0 .or. tau1.ge.1.d0 ) go to 500 if ( tau2.le.0.d0 .or. tau2.ge.1.d0 ) go to 500 dsq = ( ( dz(1)*en(1)+dz(2)*en(2)+dz(3)*en(3) )**2 )/ensq go to 950 ! t1 essentially parallel to t2 200 continue f = dzt1/t1sq dz(1) = dz(1) - f*t1(1) dz(2) = dz(2) - f*t1(2) dz(3) = dz(3) - f*t1(3) ! g = t1t2/t1sq t2x(1) = t2(1) - g*t1(1) t2x(2) = t2(2) - g*t1(2) t2x(3) = t2(3) - g*t1(3) ! t2xsq = t2x(1)**2 +t2x(2)**2 +t2x(3)**2 if ( t2xsq .le. 0.d0 ) go to 250 dzt2x = dz(1)*t2x(1) + dz(2)*t2x(2) + dz(3)*t2x(3) f = dzt2x/t2xsq dz(1) = dz(1) - f*t2x(1) dz(2) = dz(2) - f*t2x(2) dz(3) = dz(3) - f*t2x(3) 250 continue ! dsq = dz(1)**2 + dz(2)**2 + dz(3)**2 go to 950 ! ! shortest distance on boundary of unit 500 continue f1 = max( 0.d0, min ( 1.d0, dzt1/t1sq )) f2 = max( 0.d0, min ( 1.d0, (dzt1+t1t2)/t1sq )) f3 = max( 0.d0, min ( 1.d0, (-dzt2/t2sq) )) f4 = max( 0.d0, min ( 1.d0, (-dzt2+t1t2)/t2sq )) d1 = 0.d0 d2 = 0.d0 d3 = 0.d0 d4 = 0.d0 do 600 i = 1,3 d1 = d1 + ( dz(i)-f1*t1(i) )**2 d2 = d2 + ( dz(i)+t2(i)-f2*t1(i) )**2 d3 = d3 + ( -dz(i) - f3*t2(i) )**2 d4 = d4 + ( -dz(i) + t1(i) - f4*t2(i) )**2 600 continue dsq = min ( d1,d2,d3,d4 ) go to 950 ! 950 continue dist = sqrt( dsq ) return END subroutine d2line ! **deck daspl subroutine daspl (knet,ntk,nm,nn,nsa,nssa,ns,nss,maps,locs,npa,zm & & ,ia,za & & ,kblc,nblc,blcp,blc,iblc) implicit double precision (a-h,o-z) dimension maps(1), locs(1), zm(3,nm,nn) dimension ia(1:*), za(3,1:*) dimension blcp(kblc,4), blc(kblc,nblc), iblc(nblc) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to calculate the singularity destribution defining quantities* ! * for doublet/analysis (type 12) and doublet/wake (types 18,20)* ! * networks using the continuous 9-degree of freedom doublet * ! * spline. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * singularity parameter locations are computed and ordered * ! * using the subroutines gcpcal and grdind respectively. for * ! * each panel the indices of the singularity parameters * ! * affecting the distribution of doublet strength on that * ! * panel are determined. then the dependence of doublet strength* ! * at the 9 canonical panel points (cp) in terms of these * ! * singularity parameters is computed. this dependence is * ! * defined by the matrix astd which is formally assembled in * ! * subroutine blcal. however the actual computation of the * ! * dependence of doublet strength at each network grid point * ! * and its adjacent edge midpoints in the increacing row and * ! * column directions on neighboring singularity parameters is * ! * accomplished by the subroutine blccal. the singularity * ! * spline defining quantities iid,astd,ind,ncd and its are * ! * assembled and stored on i/o unit 2 along with previously * ! * computed panel geometry defining quantities. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * ari /pandq/ input transformation from local sub-* ! * panel to global coordinates * ! * * ! * astd /pandq/ output matrix relating nine canonical* ! * panel doublet values to * ! * neighboring singularity * ! * parameters * ! * * ! * blc argument -local- holding array containing * ! * dependence of doublet values * ! * at various grid points and two* ! * adjacent edge midpoints in * ! * increasing row and column * ! * directions on local doublet * ! * parameters * ! * * ! * blcp argument -local- blc matrices for each of four * ! * panel corner points * ! * * ! * ia argument -local- index array for singularity * ! * parameter grid za * ! * * ! * iblc argument -local- index array for blc. iblc(k)= * ! * index of grid point whose * ! * doublet value dependence * ! * matrix is stored beginning at * ! * blc(1,k) * ! * * ! * icp -local- -local- indices of four panel corner * ! * points * ! * * ! * iid /pandq/ output index array for panel doublet * ! * singularity parameters * ! * * ! * imap -local- -local- index map indicating which * ! * points in the domain of iblc * ! * are mapped into the range of * ! * icp * ! * * ! * imax -local- - - - - number dependant columns * ! * * ! * ind /pandq/ output number of doublet singularity * ! * parameters on which panel * ! * doublet distribution depends * ! * * ! * ins /pandq/ output number of source singularity * ! * parameters on which panel * ! * source distribution depends * ! * * ! * ip -local- - - - - index of panel in network * ! * * ! * isingp /prnt/ input print flag for singularity * ! * data (=1 if print desired) * ! * * ! * its /pandq/ input panel singularity type * ! * =1 source alone * ! * =2 doublet alone * ! * =3 source and doublet * ! * * ! * jmax -local- - - - - number dependant rows * ! * * ! * kn argument input network number * ! * * ! * ncd /pandq/ output number of parameters (i.e. * ! * quadratic coefficients) * ! * defining panel doublet * ! * distribution * ! * * ! * nsd /pandq/ output number of parameters (i.e. * ! * linear coefficients) defining * ! * panel source distribution * ! * * ! * nm argument input number of rows of * ! * network corner point grid * ! * * ! * nn argument input number of columns of * ! * network corner point grid * ! * * ! * npa argument input number of panels in all * ! * previous networks * ! * * ! * nsa argument input number of singularity * ! * parameters in all previous * ! * networks * ! * * ! * ns argument output number of singularity * ! * parameters in network * ! * * ! * nt -local- - - - - network type * ! * * ! * ntk argument input (signed) network type * ! * * ! * za argument -local- global coordinates of network * ! * singularity parameter * ! * locations * ! * * ! * zc -local- -local- control potints in vicinity of* ! * given grid point * ! * * ! * zm argument input coordinates of corner points * ! * in network grid * ! * * ! * zmc -local- -local- grid points in vicitnity of * ! * given grid point * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call indxsp common /indxsp/ nxsptt, nxspa(151), locxsp(1200) & & , ngsptt, ngspa(151), locgsp(1200) !end indxsp !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call matprp parameter (mxsrfs=300) ! mxsrfs needs to be set equal to 2*mxnett common /matprp/ matnet(2,mxnett) & & , nprop, npropx, tratio(0:10), pratio(0:10) & & , dratio(0:10), vfmat(0:10), wfmat(0:10) & & , cpfmat(0:10) & & , gcnmat(0:10), pcnmat(0:10), rcnmat(0:10) & & , vfsmat(3,4,0:10) & & , imatls(mxsrfs) common /matprc/ qratio(0:10) & & , qnetls(mxsrfs), qsrfls(mxsrfs), qmatls(mxsrfs) character*10 qratio, qnetls, qsrfls, qmatls !end matprp !call lndblx ! /lndblx/ common /lndblx/ genwak(3,mxnett), slndbl(mxnett) & & , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett) !end lndblx !ca lfqprm ! /lfqprm/ ! major flags for controlling the low-frequency features ! mlofrq = 0, normal run ! = 1, ph/0 run, low frequency theory ! = 2, (d/dt) ph/0 run, low frequency theory ! = 3, ph/1,h run, low frequency theory ! adjgeo = .true., include ztz corrections in geometry ! (full low frequency theory) ! = .false., do not include ztz corrections in geometry, ! (linearized low frequency theory) ! adjwak = .true., adjust wake zeta's, fixing trailing edges ! .false., accept user's values of wake zeta's as given ! inczex = .true., include zeta terms for nropt =4,9 (exhaust bc's) ! = .false., exclude zeta terms for nropt =4,9 ! lfqind controls the type of processing done and implies that ! mlofrq will take on certain values ! lfqind = 0, standard a502 run; mlofrq = 0 [bconcl] ! = 1, low frequency theory with current geometry ! mlofrq = 1 [bconcl]; 2,3 [lfqg23] ! = 2, low frequency theory with linearized solution ! mlofrq = 0 [bconcl]; 1,2,3 [lfq123] common /lfqprm/ mlofrq, adjgeo, adjwak, inczex & & , lfqind logical adjgeo, adjwak, inczex ! !end lfqprm !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase ! formerly in /skrch1/ dimension zc(3,4,4),zmc(3,5,5),icp(4),imap(4) ! dimension iijjar(3,3), zij(3), zle(3) dimension astdp(234), iidp(26) dimension astdwk(234), iidwk(26), indx(4), iidx(4,4), astx(4,4) dimension locpak(4), nwsdpt(4) data iijjar / 1, 8, 4, 5, 9, 7, 2, 6, 3/ !c ! * set indices defining limits of each local dependance * ! data ipxdas /0/ data ijmax,mnind /5,2/ call jzero(iblc,nblc) !c ! * set network type * ! nt=iabs(ntk) nxspk = nxspa(knet+1) - nxspa(knet) !c ! * determine number of rows and columns of singularity * ! * parameters * ! nma=nm+1 nna=nn+1 nssdef = nma*nna if ( nt.eq.18 ) nssdef = nna if ( nt.eq.20 ) nssdef = nna !c ! * determine location of singularity parameters * ! call gcpcal(nm,nn,zm,nma,nna,za) if ( nt.eq.18 ) call mtrxtr (za,nma,nna,3) !c ! * order distinct singularity parameters * ! call grdind(nma,nna,za,ia,nia) if ( nt.eq.18 ) call mtrxtr (za,nma,nna,3) np=(nm-1)*(nn-1) ns = nia if ( nt.eq.18 ) ns = ia(nna) if ( nt.eq.20 ) ns = 1 nstk = ns + nxspk !c ! * loop cycles through all panels in network * ! kntblc = 0 indwk = 0 do 699 ipk=1,np !c ! * retrieve panel defining quantities * ! ip=ipk+npa call strns(ip,cp) !c ! * set panel singularity type * ! its=2 if(ntk.lt.0) its=3 !c ! * set number of degrees of freedom of panel doublet * ! * distribution * ! ncd=9 call mnmod(ipk,nm-1,m,n) ipan = m jpan = n npk=0 !c ! * set index of singularity parameters affecting panel * ! * singularity distribution * ! do 629 j=1,ijmax nj=min (max (n+j-mnind,1),nna) do 628 i=1,ijmax mi=min (max (m+i-mnind,1),nma) npk=npk+1 lmn=mi+nma*(nj-1) iidp(npk) = nssa + lmn if ( nt .eq. 18 ) iidp(npk) = nssa + nj if ( nt .eq. 20 ) iidp(npk) = nssa + 1 if(((i.eq.1).or.(i.eq.ijmax)).and.((j.eq.1).or.(j.eq.ijmax))) & &iidp(npk)=0 628 continue 629 continue !c ! * set number of neighboring singularity parameters affecting * ! * panel doublet distribution * ! ind=npk if(its.eq.2) ins=0 if((nt.ne.12).and.(m.gt.1)) go to 640 !c ! * determine whether doublet value dependence on singularity * ! * parameter matrices already exist in blc for each of four * ! * panel corner points * ! icp(1)=m+nm*(n-1) icp(2)=icp(1)+1 icp(3)=icp(1)+nm icp(4)=icp(3)+1 call incmpr(icp,iblc,imap,4,nblc) do 639 lcp=1,4 ima=iabs(imap(lcp)) if(imap(lcp).gt.0) go to 639 !c ! * compute new matrix * ! call mnmod(icp(lcp),nm,m,n) do 632 k=1,25 call mnmod(k,5,i,j) mc=min (max (m+i-3,1),nm) nc=min (max (n+j-3,1),nn) call dcopy (3,zm(1,mc,nc),1,zmc(1,i,j),1) 632 continue do 635 k=1,16 call mnmod(k,4,i,j) mi=min (max (m+i-2,1),nma) nj=min (max (n+j-2,1),nna) lmn=mi+nma*(nj-1) call dcopy (3,za(1,lmn),1,zc(1,i,j),1) 635 continue !c ! * compute dependence of doublet strength at grid point and two * ! * adjacent edge midpoints in increasing row and column * ! * directions on network singularity parameters * ! call blccal(m,n,nm,nn,zmc,zc,blc(1,ima)) iblc(ima)=icp(lcp) 639 call dcopy (48,blc(1,ima),1,blcp(1,lcp),1) !c ! * assemble dependence of doublet strength at 9 canonical panel * ! * locations on neighboring singularity parameters * ! 640 continue call blcal(blcp,astdp) call xdaspl (knet,ipan,jpan, indx,iidx,astx, nssa, ipxdas) kndx = indx(1) + indx(2) + indx(3) + indx(4) if ( kndx.le.0 ) go to 642 ! if ( ipxdas.le.0 ) go to 641 write (6,'(1x,a10,1x, 4i12)') & & 'xdaspl',knet,ipan,jpan,kndx call outvci ('indx',4,indx) call outmti ('iidx',4,4,4,iidx) call outmat ('astx',4,4,4,astx) 641 continue call xdasin (astdp,iidp,ind, indx,iidx,astx, ipxdas) ! 642 continue !c ! * compact matrix describing dependence of singularity * ! * coefficients on surrounding singularity parameters * ! if(nt.eq.12) go to 650 if ( nt.eq.18 .and. ipan.eq.1 ) goto 643 if ( nt.eq.20 .and. ipan.eq.1 .and. jpan.eq.1 ) goto 643 goto 645 ! normal wakes are constant in ! the row direction. enforce this. 643 continue do 644 k=1,ind l=9*(k-1) astdp(l+4)=astdp(l+1) astdp(l+8)=astdp(l+1) astdp(l+7)=astdp(l+5) astdp(l+9)=astdp(l+5) astdp(l+3)=astdp(l+2) astdp(l+6)=astdp(l+2) 644 continue call scmpkt (astdp,iidp,ncd,ind) ncdwk = ncd indwk = ind call dcopy (ncdwk*indwk, astdp,1, astdwk,1) call icopy (indwk, iidp,1, iidwk,1) ! copy baseline leading edge panel ! data into current panel's data 645 continue call dcopy (ncdwk*indwk, astdwk,1, astdp,1) call icopy (indwk, iidwk,1, iidp,1) ncd = ncdwk ind = indwk if ( lfqind.eq.0 ) goto 650 ! put in linear dependency upon ! known mu/x terms do 647 ii = 1,3 do 647 jj = 1,3 iijj = iijjar(ii,jj) ifn = 2*(ipan-1) + ii jfn = 2*(jpan-1) + jj call enrchg (knet,ifn,jfn,zij) call enrchg (knet, 1,jfn,zle) spl = compd(1)*(zij(1)-zle(1)) & & +compd(2)*(zij(2)-zle(2)) & & +compd(3)*(zij(3)-zle(3)) do 646 k = 1,indwk lmu = 9*(k-1)+iijj lmux = lmu + 9*indwk astdp(lmux) = spl*astdp(lmu) 646 continue 647 continue do 648 k = 1,indwk iidp(k+indwk) = iidp(k) + nstk 648 continue ncd = ncdwk ind = 2*indwk 650 continue if ( ind.gt.26 ) then write (7,'( '' ind,knet,ipan,jpan '',4i6)') ind,knet,ipan,jpan call a502ms ('daspl','overflow of iidp, astdp') endif call scmpkt(astdp,iidp,ncd,ind) if ( nt.eq.18 .or. nt.eq.20 ) then if ( iextrp.ge.2 ) then write (6,'( '' ===daspl, k,i,j '',4i6)' ) knet,ipan,jpan,nt call outvci ('iidp',ind,iidp) call outmat ('astdp',ncd,ncd,ind,astdp) endif endif call dcopy (ncd*ind,astdp,1,astd,1) call icopy (ind,iidp,1,iid,1) ! extract astmux information from astd ! The dependence of the mu/x params ! at panel point [3,7,4] (t.e. pts ! [1,2,3]) is the same as the ! dependence of mu at panel points ! [2,5,3], the leading edge points ! upstream of [3,7,4]. if ( nt.ne.18 .and. nt.ne.20 ) goto 661 if ( lfqind.eq.0 ) goto 661 != write (6,'('' daspl, astmux construction'',3i6)')knet,ipan,jpan != write (6,'('' nstk '',i6)') nstk != call outvci ('iid',ind,iid) != call outmtx ('astd',9,9,ind,astd) inmux = 0 call icopy (5, 0,0, iimux,1) do 660 j = 1,ind if ( iid(j).gt.nssa+nstk ) goto 660 ! found a regular (non mu/x) parm jbase = 9*(j-1) inmux = inmux + 1 if ( inmux.gt.5 ) then write (6,'('' inmux overflow:'',3i6)') knet,ipan,jpan call a502ms ('daspl','astmux overflow') goto 661 endif ! mu/x parameters are displaced by ! nstk from corresponding mu parms iimux(inmux) = iid(j) + nstk astmux(1,inmux) = astd(2+jbase) astmux(2,inmux) = astd(5+jbase) astmux(3,inmux) = astd(1+jbase) 660 continue != call outvci ('iimux',inmux,iimux) != call outmtx ('astmux',3,3,inmux,astmux) 661 continue ! !c ! * skip spline diagnostic data computation and print section * ! * if data not desired * ! if(isingp.ne.1)go to 690 no=2 if(isingp.eq.1) write(6,2000) ip,kp,no,ind 2000 format(///1x,11hpanel no. =,i5,5x,13hnetwork no. =,i5, & &5x,20hdistribution order =,i5, & &5x,34hnumber of singularity parameters =,i5,///, & &2x,2his,8x,2ha1,12x,2ha2,12x,2ha3,12x,2ha4,12x,2ha5,12x,2ha6,12x, & &2ha7,12x,2ha8,12x,2ha9,5x,/) do 679 k=1,ind l1=ncd*(k-1)+1 l2=ncd*k if(isingp.eq.1) write(6,3000) iid(k),(astd(l),l=l1,l2) 3000 format(i5,9e14.5) 679 continue 690 continue !c ! * store panel singularity distribution defining quantities on * ! * i/o unit 2 along with panel geometry defining quantities * ! call istrns(ip,cp) 699 continue ! ! ! locpak(1) = knet locpak(4) = 2 if ( nt.eq.18 ) go to 750 if ( nt.eq.20 ) go to 780 ! nt = 12, maps generation do 720 j = 1,nna do 720 i = 1,nma ij = i + nma*(j-1) maps(nssa+ij) = nsa + ia(ij) ifn = max ( 1, min ( 2*nm-1, 2*i-2 ) ) jfn = max ( 1, min ( 2*nn-1, 2*j-2 ) ) locpak(2) = jfn locpak(3) = ifn call icopy (4, locpak,1, locs(4*(nssa+ij)-3),1) 720 continue nss = nma*nna ns = nia go to 800 ! nt = 18, maps generation 750 continue do 760 j = 1,nna maps(nssa+j) = nsa + ia(j) jfn = max ( 1, min ( 2*nn-1, 2*j-2 ) ) locpak(2) = jfn locpak(3) = 1 call icopy (4, locpak,1, locs(4*(nssa+j)-3),1) 760 continue nss = nna ns = ia(nna) go to 800 ! nt = 20, maps generation 780 continue maps(nssa+1) = nsa + 1 locpak(2) = 1 locpak(3) = 1 call icopy (4, locpak,1, locs(4*(nssa+1)-3),1) nss = 1 ns = 1 go to 800 ! add in extra control points to maps 800 continue if ( nxspk .le. 0 ) go to 850 nxspak = nxspa(knet) do 820 i = 1,nxspk maps(nssa+nss+i) = nsa + ns + i call icopy (4, locxsp(4*(nxspak+i)-3),1, nwsdpt,1) call mnmod (nwsdpt(4), 2*nm-1, ifn, jfn) locpak(2) = jfn locpak(3) = ifn call icopy (4, locpak,1, locs(4*(nssa+nss+i)-3),1) 820 continue nss = nss + nxspk ns = ns + nxspk 850 continue ! put linear dependency in wake maps if ( nt.ne.18 .and. nt.ne.20 ) goto 870 if ( lfqind.eq.0 ) goto 870 do 860 i = 1,nss maps(nssa+nss+i) = maps(nssa+i) + ns call icopy (4, locs(4*(nssa+i)-3),1, locpak,1) locpak(4) = 3 call icopy (4, locpak,1, locs(4*(nssa+nss+i)-3),1) 860 continue nss = 2*nss ns = 2*ns 870 continue !c ! * set total number of singularity parameters in network * ! antblc = kntblc ratio = antblc / ( nm*nn ) if ( ratio .gt. 1.2d0 ) & & write (6,'(1x,a10,1x, 4i12,f12.6)') & & 'blc stats',knet,nm,nn,kntblc,ratio return END subroutine daspl ! **deck date subroutine date (ch) character*8 ch integer int(3) ! ! build an 8 character data: mm/dd/yy ! ! put installation date in int(1) = 02 int(2) = 12 int(3) = 92 if ( int(3).gt.1900 ) int(3) = int(3) - 1900 write (ch,6001) (int(k),k=1,3) 6001 format ( i2.2, '/', i2.2, '/', i2.2 ) return END subroutine date ! **deck daxpy subroutine daxpy (n, a, x,ix, y,iy) implicit double precision (a-h,o-z) dimension x(1), y(1) ! ! standard blas saxpy ! if ( n.le.0 ) return lx = 1 ly = 1 if ( ix.le.0 ) lx = lx + iabs(ix)*(n-1) if ( iy.le.0 ) ly = ly + iabs(iy)*(n-1) do 100 k = 1,n y(ly) = y(ly) + a*x(lx) lx = lx + ix ly = ly + iy 100 continue return END subroutine daxpy ! **deck dcbht subroutine dcbht (a,d,sa,jq,na,m,n) implicit double precision (a-h,o-z) ! given a matrix a of dimensions (m,n) stored in an array ! a(na,1), obtain the q-r factorization by the method of ! householder reflectors. this version is consistent with ! the bcs routine dcbht, but is faster because of the use ! of the fast matrix multiply routines rrzatb and rrsabt ! at exit, a factorization of a of the form ! ! a = h(1) * h(2) * ... * h(n) * r ! ! is obtained and saved in packed format. ! dimension a(na,1), d(n), sa(n), jq(n) ! ! initialize pivot vector jq and ! compute column norms d(j) do 10 j = 1,n jq(j) = j d(j)=ddot(m,a(1,j),1,a(1,j),1) 10 continue ! do 100 k = 1,n ! find a pivot column dmax = d(k) l = k do 20 j = k,n if ( d(j) .le. dmax ) go to 20 dmax = d(j) l = j 20 continue ! if l.ne.k, interchange col*s k and l if ( l.eq.k ) go to 40 jsv = jq(l) jq(l) = jq(k) jq(k) = jsv dsv = d(l) d(l) = d(k) d(k) = dsv do 30 i = 1,m asv = a(i,l) a(i,l) = a(i,k) a(i,k) = asv 30 continue 40 continue ! ! compute beta(k) and w(.,k) for the rearesentation ! of h(k) in the form ! ! h(k) = i - beta(k) * w(.,k) * w(.,k)(t) ! nrem = m-k+1 asq=ddot(nrem,a(k,k),1,a(k,k),1) if ( asq.le.0 ) go to 100 dk = sqrt( asq ) if ( a(k,k) .ge. 0.d0 ) dk = -dk d(k) = dk a(k,k) = a(k,k)-dk beta = -1.d0/( a(k,k) * d(k) ) kp1 = k+1 if ( k.eq.n ) go to 100 ! apply householder transpormations ! to columns k+1 throgh n call mxma (a(k,kp1),na,1 ,a(k,k),1,nrem ,sa,1,n-k ,n-k,nrem,1) call vmul ( sa, beta, sa, n-k) call hsmmp3 (nrem,1,n-k ,a(k,k),1,nrem ,sa,1,1 ,a(k,kp1),1,na) do 50 j = kp1,n d(j) = d(j) - a(k,j)**2 50 continue 100 continue return END subroutine dcbht ! **deck dcip subroutine dcip (u,v,uv) implicit double precision (a-h,o-z) dimension u(3), v(3) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs uv = u(1)*v(1)+u(2)*v(2)+u(3)*v(3) + & & (betams-1.d0)*(u(1)*compd(1)+u(2)*compd(2)+u(3)*compd(3))& & *(v(1)*compd(1)+v(2)*compd(2)+v(3)*compd(3)) return END subroutine dcip ! **deck dcopy subroutine dcopy (n, x,ix, y,iy) implicit double precision (a-h,o-z) dimension x(1), y(1) ! ! standard blas scopy ! if ( n.le.0 ) return lx = 1 ly = 1 if ( ix.le.0 ) lx = lx + iabs(ix)*(n-1) if ( iy.le.0 ) ly = ly + iabs(iy)*(n-1) if ( ix.eq.0 ) goto 200 do 100 k = 1,n y(ly) = x(lx) lx = lx + ix ly = ly + iy 100 continue return 200 continue do 300 k = 1,n y(ly) = x(1) ly = ly + iy 300 continue return END subroutine dcopy ! **deck ddot double precision function ddot (n, x,ix, y,iy) implicit double precision (a-h,o-z) dimension x(1), y(1) ! ! standard blas scopy ! ddot = 0.d0 if ( n.le.0 ) return lx = 1 ly = 1 if ( ix.le.0 ) lx = lx + iabs(ix)*(n-1) if ( iy.le.0 ) ly = ly + iabs(iy)*(n-1) sum = 0.d0 do 100 k = 1,n sum = sum + y(ly)*x(lx) lx = lx + ix ly = ly + iy 100 continue ddot = sum return END Function Ddot ! **deck ddwspl subroutine ddwspl (knet,ntk,m,n,nsa,nssa,nbasic,nnaive & & ,maps,locs,npa,zm,ia,za) implicit double precision (a-h,o-z) dimension maps(1), locs(1), zm(3,m,n) dimension ia(1:*), za(3,1:*) ! ! construct design wake splines (lev nw type 6) ! !call indxsp common /indxsp/ nxsptt, nxspa(151), locxsp(1200) & & , ngsptt, ngspa(151), locgsp(1200) !end indxsp !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call compsp ! /compsp/ ! contains info relating mu on edges 2 or 4 of ntdk=6 nw's ! to panel interior values common /compsp/ bpsp(6,200,2) & & , kntpsp, npsp(200,2), kkpsp(200,2), iipsp(6,200,2) !end compsp !call lsqsfc ! /lsqsfc/ common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk !end lsqsfc logical ident common /skrchy/ scry(200,28) dimension lijpnt(3,3), ze(3,3,3), amr(3,3), enr(3), iidp(25,9) dimension w(3), xe(4),bdp(25,9), iide(4), npkp(9), iidq(225) dimension nwsdpt(4), locx(4), locpak(4), zmu(3), we(4), zwe(3,4) ! data lijpnt / 1,8,4, 5,9,7, 2,6,3 / data deltf / 10000.d0 / ! ! ntdk = iabs(ntk) nxspk = nxspa(knet+1) - nxspa(knet) if ( m.gt.200 ) call a502er ('ddwspl' & & ,'more than 200 rows in a network') call icopy (400, 0,0, npsp,1) ! nma = m nna = n + 1 call gcpcal (m,n,zm, nma,nna,za) call grdind (nma,nna,za,ia,nia) npan = (m-1)*(n-1) mfn = 2*m-1 nfn = 2*n-1 ! loop over the panels of the network do 900 ijpan = 1,npan call mnmod (ijpan,m-1,ipan,jpan) ip = ijpan + npa call strns (ip,cp) call jzero (npkp,9) its = 2 if ( ntk.lt.0 ) its = 3 ncd = 9 ! ! loop over the 9 canonical points on t ! do 800 jpt = 1,3 do 800 ipt = 1,3 lij = lijpnt(ipt,jpt) ifn = ipt + 2*(ipan-1) jfn = jpt + 2*(jpan-1) klass = 0 ipar = mod(ifn,2) jpar = mod(jfn,2) klass = ipar + 2*jpar + 1 ! use klass=5 for all of edges 2 and 4 if ( ifn.eq.1 .or. ifn.eq.mfn ) klass = 6 if ( jfn.eq.1 .or. jfn.eq.nfn ) klass = 5 go to (100, 200, 300, 400, 500, 600), klass ! panel center 100 continue imin = max(1, min(nma, ipan-1)) imax = max(1, min(nma, ipan+2)) jmin = max(1, min(nna, jpan )) jmax = max(1, min(nna, jpan+2)) ! do 110 jj = 1,3 do 110 ii = 1,3 i1 = ipan + (ii-1)/2 i2 = ipan + ii/2 j1 = jpan + (jj-1)/2 j2 = jpan + jj/2 ze(1,ii,jj) = .25d0*( zm(1,i1,j1)+zm(1,i1,j2) & & +zm(1,i2,j1)+zm(1,i2,j2)) ze(2,ii,jj) = .25d0*( zm(2,i1,j1)+zm(2,i1,j2) & & +zm(2,i2,j1)+zm(2,i2,j2)) ze(3,ii,jj) = .25d0*( zm(3,i1,j1)+zm(3,i1,j2) & & +zm(3,i2,j1)+zm(3,i2,j2)) 110 continue call msrotm (ze,3,3,2,2,amr) ! ! ! k = 0 do 120 j = jmin,jmax do 120 i = imin,imax ij = i + (j-1)*nma k = k + 1 iidp(k,lij) = nssa + ij call bxycal (amr,ze(1,2,2),za(1,ij),zk(1,k),wtk(k)) if ( j.eq.jpan+1 .and. (i.eq.ipan .or. i.eq.ipan+1) ) & & wtk(k) = deltf 120 continue ! no = 2 npk = k if ( npk.le.6 ) no = 1 call lsqsg call dcopy (npk, ak(1,1),6, bdp(1,lij),1) npkp(lij) = npk go to 800 ! interior, on mesh row, between mesh c 200 continue i = (ifn+1)/2 j = jpan+1 ij = i + (j-1)*nma npkp(lij) = 1 iidp(1,lij) = nssa + ij bdp(1,lij) = 1.d0 go to 800 ! interior, between mesh rows, on mesh 300 continue imin = max(1, min (nma, ifn/2 - 1 )) imax = max(1, min (nma, ifn/2 + 2 )) jmin = max(1, min (nna, (jfn+1)/2 - 1 )) jmax = max(1, min (nna, (jfn+1)/2 + 2 )) jcrs = (jfn+1)/2 i1 = ifn/2 i2 = i1 + 1 j1 = jcrs j2 = j1 + 1 do 310 jj = 1,3 call dcopy (3, zm(1,i1,jcrs+jj-2),1, ze(1,1,jj),1 ) call dcopy (3, zm(1,i2,jcrs+jj-2),1, ze(1,3,jj),1 ) ze(1,2,jj) = .5d0*(ze(1,1,jj)+ze(1,3,jj)) ze(2,2,jj) = .5d0*(ze(2,1,jj)+ze(2,3,jj)) ze(3,2,jj) = .5d0*(ze(3,1,jj)+ze(3,3,jj)) 310 continue ! call msrotm (ze,3,3,2,2,amr) k = 0 do 320 j = jmin,jmax do 320 i = imin,imax ij = i + (j-1)*nma k = k + 1 iidp(k,lij) = nssa + ij call bxycal (amr,ze(1,2,2),za(1,ij),zk(1,k),wtk(k)) if ( (i.eq.i1 .or. i.eq.i2) .and. & & (j.eq.j1 .or. j.eq.j2) ) wtk(k) = deltf 320 continue no = 2 npk = k if ( npk.le.6 ) no = 1 call lsqsg call dcopy (npk,ak(1,1),6,bdp(1,lij),1) npkp(lij) = npk go to 800 ! interior, on mesh row and column 400 continue icrs = (ifn+1)/2 jcrs = (jfn+1)/2 j1 = jcrs j2 = jcrs + 1 i1 = icrs imin = max( 1, min( nma, icrs-1 )) imax = max( 1, min( nma, icrs+1 )) jmin = max( 1, min( nna, jcrs-1 )) jmax = max( 1, min( nna, jcrs+2 )) ! do 410 jj = 1,3 do 410 ii = 1,3 call dcopy (3, zm(1,icrs+ii-2,jcrs+jj-2),1, ze(1,ii,jj),1) 410 continue ! call msrotm (ze,3,3,2,2,amr) k = 0 do 420 j = jmin,jmax do 420 i = imin,imax ij = i + (j-1)*nma k = k + 1 iidp(k,lij) = nssa + ij call bxycal (amr,ze(1,2,2),za(1,ij),zk(1,k),wtk(k)) if ( i.eq.i1 .and. (j.eq.j1 .or. j.eq.j2) ) wtk(k) = deltf 420 continue no = 2 npk = k if ( npk.le.6 ) no = 1 call lsqsg call dcopy (npk, ak,6, bdp(1,lij),1) npkp(lij) = npk go to 800 ! first or last column 500 continue if ( ipar.eq.0 ) go to 550 ! singularity parameter location, edge i = (ifn+1)/2 j = 1 if ( jfn.eq.nfn ) j = nna ij = i + (j-1)*nma npkp(lij) = 1 iidp(1,lij)= nssa + ij bdp(1,lij) = 1.d0 ! calculate special splines for edge 2 ! s.p. locations to override aero bc's ! their corresponding control points icrs = (ifn+1)/2 jcrs = (jfn+1)/2 jx = 1 if ( jfn.gt.1 ) jx = 2 if ( npsp(icrs,jx).ne.0 ) goto 540 kkpsp(icrs,jx) = nssa + ij imin = max (1, icrs-1) imax = min (nma,icrs+1) if ( jx.eq.2 ) goto 510 jmin = 2 jmax = 3 goto 511 510 continue jmin = nna-2 jmax = nna-1 511 continue call msrotm (zm,m,n,icrs,jcrs,amr) k = 0 jsng = 1 if ( jx.eq.2 ) jsng = nna !--- call outlin ('edge spl',5,knet,ifn,jfn,jsng,jx) do 520 j = jmin,jmax do 520 i = imin,imax ij = i + (j-1)*nma k = k + 1 iipsp(k,icrs,jx) = nssa + ij call bxycal (amr,zm(1,icrs,jcrs),za(1,ij),zk(1,k),wtk(k)) if ( (i.eq.icrs) .and. iabs(j-jsng).eq.1 ) wtk(k) = deltf !--- call outlin ('spl inda',6,k,i,j,zk(1,k),zk(2,k),wtk(k)) 520 continue npk = k no = 1 call lsqsg call dcopy (npk, ak,6, bpsp(1,icrs,jx),1) !--- call outmat ('ak',6,1,npk,ak) npsp(icrs,jx) = npk 540 continue go to 800 ! ! ! not a s.p. location (usual edge splin 550 continue imin = max( 1, min( nma, ifn/2-1 )) imax = max( 1, min( nma, ifn/2+2 )) j = 1 if ( jfn.eq.nfn ) j = nna i1 = ifn/2 i2 = i1 + 1 ij1 = i1 + (j-1)*nma ij2 = i2 + (j-1)*nma zmu(1) = .5d0*( za(1,ij1) + za(1,ij2) ) zmu(2) = .5d0*( za(2,ij1) + za(2,ij2) ) zmu(3) = .5d0*( za(3,ij1) + za(3,ij2) ) ijmin = imin + (j-1)*nma ijmax = imax + (j-1)*nma call distnc (za(1,ijmin), za(1,ij1), dm) call distnc (za(1,ij1 ), za(1,ij2), dmid) call distnc (za(1,ijmax), za(1,ij2), dp) call pident (za(1,ijmin), za(1,ij1), ident) if ( ident .or. ia(ijmin).eq.ia(ij1) ) dm = 0.d0 call pident (za(1,ij1 ), za(1,ij2), ident) if ( ident .or. ia(ij1 ).eq.ia(ij2) ) dmid = 0.d0 call pident (za(1,ijmax), za(1,ij2), ident) if ( ident .or. ia(ijmax).eq.ia(ij2) ) dp = 0.d0 ! xe(1) = -dm - .5d0*dmid xe(2) = -.5d0*dmid xe(3) = .5d0*dmid xe(4) = dp + .5d0*dmid do 560 ii = 1,4 we(ii) = 1.d0 i = i1 + (ii-2) i = min( imax, max( imin, i )) ij = i + (j-1)*nma iidp(ii,lij) = nssa + ij call vadd ( za(1,ij), -1.d0, zmu, w, 3) wsq = w(1)**2 + w(2)**2 + w(3)**2 if ( wsq.le.0.d0 .or. amach.lt.1.d0 ) go to 560 call uvect (w) call vip (w,1, compd,1, 3,wc) we(ii) = 1.d0+amach*(1.d0-wc) 560 continue npk = imax - imin + 1 if ( npk.gt.2 ) go to 570 npkp(lij) = 2 iidp(1,lij) = nssa + ij1 iidp(2,lij) = nssa + ij2 bdp(1,lij) = .5d0 bdp(2,lij) = .5d0 go to 590 ! 570 continue call edgspl (xe,we,bdp(1,lij)) npkp(lij) = 4 go to 590 ! 590 continue go to 800 ! ! first or last row 600 continue if ( jpar.eq.0 ) go to 680 if ( jfn.eq.1 .or. jfn.eq.nfn ) go to 680 ksd = 1 if ( ifn.eq.mfn ) ksd = 3 kpt = (jfn+1)/2 if ( ksd.eq.3 ) kpt = n+1-kpt iz = 1 if ( ksd.eq.3 ) iz = m nxsp1 = nxspa(knet) + 1 nxsp2 = nxspa(knet+1) nxspk = nxsp2 - nxsp1 + 1 call jzero (iide,4) nloc = 0 do 610 l = nxsp1,nxsp2 call icopy (4, locxsp(4*(l)-3),1, nwsdpt,1) if ( nwsdpt(2).ne.ksd ) go to 610 lextra = l lpt = nwsdpt(3) if ( lpt.eq.kpt ) go to 690 idist = iabs(kpt-lpt) if ( idist.gt.1 ) go to 610 nloc = nloc + 1 lnd = ((lpt-kpt)*3+5)/2 iide(lnd)= nssa + nma*nna + l - nxspa(knet) jz = lpt if ( ksd.eq.3 ) jz = n + 1 - lpt call dcopy (3, zm(1,iz,jz),1, zwe(1,lnd),1) 610 continue if ( nloc.gt.2 ) call a502er ('ddwspl' & & ,'too many extra s.p.-s in vicinity ') jz = (jfn+1)/2 call dcopy (3, zm(1,iz,jz),1, zmu,1) inc = 1 if ( ksd.eq.3 ) inc = -1 i = 1 if ( ksd.eq.3 ) i = nma do 620 ii = 1,4 if ( iide(ii).ne.0 ) go to 620 jfnsp = jfn + inc*(2*ii-5) jfnsp = max( 1, min( nfn, jfnsp )) jz1 = (jfnsp+1)/2 jz2 = (jfnsp+2)/2 zwe(1,ii) = .5d0*( zm(1,iz,jz1) + zm(1,iz,jz2) ) zwe(2,ii) = .5d0*( zm(2,iz,jz1) + zm(2,iz,jz2) ) zwe(3,ii) = .5d0*( zm(3,iz,jz1) + zm(3,iz,jz2) ) j = (jfnsp+2)/2 if ( jfnsp.eq.nfn ) j = nna ij = i + (j-1)*nma iide(ii) = ij + nssa 620 continue ! do 630 ii = 1,4 call distnc (zmu,zwe(1,ii),dz) call pident (zmu,zwe(1,ii),ident) if ( ident ) dz = 0.d0 aaaii = ii xe(ii) = sign( 1.d0, aaaii - 2.5d0 ) * dz we(ii) = 1.d0 if ( dz.le.0.d0 .or. amach.lt.1.d0 ) go to 630 call vadd (zwe(1,ii),-1.d0,zmu,w,3) call uvect (w) call vip (w,1, compd,1, 3,wc) we(ii) = 1.d0 + amach*(1.d0-wc) 630 continue call edgspl (xe,we,bdp(1,lij)) call icopy (4, iide,1, iidp(1,lij),1) npkp(lij) = 4 go to 695 ! natural singularity parameter, ! first or last row 680 continue j = (jfn+2)/2 if ( jfn.eq.nfn ) j = nna i = 1 if ( ifn.eq.mfn ) i = nma npkp(lij) = 1 iidp(1,lij)= i + (j-1)*nma + nssa bdp(1,lij) = 1.d0 go to 695 ! extra s.p., first or last row 690 continue npkp(lij) = 1 iidp(1,lij)= nna*nma + nssa + lextra - nxspa(knet) bdp(1,lij) = 1.d0 go to 695 ! 695 continue go to 800 ! 800 continue ! ! pack up the spline matrix ! k = 0 do 820 ii = 1,9 call icopy (npkp(ii), iidp(1,ii),1, iidq(k+1),1) k = npkp(ii) + k 820 continue nq = k call shlsrt (nq,iidq) iidval = iidq(1) - 1 nuq = 0 do 830 k = 1,nq if ( iidq(k).eq.iidval ) go to 830 nuq = nuq + 1 iidq(nuq) = iidq(k) iidval = iidq(nuq) 830 continue call icopy (nuq, iidq,1, iid,1) ind = nuq if ( ind.gt.21 ) call a502er ('ddwspl' & & ,'global s.p. count exceeds limit of 21') call zero (astd,189) do 850 i = 1,9 npk = npkp(i) do 840 k = 1,npk call srchol (iid,ind,iidp(k,i),l) if ( l.eq.0 ) write (6,'(1x,a10,1x, 6i12)') & & 'srchol-err',ipan,jpan,knet & & ,i,k,iidp(k,i) il = i + (l-1)*9 astd(il)= bdp(k,i) + astd(il) 840 continue 850 continue call zero (wtk,9) do 860 j = 1,ind la = 1 + 9*(j-1) call daxpy (9, 1.d0, astd(la),1, wtk,1) 860 continue ! call istrns (ip,cp) 900 continue ! ! ! ! maps generation locpak(1) = knet locpak(4) = 2 nss = nma*nna ns = nia do 920 j = 1,nna do 920 i = 1,nma ij = i + nma*(j-1) maps(nssa+ij) = nsa + ia(ij) ifn = max( 1, min( 2*m-1, 2*i-1 )) jfn = max( 1, min( 2*n-1, 2*j-2 )) locpak(2) = jfn locpak(3) = ifn call icopy (4, locpak,1, locs(4*(nssa+ij)-3),1) 920 continue nxspk = nxspa(knet+1) - nxspa(knet) if ( nxspk.le.0 ) go to 940 nxspak = nxspa(knet) do 930 i = 1,nxspk maps(nssa+nss+i) = nsa + nia + i call icopy (4, locxsp(4*(nxspak+i)-3),1, nwsdpt,1) call mnmod (nwsdpt(4), 2*m-1, ifn, jfn) locpak(2) = jfn locpak(3) = ifn call icopy (4, locpak,1, locs(4*(nssa+nss+i)-3),1) 930 continue nss = nss + nxspk ns = ns + nxspk 940 continue nw = m*28 call pakpsp (200,m, npsp,kkpsp,iipsp,bpsp, 200*28,scry) call iytrns (knet,scry,nw) ! ! ! 950 continue nnaive = nss nbasic = ns return END subroutine ddwspl ! **deck delvca subroutine delvca (nx,nc,x, dv,ii,in, delv) implicit double precision (a-h,o-z) dimension x(nx,nc), dv(3,in), delv(3,nc) dimension ii(in) ! call zero (delv,3*nc) do 200 ic = 1,nc do 100 j = 1,in delv(1,ic) = delv(1,ic) + dv(1,j)*x(ii(j),ic) delv(2,ic) = delv(2,ic) + dv(2,j)*x(ii(j),ic) delv(3,ic) = delv(3,ic) + dv(3,j)*x(ii(j),ic) 100 continue 200 continue return END subroutine delvca ! **deck det function det (a,b,c) implicit double precision (a-h,o-z) double precision det dimension a(3), b(3), c(3) det = a(1)*( b(2)*c(3) - b(3)*c(2) ) & & +a(2)*( b(3)*c(1) - b(1)*c(3) ) & & +a(3)*( b(1)*c(2) - b(2)*c(1) ) return END Function Det ! **deck dfnabu subroutine dfnabu (nwname,nnett & & ,line, k1,isd1,k2,isd2) implicit double precision (a-h,o-z) character*10 nwname(nnett) ! ! take a line of input data describing a forced abutment ($abu) ! and crack it to give network # and edge # ! character*90 line character*10 lk1, lk2 ! read nw info as character data, plus ! data as floating point read (line,6001,err=9950) lk1,sd1,lk2,sd2 6001 format (a,f10.0,a,f10.0) isd1 = sd1 isd2 = sd2 ! attempt a match of the network name k1 = 0 if ( lk1 .eq. ' ' ) goto 101 call ljbf10 (lk1) do 100 k = 1,nnett if ( nwname(k).ne.lk1 ) goto 100 k1 = k goto 110 100 continue 101 continue read (line,6002,err=9950) ak1 6002 format (f10.0) k1 = ak1 110 continue ! attempt a match for the 2nd nw name k2 = 0 if ( lk2.eq.' ' ) goto 201 call ljbf10 (lk2) do 200 k = 1,nnett if ( nwname(k).ne.lk2 ) goto 200 k2 = k goto 210 200 continue 201 continue read (line,6003,err=9950) ak2 6003 format (20x,f10.0) k2 = ak2 210 continue ! write out input and interpretted data write (6,6004) line, k1,isd1,k2,isd2 6004 format (' $abu:',a,' nw.e-1',i4,1h.,i1,' nw.e-2',i4,1h.,i1) ! ! ! return ! ! read error handling ! 9950 continue write (6,9960) 'dfnabu', line, ((lll,lll=1,10),kkk=1,8) 9960 format (' read error occurred in subroutine ',a & & ,/,' INPUT LINE:',a90 & & ,/,' columns:',80i1,4x,'line # (see list of a502 input)' ) call a502er('dfnabu',' program failure due to ill-formatted data') return ! END subroutine dfnabu ! **deck dfnpea subroutine dfnpea (nwname,nnett & & ,line, kk,isd,ipt1,ipt2) implicit double precision (a-h,o-z) character*10 nwname(nnett) ! ! take a line of input data describing a forced abutment ($abu) ! and crack it to give network # and edge # ! character*90 line character*10 lk ! read nw info as character data, plus ! data as floating point read (line,6001,err=9950) lk,sd,pt1,pt2 6001 format (a,3f10.0) isd = sd ipt1 = pt1 ipt2 = pt2 if ( ipt1.gt.ipt2 ) then ipt1 = pt2 ipt2 = pt1 endif ! attempt a match of the network name kk = 0 if ( lk .eq. ' ' ) goto 101 call ljbf10 (lk) do 100 k = 1,nnett if ( nwname(k).ne.lk ) goto 100 kk = k goto 110 100 continue 101 continue read (line,6002,err=9950) akk 6002 format (f10.0) kk = akk 110 continue ! write out input and interpretted data return write (6,6004) line, kk,isd,ipt1,ipt2 6004 format (' $pea:',a,' nw.e',i4,1h.,i1,' start pt',i3 & & ,' end pt',i3) ! ! ! return ! ! read error handling ! 9950 continue write (6,9960) 'dfnpea', line, ((lll,lll=1,10),kkk=1,8) 9960 format (' read error occurred in subroutine ',a & & ,/,' INPUT LINE:',a90 & & ,/,' columns:',80i1,4x,'line # (see list of a502 input)' ) call a502er('dfnpea',' program failure due to ill-formatted data') return ! END subroutine dfnpea ! **deck difmat subroutine difmat (label,m,n,a,b) implicit double precision (a-h,o-z) dimension a(m,n), b(m,n) character*(*) label !call skrch1 common /skrch1/ w(9000000) !end skrch1 call setcor ('difmat') write (6,'('' difmat:'',2i5,a)') m,n,label call getcor ('c',llc,m*n) call igtcor ('ia',llia,m*n) call difmtx (label,m,n,a,b,w(llc),w(llia)) call frecor ('difmat') return END subroutine difmat ! **deck difmtx subroutine difmtx (label,m,n,a,b,c,ia) implicit double precision (a-h,o-z) dimension a(m*n), b(m*n), c(m*n), ia(m*n) character*(*) label character*100 line character*20 chx ! 12345678901234567890' chx = '**==++--,,.. ' ! call dcopy (m*n, b,1, c,1) call daxpy (m*n, -1.d0, a,1, c,1) mn = m*n do 100 ij = 1,mn c(ij) = abs(c(ij)) 100 continue ! generate matrix printout write (6,'('' difmtx:'',2i5,a)') m,n,label 6000 format (' comparisons for ',a,' columns:',2i5 & & ,/,5x,100i1 ) 6001 format (1x,i4,a) do 200 j1 = 1,n,100 j2 = min(j1+99,n) write (6,6000) label,j1,j2, ((kk,kk=1,10),ll=1,10) do 180 i = 1,m do 110 j = j1,j2 k = j-j1+1 line(k:k) = ' ' ij = i + (j-1)*m ind = -log10( max( abs(c(ij)), 1.d-20 ) ) ind = max(1,min(20,ind)) line(k:k) = chx(ind:ind) 110 continue write (6,6001) i, line(1:k) 180 continue 200 continue call dshell (mn,c,ia) ! print 100 worst entries ijmin = max(1,mn-100) do 300 ijx = ijmin,mn ij = ia(ijx) j = (ij+m-1)/m i = ij - m*(j-1) write (6,6002) i,j,c(ijx) 300 continue 6002 format (' 100 largest entries: ',2i6,e12.4) return END subroutine difmtx ! **deck difmvc subroutine difmvc (m,n, a,b,d) implicit double precision (a-h,o-z) dimension a(3,m,n), b(3,m,n), d(m,n) dimension c(3) ! ! compute the angular difference of a bunch of vectors ! do 200 j = 1,n do 100 i = 1,m call cross (a(1,i,j),b(1,i,j),c) aa = ddot(3, a(1,i,j),1, a(1,i,j),1) bb = ddot(3, b(1,i,j),1, b(1,i,j),1) absq= ddot(3, c,1, c,1) aa = max( 1.d-10, aa) bb = max( 1.d-10, bb) xsin = sqrt( absq/( aa*bb ) ) d(i,j) = asin(xsin) 100 continue 200 continue return END subroutine difmvc ! **deck dinflu subroutine dinflu (zc,iflu,iflumx) implicit double precision (a-h,o-z) dimension zc(3) !! integer iflu(2,2), iflumx ! Removed by Martin Hegedus, 4/21/09 integer iflu(4), iflumx ! Added by Martin Hegedus, 4/21/09 ! ! compute the distance from a polygonal panel"s projection ! onto a plane (qc,en), to a point p-s domain of dependance. ! both projection and distance measurement are done in x(bar) ! ! complex*16 zed dimension rx(3) logical influ, mplane logical within integer ifluai ! Added by Martin Hegedus, 4/21/09 !call epsff common /epsff/ eps1, eps2, eps3, eps4, eps5 & & , phc1, phc2, phc3 !end epsff common /ulibcb/ r(3,16), xi(16), et(16) & & , rc(3), tg(3), p(3), en(3) & & , rm(3), rp(3), udum(2) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs dimension fncmpd(3,3), ftcmpd(3,3) equivalence (ggcp,ftcmpd), (ggcpit,fncmpd) !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf dimension qc(3) dimension rq(3,16), enc(3) equivalence (cpfz,qc), (icsf,ics), (n,nsff), (rq,rqff), (enc,encf) !ca freqdt ! /freqdt/ common /freqdt/ omgbar, omegb, omg, omgabs !---- complex*16 omgbar, omegb, omg !end freqdt !call symm common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym !end symm data rthaf/ .70710678118655d0 / data dph1 / .174d0 /, dph2 / .572d0 /, dph4 / 1.1d0 / ! data ncall/0/ 1 ncall = ncall + 1 qrdb = .5d0*diamf iflumx = 0 ! make fast influence tests for superso !! iflu(1,1) = 0 ! Removed by Martin Hegedus, 4/21/09 !! iflu(1,2) = 0 ! Removed by Martin Hegedus, 4/21/09 !! iflu(2,1) = 0 ! Removed by Martin Hegedus, 4/21/09 !! iflu(2,2) = 0 ! Removed by Martin Hegedus, 4/21/09 iflu(1) = 0 ! Added by Martin Hegedus, 4/21/09 iflu(2) = 0 ! Added by Martin Hegedus, 4/21/09 iflu(3) = 0 ! Added by Martin Hegedus, 4/21/09 iflu(4) = 0 ! Added by Martin Hegedus, 4/21/09 if ( sbetam .gt. 0.d0 ) go to 5 tg(1) = zc(1)-pwf(1) tg(2) = zc(2)-pwf(2) tg(3) = zc(3)-pwf(3) tgx = tg(1)*compd(1)+tg(2)*compd(2)+tg(3)*compd(3) !--- call compip (tg,tg,compd,betams,rsqh) !--- rsqcrt = 1.d-2*diamf*diamf !--- tgxcrt = 1.d-2*diamf !--- write (6,6302) tgx,tgxcrt, rsqh,rsqcrt 6302 format (' tgx,rsqh:',2e12.4,5x,2e12.4) if ( pxf .gt. tgx + diamf*1.d-2 ) go to 2100 call compip (tg,tg,compd,betams,tgx) !--- tgxx = tgx + 1.d-2*diamf*diamf if ( ( tgx + 1.d-2*diamf*diamf ) .lt. 0.d0 ) go to 2100 ! 5 continue qrdb2 = qrdb**2 mplane = rfmin*sbetam .gt. 0.d0 ! set up looping over planes of symmetr ! do 2000 jj = 1,njsym sgnj = 3-2*jj ! do 2000 ii = 1,nisym sgni = 3-2*ii ! p(1) = zc(1) p(2) = sgni*zc(2) p(3) = sgnj*zc(3) if ( sbetam .lt. 0.d0 ) go to 10 ! subsonic tests influ = .true. tg(1) = qc(1) - p(1) tg(2) = qc(2) - p(2) tg(3) = qc(3) - p(3) rc(1) = af(1)*tg(1) + af(4)*tg(2) + af(7)*tg(3) rc(2) = af(2)*tg(1) + af(5)*tg(2) + af(8)*tg(3) rc(3) = af(3)*tg(1) + af(6)*tg(2) + af(9)*tg(3) rcxysq = rc(1)**2 + rc(2)**2 dqcb = sqrt( rcxysq + rc(3)**2 ) dmin = max( 0.d0, abs(rc(3)) - qdltf ) if ( rcxysq .gt. qrdb2 ) & & dmin = sqrt( dmin**2 + ( sqrt(rcxysq)-qrdb )**2 ) go to 1000 ! ! supersonic tests 10 continue ! compute the distance from the mean ! plane panel center to the boundary ! of the cone, in x(bar). tg(1) = qc(1) - p(1) tg(2) = qc(2) - p(2) tg(3) = qc(3) - p(3) rc(1) = ftcmpd(1,1)*tg(1)+ftcmpd(1,2)*tg(2)+ftcmpd(1,3)*tg(3) rc(2) = ftcmpd(2,1)*tg(1)+ftcmpd(2,2)*tg(2)+ftcmpd(2,3)*tg(3) rc(3) = ftcmpd(3,1)*tg(1)+ftcmpd(3,2)*tg(2)+ftcmpd(3,3)*tg(3) rcyzsq = rc(2)**2 + rc(3)**2 xcsq = rc(1)**2 rcsq = xcsq + rcyzsq hcsq = xcsq - rcyzsq influ = rc(1).lt.0.d0 .and. xcsq.gt.rcyzsq if ( rc(1).gt.0.d0 .and. xcsq.gt.rcyzsq ) go to 20 ! near pt to qc is on cone surface dqcb = abs( rc(1) + sqrt(rcyzsq) ) * rthaf dsq = dqcb**2 go to 30 ! near point to qc is at cone apex 20 continue dsq = rcsq dqcb = sqrt ( dsq ) ! 30 continue if ( dsq .le. qrdb2 ) go to 100 ! panel cannot intersect the boundary ! of the mach cone.-- the center point ! distance dqcb exceeds the radius ! qrdb. dmin = dqcb - qrdb ifluij = 0 if ( .not. influ ) go to 1200 if ( dqcb .gt. eps3*diamf ) go to 1000 ! perform detailed influence test 100 continue dmin = dqcb hsqmin = hcsq ! isx = 0 k = 0 do 300 is = 1,n if ( is .eq. ics ) go to 300 isx = isx + 1 r(1,is) = rq(1,is) + rc(1) r(2,is) = rq(2,is) + rc(2) r(3,is) = rq(3,is) + rc(3) xx = r(1,is) yy = r(2,is) zz = r(3,is) ryzsq = yy*yy + zz*zz hsq = xx*xx - ryzsq rsq = xx*xx + ryzsq if ( xx.gt.0.d0 .or. hsq.lt.0.d0 ) go to 260 ! corner inside d(p) if ( .not. influ ) go to 250 k = k + 1 hsqmin = min ( hsq, hsqmin) dmin = min ( dmin, abs( xx + sqrt(ryzsq) ) *rthaf ) if ( k .eq. isx ) go to 300 ! either the center is outside, or ! isx .ne. k . set dmin = 0 and exit 250 continue dmin = 0.d0 ! *** influ = .true. *** go to 900 ! ! corner point outside d(p) 260 continue if ( influ ) go to 270 if ( hsq.gt.0.d0 ) dmin = min( dmin, sqrt(rsq) ) if ( hsq.le.0.d0 ) dmin = min( dmin, & & abs( xx+sqrt(ryzsq) ) * rthaf ) if ( k .eq. 0 ) go to 300 ! either the center was inside or k.ne. ! set dmin = 0 , and exit 270 continue dmin = 0.d0 ! *** influ = .true. *** go to 900 ! 300 continue ! if all corners inside, we are done influ = influ .or. k.ne.0 if ( influ ) go to 900 ! qc and all corners lie outside d(p). ! if mean plane is superinclined, check ! the near point (or the piercing point ! as appropriate) lies on the mean plan ! if the mean plane is not superincline ! go immediately to the checking of ! the supersonic edges. hsqmin = 0.d0 if ( enc(1)**2 .le. enc(2)**2+enc(3)**2 ) go to 400 ! xn = enc(1)*rc(1) + enc(2)*rc(2) + enc(3)*rc(3) if ( xn*enc(1) .gt. 0.d0 ) go to 340 ! panel is upstream of the control pt. ! check for piercing ichk = 1 rx(1) = xn/enc(1) rx(2) = 0.d0 rx(3) = 0.d0 go to 350 340 continue ! panel is downstream of p-s domain of ! dependance. compute minimum distance ! pt from apex to panel plane and see ! if it lies in the panel. ichk = 2 rx(1) = xn*enc(1) rx(2) = xn*enc(2) rx(3) = xn*enc(3) ! determine if rx(*) is in the avg pane 350 continue do 360 is = 1,n xi(is) = 1.d0 et(is) = 0.d0 if ( is.eq.ics ) go to 360 isp1 = mod(is,n)+1 if ( isp1.eq.ics ) isp1 = mod(isp1,n)+1 rp(1) = r(1,isp1) - rx(1) rp(2) = r(2,isp1) - rx(2) rp(3) = r(3,isp1) - rx(3) rm(1) = r(1,is ) - rx(1) rm(2) = r(2,is ) - rx(2) rm(3) = r(3,is ) - rx(3) xi(is) = rm(1)*rp(1) + rm(2)*rp(2) + rm(3)*rp(3) et(is) = det( enc,rm,rp ) 360 continue ! call zwindg (n,xi,et,zed,ized,ierr) if ( ierr.eq.0 ) go to 370 ! error found. rx is probably on the ! boundary. if(ncall.lt.10) call errmsg(' zwindg eror in dinflu') go to 400 ! 370 continue if ( ized.eq.0 ) go to 400 ! rx lies in the panel if ( ichk .eq. 1 ) dmin = 0.d0 ! *** if ( ichk .eq. 1 ) influ = .true. *** if ( ichk.eq.2 ) dmin = min ( dmin, abs(xn) ) go to 900 ! check supersonic edges 400 continue do 500 is = 1,n if ( is.eq.ics ) go to 500 isp1 = mod(is,n)+1 if ( isp1.eq.ics ) isp1 = mod(isp1,n)+1 tg(1) = r(1,isp1) - r(1,is) tg(2) = r(2,isp1) - r(2,is) tg(3) = r(3,isp1) - r(3,is) tgyzsq = tg(2)**2 + tg(3)**2 tgsq = tg(1)**2 - tgyzsq if ( tgsq.ge.0.d0 ) go to 500 ! supersonic edge, plug ahead. qct = abs( r(2,is)*tg(3) - r(3,is)*tg(2) ) drsq = tg(1)**2 + tgyzsq cxtqxt = r(1,is)*tgyzsq - tg(1)*( tg(2)*r(2,is) & & +tg(3)*r(3,is) ) tgnm = sqrt( abs(tgsq) ) if ( cxtqxt*tgnm .gt. qct*drsq ) go to 450 ! tau = -tg(1)*qct taumin = tgnm*( tg(2)*r(2,is )+tg(3)*r(3,is ) ) taumax = tgnm*( tg(2)*r(2,isp1)+tg(3)*r(3,isp1) ) if ( tau.le.taumin .or. tau.ge.taumax ) go to 500 dmin = min ( dmin, & & rthaf*(cxtqxt+tgnm*qct)/tgyzsq ) if ( dmin.gt.0.d0 ) go to 500 dmin = 0.d0 ! *** influ = .true. *** go to 900 ! 450 continue taumin = r(1,is )*tg(1)+r(2,is )*tg(2)+r(3,is )*tg(3) taumax = r(1,isp1)*tg(1)+r(2,isp1)*tg(2)+r(3,isp1)*tg(3) if ( taumin.gt.0.d0 .or. taumax.lt.0.d0 ) go to 500 call cross ( r(1,is), tg, rx) dist = sqrt((rx(1)**2 + rx(2)**2 + rx(3)**2)/ & & drsq) dmin = min (dmin,dist) 500 continue ! supersonic collection point 900 continue if ( mplane ) dmin = max( 0.d0, dmin - qdltf ) if ( dmin .le. 0.d0 ) influ = .true. ifluij = 0 if ( .not.influ ) go to 1200 ! define iflu(ii,jj) 1000 continue ifluij = 6 if ( dmin .gt. eps5 * diamf ) ifluij = 5 if ( dmin .gt. eps4 * diamf ) ifluij = 4 if ( dqcb .gt. eps3 * diamf ) ifluij = 3 if ( dqcb .gt. eps2 * diamf ) ifluij = 2 if ( dqcb .gt. eps1 * diamf ) ifluij = 1 ! adjust value of ifluij to reflect wav ! length restrictions, when ifluij # 0 dphase = omgabs*diamf if ( dphase.lt.phc1 ) goto 1200 ifluij = max0( ifluij, 2) if ( dphase.lt.phc2 ) goto 1200 ifluij = max0( ifluij, 3) if ( dphase.lt.phc3 ) goto 1200 ifluij = max0( ifluij, 4) ! 1200 continue !! iflu(ii,jj) = ifluij ! Removed by Martin Hegedus, 4/21/09 ifluai = (jj-1)*nisym + ii ! Added by Martin Hegedus, 4/21/09 iflu(ifluai) = ifluij ! Added by Martin Hegedus, 4/21/09 iflumx = max ( iflumx, ifluij ) !--- write (6,6202) ii,jj,ifluij,dmin,dqcb,influ 6202 format (' x-- symm:',3i4,' dmin,dqcb,influ:',2e12.4,2x,l3) 2000 continue ! 2100 continue return END subroutine dinflu ! **deck disct1 subroutine disct1 (m,n ,a,na ,ind ,b,nb) implicit double precision (a-h,o-z) dimension a(na,n), b(nb,n) dimension ind(m) ! ! a matrix scatter routine that ought to be implemented in cal ! do 100 j = 1,n do 50 i = 1,m b(ind(i),j) = a(i,j) 50 continue 100 continue ! return END subroutine disct1 ! **deck disct2 subroutine disct2 (m,n ,a,na ,ind ,b,nb) implicit double precision (a-h,o-z) dimension a(na,n), b(nb,n) dimension ind(m) ! ! a matrix scatter routine that ought to be implemented in cal ! do 100 j = 1,n do 50 i = 1,m b(ind(i),j) = b(ind(i),j) + a(i,j) 50 continue 100 continue ! return END subroutine disct2 ! **deck distnc subroutine distnc(x,y,d) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * calculate eudlidean distance between two points in 3 - space * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * calculate magnitude of vector difference of two points * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * d argument output distance between points * ! * * ! * x argument input first point * ! * * ! * y argument input second point * ! * * ! * z -local- - - - - vector difference of x and y * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension x(3),y(3),z(3) call vadd(x,-1.d0,y,z,3) call mag(z,d) return END subroutine distnc ! **deck djsct1 subroutine djsct1 (m,n ,a,na ,ind ,b,nb) implicit double precision (a-h,o-z) dimension a(na,n), b(nb,n) dimension ind(n) ! ! a matrix scatter routine that ought to be implemented in cal ! do 100 j = 1,n do 50 i = 1,m b(i,ind(j)) = a(i,j) 50 continue 100 continue ! return END subroutine djsct1 ! **deck djsct2 subroutine djsct2 (m,n ,a,na ,ind ,b,nb) implicit double precision (a-h,o-z) dimension a(na,n), b(nb,n) dimension ind(n) ! ! a matrix scatter routine that ought to be implemented in cal ! do 100 j = 1,n do 50 i = 1,m b(i,ind(j)) = b(i,ind(j)) + a(i,j) 50 continue 100 continue ! return END subroutine djsct2 ! **deck dlocfx subroutine dlocfx (nw) ! ! dlocfx is a hook to modify an expression nw calculated as ! the difference of two loc functions. on the cray it is ! a no-op, on a sparc (or similar machine) it is a divide by 4. ! !call locinf /locinf/ common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i double precision rlocdm !end locinf ! if ( mod(nw,kkloci).ne.0 ) then write (6,'(1x,'' dlocfx error. nw, kloci = '',2i6)') nw,kkloci CALL AbortPanair('dlocfx') endif nw = nw/kkloci return END subroutine dlocfx ! **deck dnchek subroutine dnchek (knet,m,n,z,q,header) implicit double precision (a-h,o-z) dimension z(3,m,n), q(3,m,n) dimension enz(3), enq(3) logical header ! for a given network (id = knet) having m rows and n column ! of mesh points, compare the mean plane panel normals before ( ! and after ( q ) adjustment, reporting any discrepancies of mo ! than 5 degrees. !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons mpan = m - 1 npan = n - 1 do 100 j = 1,npan do 100 i = 1,mpan call mpnorm ( z(1,i,j), z(1,i,j+1), z(1,i+1,j+1), z(1,i+1,j) & & , enz ) call mpnorm ( q(1,i,j), q(1,i,j+1), q(1,i+1,j+1), q(1,i+1,j) & & , enq ) call vip ( enz,1, enq,1, 3, cosalf) if ( cosalf .gt. .9999999848d0 ) go to 100 sinalf = sqrt( max( 0.d0, 1.d0-cosalf**2 ) ) alf = atan2( sinalf, cosalf) if ( .not. header ) call bmark ('pnrmlmov') if ( .not. header ) write (6,9001) header = .true. alfdeg = alf*180.d0/pi write (6,9002) knet,i,j,alfdeg if ( cosalf .gt. .996195d0 ) go to 100 write (6,9003) call abtmsg ('*** normal change exceeds 5 degrees') 100 continue return 9001 format (1h1,10x,'****** movement of panel normals ******' & & ,/, 11x,'threshold value for message = .01 degrees' & & ,//, ' nw row col normal change (deg.)' ) 9002 format (1x,i4,i5,i5,8x,f12.6) 9003 format (60x,'*** warning *** normal change exceeds 5 degrees') END subroutine dnchek ! **deck domvec subroutine domvec (a,v) implicit double precision (a-h,o-z) dimension a(3,3), v(3), x(3), y(3) kk = 1 if ( a(2,2) .gt. a(kk,kk) ) kk = 2 if ( a(3,3) .gt. a(kk,kk) ) kk = 3 x(1) = 0.d0 x(2) = 0.d0 x(3) = 0.d0 x(kk) = 1.d0 do 20 l = 1,20 call mxma (a,1,3, x,1,3, y,1,3, 3,3,1) call uvect (y) call xfera (y,x,3) 20 continue call xfera (x,v,3) return END subroutine domvec ! **deck dpdqfv subroutine dpdqfv implicit double precision (a-h,o-z) ! dumper of panel data required in offbd/stmlne !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call pandfv common /pandfv/ dvz(9,4), amuxz(3,4), sv1(3,4), dv1(6,4) & & , sv2(3,2,4), dv2(10,2,4) & & , sv8(3,8,4), dv8( 6,8,4) & & , usv(6,4), uvmv(4,6,4), amsv(3,3,4), amdv(3,3,4) & & , lpandv !end pandfv ! ! ! call outmat ('cp',3,3,9,cp) call outmat ('ar',9,9,5,ar) call outmat ('ari',3,3,3,ari) call outmat ('en',3,3,5,en) call outmat ('aj',1,1,5,aj) call outmat ('sgx',1,1,5,sgx) call outmat ('pk',3,3,6,pk) call outmat ('pp',9,9,8,pp) call outmat ('cpfz',1,1,3,cpfz) call outmat ('cpf',3,3,4,cpf) call outmat ('af',3,3,3,af) call outmat ('aft',3,3,3,aft) call outmat ('rqff',3,3,4,rqff) call outmat ('pf',3,3,4,pf) call outvci ('its...',10,its) call outvec ('sf...',4,sf) call outvec ('pwf',5,pwf) call outvec ('encf',3,encf) write (6,'(1x,a10,1x, 3i12)') & & 'itsf,icsf',itsf,icsf,nsff return END subroutine dpdqfv ! **deck dscal subroutine dscal (n, a, y,iy) implicit double precision (a-h,o-z) dimension y(1) ! ! standard blas sscal ! if ( n.le.0 ) return ly = 1 if ( iy.le.0 ) ly = ly + iabs(iy)*(n-1) do 100 k = 1,n y(ly) = a*y(ly) ly = ly + iy 100 continue return END subroutine dscal ! **deck dshell subroutine dshell (n,a,key) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * fshell sorts an integer array a(n) using the shell sort * ! * algorithm.(cf. july 1958, cacm, an article by donald m. * ! * shell). * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * fshell uses the shell sort algorithm developed by donald m. * ! * shell and published in the july 1958 cacm. in the process * ! * of sorting the array a , the program keeps track of the * ! * original position of a*s array elements by rearranging the * ! * array key (initialization - key(i)=i ) so that it always * ! * corresponds with a. the array key can then be used to * ! * bring other arrays into correspondence with a if they were * ! * originally in correspondence. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * a argument in/out array to be sorted * ! * * ! * ia local - - - - address of first element to * ! * be compared * ! * * ! * iap local - - - - address of second element to * ! * be compared * ! * * ! * jmax local - - - - number of compares to be made * ! * for a given increment m * ! * * ! * key argument output array of original addresses * ! * for the sorted a array * ! * * ! * m local - - - - the increment used at any * ! * given stage of the sort * ! * * ! * n local - - - - the dimension of the a and key* ! * arrays * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! integer key(n) dimension a(n) !c * * ! * initialize the array key containing original addresses * ! * * if ( n.le.0 ) return do 10 i = 1,n 10 key(i) = i !c * * ! * initialize the increment of the sort process, m * ! * * m = n !c * * ! * statement 100 marks the starting point of a sort stage * ! * * 100 continue !c * * ! * update the increment m , and test for completion * ! * * m = m/2 if ( m.le.0 ) return !c * * ! * the following loop ranges over all pairs of elements in a * ! * for which the addresses differ by exactly m * ! * * jmax = n - m do 200 j = 1,jmax ia = j iap = ia + m !c * * ! * check that elements a(ia) and a(iap) are in proper order. if* ! * not, interchange them, bring key into correspondence and * ! * ensure that elements a(ia) and a(ia-m) are in proper * ! * order * ! * * 150 if ( a(ia) .le. a(iap) ) go to 200 asv = a(ia) a(ia) = a(iap) a(iap) = asv ! ksv = key(ia) key(ia) = key(iap) key(iap)= ksv ! iap = ia ia = ia - m if ( ia.gt.0 ) go to 150 200 continue ! ! * go on to the next value for the increment m * ! go to 100 END subroutine dshell ! **deck dsnc2g subroutine dsnc2g (knet,m,n,z, lc2g,klc2g,cc2g) implicit double precision (a-h,o-z) dimension z(3,m,n) dimension lc2g(m-1,n-1), klc2g(9,m-1,n-1), cc2g(36,m-1,n-1) ! ! construct the dependency of the panel corner point velocities upon ! the panel center velocities. ! !ca lsqsfc ! /lsqsfc/ common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk !end lsqsfc !ca comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs ! dimension eng(3), indx(9), ak1(9), ak4(4,9) dimension zorig(3), zpt(3), zloc(3), fzloc(3) dimension aa(3,3) logical ident, colaps(4) ! ! wt = 1.d4 p5 = .5d0 mfn = 2*m-1 nfn = 2*n-1 mnfn = mfn*nfn ! detect collapsed edges do 100 ksd = 1,4 kn = n if ( ksd.eq.2 .or. ksd.eq.4 ) kn = m ncolps = 0 colaps(ksd) = .false. do 90 kg = 1,kn-1 call edg2gd ( kg,ksd, m,n, i1,j1) call edg2gd (kg+1,ksd, m,n, i2,j2) call pident (z(1,i1,j1), z(1,i2,j2), ident) if ( ident ) ncolps = ncolps + 1 90 continue if ( ncolps.le.0 ) goto 100 colaps(ksd) = .true. if ( ncolps.eq.(kn-1) ) goto 100 write (7,'('' partially collapsed edge detected:'',2i5)') & & knet,ksd write (6,'('' partially collapsed edge detected:'',2i5)') & & knet,ksd 100 continue ! loop over network grid points do 400 l = 1,n-1 do 350 k = 1,m-1 kl = k + (l-1)*(m-1) ! use the mean plane normal call mpnrml (z(1,k,l),m,n, eng) call vip (eng,1, eng,1, 3, engsq) if ( engsq.le. 0.d0 ) then write (6,'('' bad n calc, dsnc2g, k,i,j:'',3i5,4e12.4)') & & knet,i,j,eng,engsq call a502er ('dsnc2g','divide check trapped') endif fac = 1.d0/sqrt(engsq) call dscal (3, fac, eng,1) call en2xfm (eng,aa) ! get origin ifn = 2*k jfn = 2*l call fngrid (m,n,z, ifn,jfn, zorig) ! build spline npk = 0 l1 = max( 1, l-1) l2 = min(n-1, l+1) k1 = max( 1, k-1) k2 = min(m-1, k+1) do 250 lp = l1,l2 do 240 kp = k1,k2 kfn = 2*kp lfn = 2*lp npk = npk + 1 wtk(npk) = 1.d0 if ( k.eq.kp .and. l.eq.lp ) wtk(npk) = wt indx(npk) = kp + (lp-1)*(m-1) call fngrid (m,n,z, kfn,lfn, zpt) call lproj (eng,zorig,zpt,zk(1,npk)) call unipan (aa,zorig,zk(1,npk),zk(1,npk)) if ( k1.ne.k2 ) goto 220 ! k1=k2; put in dummy values npk = npk + 1 wtk(npk) = 1.d0 indx(npk) = indx(npk-1) call fngrid (m,n,z, kfn-1,lfn, zpt) call lproj (eng,zorig,zpt,zk(1,npk)) call unipan (aa,zorig,zk(1,npk),zk(1,npk)) ! npk = npk + 1 wtk(npk) = 1.d0 indx(npk) = indx(npk-1) call fngrid (m,n,z, kfn+1,lfn, zpt) call lproj (eng,zorig,zpt,zk(1,npk)) call unipan (aa,zorig,zk(1,npk),zk(1,npk)) ! 220 continue if ( l1.ne.l2 ) goto 230 ! l1=l2; put in dummy values npk = npk + 1 wtk(npk) = 1.d0 indx(npk) = indx(npk-1) call fngrid (m,n,z, kfn,lfn-1, zpt) call lproj (eng,zorig,zpt,zk(1,npk)) call unipan (aa,zorig,zk(1,npk),zk(1,npk)) ! npk = npk + 1 wtk(npk) = 1.d0 indx(npk) = indx(npk-1) call fngrid (m,n,z, kfn,lfn+1, zpt) call lproj (eng,zorig,zpt,zk(1,npk)) call unipan (aa,zorig,zk(1,npk),zk(1,npk)) ! 230 continue ! 240 continue 250 continue no = 1 if ( npk.gt.9 ) then call a502er ('dsnc2g','indx buffer overflow') endif call lsqsf !---- write (6,'('' dsnc2g: knet,k,l: '',3i6)') knet,k,l !---- call outvci ('indx',npk,indx) !---- call outmat ('ak',6,3,npk,ak) ! evaluate spline at 4 panel corners ijp = 0 do 260 jp = 0,1 do 255 ip = 0,1 ijp = ijp + 1 i = k + ip j = l + jp ifn = 2*i-1 jfn = 2*j-1 call fngrid (m,n,z, ifn,jfn, zpt) call lproj (eng,zorig,zpt,zloc) call unipan (aa,zorig,zloc,zloc) fzloc(1) = 1.d0 fzloc(2) = zloc(1) fzloc(3) = zloc(2) call hsmmp1 (npk,3,1, ak,6,1, fzloc,1,3, ak1,1,npk) call dcopy (npk, ak1,1, ak4(ijp,1),4) 255 continue 260 continue call scmpkt (ak4,indx,4,npk) call dcopy (4*npk, ak4,1, cc2g(1,k,l),1) call icopy (npk, indx,1, klc2g(1,k,l),1) lc2g(k,l) = npk !---- call outvci ('indx',npk,klc2g(1,k,l)) !---- call outmat ('ak4',4,4,npk, cc2g(1,k,l)) ! 350 continue 400 continue ! return END subroutine dsnc2g ! **deck dsncdv subroutine dsncdv (ipv,cpq,s, dpv) implicit double precision (a-h,o-z) dimension cpq(3,4), s(4000) dimension dpv(4) ! ! given a panel index "ipv" compute the jump in the panel center ! potential and velocity using the H-P model of doublet variation ! on the panel. ! ! ipv i i*4 panel index for which panel center v-jumps req'd ! cpq i r*8 coordinates of the panel, design surface ! s i r*8 the singularity vector ! dpv o r*8 the jump in potential and velocity ! bs l r*8 coeff of mu/s in expression for grad/tg (mu) ! bt l r*8 coeff of mu/t in expression for grad/tg (mu) ! phis l r*8 s-derivatives of 9 biquadratic basis fcns ! phit l r*8 t-derivatives of 9 biquadratic basis fcns ! !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq ! dimension phi(9), phis(9), phit(9) dimension ps(3), pt(3), enc(3), enuc(3), ensg(3), bs(3), bt(3) dimension amu(9) dimension ivjds(40), dvjds(3,40), delv(3) ! if ( ipv.ne.ipn ) call strns (ipv,cp) ! compute the 9 canonical mu parms call dcopy (9, 0.d0,0, amu,1) do 100 j = 1,ind lastd = 1 + (j-1)*9 call daxpy (9, s(iid(j)), astd(lastd),1, amu,1) 100 continue ! evaluate [[ phi ]], [[ phi/s ]] ! and [[ phi/t ]] sc = 0.d0 tc = 0.d0 call bqbfun (sc,tc, phi,phis,phit) dph = ddot(9, amu,1, phi,1) dphs = ddot(9, amu,1, phis,1) dpht = ddot(9, amu,1, phit,1) ! do 200 i = 1,3 ps (i) = .25d0*(cpq(i,1) - cpq(i,2) - cpq(i,3) + cpq(i,4) ) pt (i) = .25d0*(cpq(i,1) + cpq(i,2) - cpq(i,3) - cpq(i,4) ) 200 continue ! enc = N = p/s x p/t; ! enuc = N~ /( N, N~) call cross (ps,pt,enc) call dcopy (3, enc,1, enuc,1) call cscal2 (betams,enuc,1) call vip (enc,1, enuc,1, 3, enenuc) call vmul (enuc, 1.d0/enenuc, enuc,3) call cross (pt,enuc,bs) call cross (enuc,ps,bt) ! ensg = N ( |N| / (N,N~) ) ! = n / (n,n~) enabs = sqrt( ddot( 3, enc,1, enc,1) ) call vmul (enc, enabs/enenuc, ensg, 3) sgctr = 0.d0 do 250 j = 1,ins sgctr = sgctr + asts(3*j-2)*s(iis(j)) 250 continue ! add the two dependencies upon 9 mu's ! [[ v ]] = bs*[[phi/s]] + bt*[[phi/t]] ! + sigma * [ n / (n,n~) ] dpv(1) = dph do 300 i = 1,3 dpv(i+1) = bs(i)*dphs + bt(i)*dpht + ensg(i)*sgctr 300 continue ! DEBUG: call dsncvj and get it right !-- call dsncvj (ipv,cpq, nvjds,ivjds,dvjds) !-- call dcopy (3, 0.d0,0, delv,1) !-- do 400 j = 1,nvjds !-- call daxpy (3, s(ivjds(j)), dvjds(1,j),1, delv,1) !-- 400 continue !-- sga = ddot(3, enuc,1, delv,1) !-- sgb = ddot(3, enuc,1, dpv(2),1) !-- write (6,'('' DSNCDV: ipv '',i5,3f12.6,3x,3f12.6,3x,2f12.6)') !-- x ipv,(dpv(i),i=2,4),delv,sga,sgb !-- call dcopy (3, delv,1, dpv(2),1) ! return END subroutine dsncdv ! **deck dsnpdt subroutine dsnpdt (mfn,nfn,vfg,ip,ipan,jpan) implicit double precision (a-h,o-z) dimension vfg(3,mfn,nfn,2) ! ! generate sensitivity panel data for a single panel ! !ca comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !ca acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !ca symm common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym !end symm !ca pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !ca pandsn ! /pandsn/ ! pandsn: panel data for the design common /pandsn/ wpdn(3,9), wsdn(3,3,8) & & , wcdn(18,12), wcsdn(18,12,8) & & , acdn( 3,12), acsdn( 3,12,8) & & , iiptdn(4), iipgdn(4), iidumm(8) !end pandsn dimension vd(3,9), vdm(3,3,3) dimension inca(9), jnca(9), isx(3), qd(3,9) dimension cpx(3) logical ident ! data inca / 0,0,2,2, 0,1,2,1, 1 / data jnca / 0,2,2,0, 1,2,1,0, 1 / ! call dcopy (3*9, 0.d0,0, qd,1) ! do 200 ipt = 1,9 ! (iv,jv) = 3x3 grid indices iv = 1 + inca(ipt) jv = 1 + jnca(ipt) ! (ifn,jfn) = fine grid indices ifn = 2*(ipan-1) + 1 + inca(ipt) jfn = 2*(jpan-1) + 1 + jnca(ipt) call vadd (vfg(1,ifn,jfn,1), -1.d0, vfg(1,ifn,jfn,2) & & ,vd(1,ipt),3) ! force continuity at P-O-S !--- if ( abs(cp(2,ipt)).le. 1.d-7 ) vd(2,ipt) = 0.d0 ! call dcopy (3, cp(1,ipt),1, cpx,1) if ( misym.gt.0 ) then cpx(2) = 0.d0 call pident (cp(1,ipt),cpx,ident) if ( ident ) vd(2,ipt) = 0.d0 endif cpx(2) = cp(2,ipt) if ( mjsym.gt.0 ) then cpx(3) = 0.d0 call pident (cp(1,ipt),cpx,ident) if ( ident ) vd(3,ipt) = 0.d0 endif ! form perturbation mass flux call cmpscl (betams,compd,vd(1,ipt),vd(1,ipt)) ! add in freestream for W/tot call daxpy (3, 1.d0, fsv,1, vd(1,ipt),1) ! copy to debug print array call dcopy (3, vd(1,ipt),1, wpdn(1,ipt),1) call dcopy (3, vd(1,ipt),1, vdm(1,iv,jv),1) 200 continue !---- call outmvc ('vd',3,3,3,vdm) do 250 is = 1,8 if ( is.le.4 ) then isx(1) = is isx(2) = is+4 isx(3) = mod(is+2,4)+5 else isx(1) = 9 isx(2) = mod(is+2,4)+5 isx(3) = is endif ! generate subpanel info do 240 kk = 1,3 call dcopy (3, wpdn(1,isx(kk)),1, wsdn(1,kk,is),1) 240 continue 250 continue ! return END subroutine dsnpdt ! **deck dswap subroutine dswap (n, x,ix, y,iy) implicit double precision (a-h,o-z) dimension x(1), y(1) ! ! standard blas sswap ! if ( n.le.0 ) return lx = 1 ly = 1 if ( ix.le.0 ) lx = lx + iabs(ix)*(n-1) if ( iy.le.0 ) ly = ly + iabs(iy)*(n-1) do 100 k = 1,n xsv = x(lx) x(lx) = y(ly) y(ly) = xsv lx = lx + ix ly = ly + iy 100 continue return END subroutine dswap ! **deck duzint subroutine duzint(cp,cq,pint,iflags, insidf) implicit double precision (a-h,o-z) ! ! purpose: determine whether intersection does occur ! ! inputs: cp,cq coefficients of planes ! pint array of intersection points ! iflags array of flags about intersection ! ! outputs: insidf flag indicating intersection occurs ! dimension ul(3) dimension cp(4), cq(4) dimension pint(3,4,2) dimension iflags(3,2) dimension pline(4), qline(4) logical insidf data tol / 1.0d-6 / ! ! initialize flag ! insidf = .false. ! ipsum = 0 iqsum = 0 do 10 j=1,3 ipsum = ipsum + iflags(j,1) iqsum = iqsum + iflags(j,2) 10 continue ! if( ipsum .eq. 4 .and. iqsum .eq. 4 ) go to 999 if( ipsum .eq. 0 .or. iqsum .eq. 0 ) go to 999 ! ! compute the direction cosines of the unit line ul(1) = cp(2)*cq(3) - cp(3)*cq(2) ul(2) = cp(3)*cq(1) - cp(1)*cq(3) ul(3) = cp(1)*cq(2) - cp(2)*cq(1) temp = sqrt( ul(1)*ul(1) + ul(2)*ul(2) + ul(3)*ul(3) ) ul(1) = ul(1)/temp ul(2) = ul(2)/temp ul(3) = ul(3)/temp ! ! compute magnitude on the unit line, ul jp = 0 jq = 0 do 12 i=1,4 pline(i) = 0.0d0 qline(i) = 0.0d0 12 continue ! do 20 iside=1,3 if( iflags(iside,1) .eq. 0 ) go to 15 jp = jp + 1 do 13 j=1,3 pline(jp) = pline(jp) + ul(j)*pint(j,iside,1) 13 continue ! if( iflags(iside,1) .ne. 2 ) go to 15 jp = jp + 1 do 14 j = 1,3 pline(jp) = pline(jp) + ul(j) * pint(j,4,1) 14 continue ! 15 if( iflags(iside,2) .eq. 0 ) go to 20 jq = jq + 1 do 18 j=1,3 qline(jq) = qline(jq) + ul(j)*pint(j,iside,2) 18 continue ! if( iflags(iside,2) .ne. 2 ) go to 20 jq = jq + 1 do 19 j = 1,3 qline(jq) = qline(jq) + ul(j) * pint(j,4,2) 19 continue ! 20 continue ! plmin = pline(1) plmax = pline(1) do 30 ip=2,jp plmin = min (plmin,pline(ip)) plmax = max (plmax,pline(ip)) 30 continue ! qlmin = qline(1) qlmax = qline(1) do 40 iq=2,jq qlmin = min (qlmin,qline(iq)) qlmax = max (qlmax,qline(iq)) 40 continue ! if( qlmax .le. plmin + tol ) go to 999 if( qlmin .ge. plmax - tol ) go to 999 if( ( ipsum .eq. 4 ) .and. & & ( abs( qlmax - qlmin ) .le. tol ) ) go to 999 if( ( iqsum .eq. 4 ) .and. & & ( abs( plmax - plmin ) .le. tol ) ) go to 999 if( ( abs( plmax - plmin ) .le. tol ) .and. & & ( abs( qlmax - qlmin ) .le. tol ) ) go to 999 ! ! compute the length of the cut and output the result if(( qlmax.ge.plmax ) .and. ( qlmin.ge.plmin )) size=plmax-qlmin if(( plmax.ge.qlmax ) .and. ( plmin.ge.qlmin )) size=qlmax-plmin if(( plmin.ge.qlmin ) .and. ( plmax.le.qlmax )) size=plmax-plmin if(( qlmin.ge.plmin ) .and. ( qlmax.le.plmax )) size=qlmax-qlmin ! write(6,1000) size 1000 format(1x,/,1x,18hnext cut length is,f24.13) ! insidf = .true. ! 999 return END subroutine duzint ! **deck dvcalc subroutine dvcalc (zc,sc,tc, dvsrc,dvdbl) implicit double precision (a-h,o-z) dimension zc(3), dvsrc(3,3), dvdbl(3,9) ! evaluate the velocity jump at the point zc (h-p coordinates ! on the panel are (sc,tc) ) where the doublet gradient is ! calculated using the natural biquadratic distribution on the ! h-p panel. !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call endvcl ! /endvcl/ common /endvcl/ encp(3) !end endvcl dimension ps(3), pt(3), pst(3), enc(3), enuc(3), as(3), at(3) & & , bs(3), bt(3), phi(9), phis(9), phit(9), dvs(3) ! call zero (dvdbl,27) if ( its.le.1 ) go to 500 call bqbfun (sc,tc, phi,phis,phit) do 100 i = 1,3 ps (i) = .25d0*(cp(i,1) - cp(i,2) - cp(i,3) + cp(i,4) ) pt (i) = .25d0*(cp(i,1) + cp(i,2) - cp(i,3) - cp(i,4) ) pst(i) = .25d0*(cp(i,1) - cp(i,2) + cp(i,3) - cp(i,4) ) 100 continue ! call vadd (ps,tc,pst,as,3) call vadd (pt,sc,pst,at,3) call cross (as,at,enc) call dcopy (3, enc,1, enuc,1) call cscal2 (betams,enuc,1) call vip (enc,1, enuc,1, 3, enenuc) call vmul (enuc, 1.d0/enenuc, enuc,3) call cross (at,enuc,bs) call cross (enuc,as,bt) call mxma (bs,1,3, phis,1,1, dvdbl,1,3, 3,1,9) call hsmmp2 (3,1,9, bt,1,3, phit,1,1, dvdbl,1,3) ! now compute jump in velocity due to s 500 continue call zero (dvsrc,9) if ( mod(its,2).eq.0 ) go to 900 call sincs (zc,dvs) call uvect (enc) call dcip (enc,enc,enfac) enfac = 1.d0/enfac call vmul (enc,enfac,enc,3) call mxma (enc,1,3, dvs,1,1, dvsrc,1,3, 3,1,3) 900 continue call xfera (enc,encp,3) call uvect (encp) return END subroutine dvcalc ! **deck dzbchk subroutine dzbchk (k,m,n,eps,z,zsv,header) implicit double precision (a-h,o-z) character motion*8 dimension z(3,4000), zsv(3,4000) dimension w(3,10), wsv(3,10) logical header !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt dimension dz(mxedmp) logical nonzro, toobig ! do 400 ksd = 1,4 nz = n if ( ksd.eq.2 .or. ksd.eq.4 ) nz = m call zero (dz,nz) nonzro = .false. toobig = .false. dzmax = 0.d0 do 200 iz = 1,nz if ( ksd.eq.1 ) lz = 1 + (iz-1)*m if ( ksd.eq.2 ) lz = iz + (n-1)*m if ( ksd.eq.3 ) lz = m*n - (iz-1)*m if ( ksd.eq.4 ) lz = m - (iz-1) call distnc (z(1,lz), zsv(1,lz), dz(iz)) if ( dz(iz) .gt. 1.d-8 ) nonzro = .true. if ( dz(iz) .gt. eps ) toobig = .true. dzmax = max ( dzmax, dz(iz)) 200 continue if ( .not.nonzro .and. .not.toobig ) go to 400 if ( .not. header ) call bmark ('nwedgmov') if ( .not. header ) write (6,9000) header = .true. motion = '.lt. eps' if ( toobig ) motion = 'too big ' if ( toobig ) call abtmsg ('dzbchk: points moved too far ') write (6,9001) k,ksd,motion,eps do 300 iz1 = 1,nz,10 iz2 = min ( nz, iz1+9) do 250 iz = iz1,iz2 if ( ksd.eq.1 ) lz = 1 + (iz-1)*m if ( ksd.eq.2 ) lz = iz + (n-1)*m if ( ksd.eq.3 ) lz = m*n - (iz-1)*m if ( ksd.eq.4 ) lz = m - (iz-1) i = iz - iz1 + 1 call dcopy (3, z(1,lz),1, w(1,i),1) call dcopy (3, zsv(1,lz),1, wsv(1,i),1) 250 continue nw = iz2 - iz1 + 1 if ( iz1.eq.1 ) write (6,9002) dzmax, (dz(i),i=iz1,iz2) if ( iz1.ne.1 ) write (6,9006) (dz(i),i=iz1,iz2) write (6,9003) iz1,'x', (wsv(1,i),i=1,nw) write (6,9004) 'y', (wsv(2,i),i=1,nw) write (6,9004) 'z', (wsv(3,i),i=1,nw) write (6,9005) 'x', (w(1,i),i=1,nw) write (6,9004) 'y', (w(2,i),i=1,nw) write (6,9004) 'z', (w(3,i),i=1,nw) 300 continue 9000 format (1h1,10x,'***** movement of network edge points *****' & & ,/, 2x,'nw.edge motion' & & ,/, 2x,'dz(max) dz(i)') 9001 format (//,1x,i3,1h.,i1,5x,' ** ',a8,' ** ', & & ' tolerance = ',e12.4) 9002 format (1x,e10.2,10f12.6) 9003 format (1x,i3,1x,'orig',1x,a1,10f12.6) 9004 format (10x, a1,10f12.6) 9005 format (4x,'moved',1x,a1,10f12.6) 9006 format (1h0,10x,10f12.6) 400 continue return END subroutine dzbchk ! **deck e11fmt subroutine e11fmt (n,z,az) implicit double precision (a-h,o-z) dimension z(n) character*11 az(n), e11 character*12 e12 ! ! generate an e11.5 type format for the data vector z(1:n) ! ! n i int the number of data items to converted to str ! z i int z(1:n) = the set of data items to be convert ! az o ch*11 array of character strings containing the ! formatted floating point data ! ! michael epton, 30 november 1988 ! do 100 i = 1,n zi = z(i) if ( zi.eq.0.d0 ) goto 20 ! azi = max( 1.0001d-9, min( 9.9998d9, abs(zi) )) sgn = sign(1.d0,zi) zi = sgn*azi ! 20 continue write (e12,'(1p,e12.5)' ) zi e11( 1:10) = e12( 1:10) e11(11:11) = e12(12:12) az(i) = e11 100 continue return END subroutine e11fmt ! **deck edg2fg subroutine edg2fg (ifg,kedg, nm,nn,zm,nza, zz) implicit double precision (a-h,o-z) dimension nm(150), nn(150), nza(151), zm(3,6000), zz(3) ! ! given the fine grid index along an edge, compute the geometric ! position of that point ! call mnmod (kedg,4,ksd,knet) m = 2*nm(knet) - 1 n = 2*nn(knet) - 1 ! get the fine grid row/col indices goto (100,200,300,400) ksd 100 continue i = 1 j1 = (ifg+1)/2 j2 = (ifg+2)/2 ij1 = i + (j1-1)*nm(knet) ij2 = i + (j2-1)*nm(knet) goto 500 200 continue i1 = (ifg+1)/2 i2 = (ifg+2)/2 j = nn(knet) ij1 = i1 + (j-1)*nm(knet) ij2 = i2 + (j-1)*nm(knet) goto 500 300 continue i = nm(knet) ifgx = n+1-ifg j1 = (ifgx+1)/2 j2 = (ifgx+2)/2 ij1 = i + (j1-1)*nm(knet) ij2 = i + (j2-1)*nm(knet) goto 500 400 continue ifgx = m+1-ifg i1 = (ifgx+1)/2 i2 = (ifgx+2)/2 j = 1 ij1 = i1 ij2 = i2 goto 500 ! 500 continue l1 = ij1 + nza(knet) l2 = ij2 + nza(knet) call avg2pt (zm(1,l1),zm(1,l2),zz) return END subroutine edg2fg ! **deck edg2gd subroutine edg2gd (kpt,ksd, m,n, i,j) implicit double precision (a-h,o-z) ! ! compute the (i,j) indices of a point on an (m,n) grid given that ! the point is point number kpt on edge ksd ! if ( ksd.lt.1 .or. ksd.gt.4 ) then CALL AbortPanair('edg2gd-1') endif ! goto (100,200,300,400) ksd 100 continue i = 1 j = kpt np = n goto 500 200 continue i = kpt j = n np = m goto 500 300 continue i = m j = n+1 - kpt np = n goto 500 400 continue i = m+1-kpt j = 1 np = m goto 500 500 continue if ( kpt.lt.1 .or. kpt.gt.np ) then CALL AbortPanair('edg2gd-2') endif return END subroutine edg2gd ! **deck edg2nw subroutine edg2nw (kpt,ksd, m,n, ij) implicit double precision (a-h,o-z) ! ! compute the ij index of a point on an (m,n) grid given that ! the point is point number kpt on edge ksd ! if ( ksd.lt.1 .or. ksd.gt.4 ) then CALL AbortPanair('edg2nw-1') endif ! goto (100,200,300,400) ksd 100 continue i = 1 j = kpt np = n goto 500 200 continue i = kpt j = n np = m goto 500 300 continue i = m j = n+1 - kpt np = n goto 500 400 continue i = m+1-kpt j = 1 np = m goto 500 500 continue ij = i + (j-1)*m if ( kpt.lt.1 .or. kpt.gt.np ) then CALL AbortPanair('edg2nw-2') endif return END subroutine edg2nw ! **deck edgabt subroutine edgabt(l,jsd,jz1,jz2,k,isd,iz1,iz2,z,nok,nch) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits logical ident !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts dimension z(3,1) data fact /2.d0/ izr(i)=iz1+isin*(i-1) nok=0 nch=0 ni=iabs(iz2-iz1)+1 nj=jz2-jz1+1 if(nj.lt.ni) go to 900 if((ni.eq.1).and.(nj.gt.1)) go to 900 nzak=nza(k) call mshind(isd,iz1,1,nm(k),nn(k),kp1) kp1=nzak+kp1 j=1 call dcopy (3,zm(1,kp1),1,z(1,j),1) nzal=nza(l) isin=1 if(iz2.lt.iz1) isin=-1 if(ni.eq.1) go to 600 jzs=jz1 kps=kp1 do 500 i=2,ni jzi=jzs+1 if(jzi.gt.jz2) go to 900 iz=izr(i) call mshind(isd,iz,1,nm(k),nn(k),kp) kp=nzak+kp call distnc(zm(1,kp),zm(1,kps),dk) call cpetp(l,jsd,jzi,jz2,zm(1,kp),jzf) call mshind(jsd,jzs,1,nm(l),nn(l),lps) lps=nzal+lps dl=0.d0 do 300 jz=jzi,jzf call mshind(jsd,jz,1,nm(l),nn(l),lp) lp=nzal+lp call distnc(zm(1,lps),zm(1,lp),d) dl=dl+d 300 lps=lp if(dl.gt.fact*dk) go to 900 ds=dl call mshind(jsd,jzs,1,nm(l),nn(l),lps) lps=nzal+lps dl=0.d0 do 400 jz=jzi,jzf call mshind(jsd,jz,1,nm(l),nn(l),lp) lp=nzal+lp call distnc(zm(1,lps),zm(1,lp),d) dl=dl+d t=dl/ds j=j+1 z(1,j)=t*zm(1,kp)+(1.d0-t)*zm(1,kps) z(2,j)=t*zm(2,kp)+(1.d0-t)*zm(2,kps) z(3,j)=t*zm(3,kp)+(1.d0-t)*zm(3,kps) 400 lps=lp jzs=jzf 500 kps=kp 600 nok=isin do 700 jz=jz1,jz2 j=jz-jz1+1 call mshind(jsd,jz,1,nm(l),nn(l),lp) lp=nzal+lp call pident(z(1,j),zm(1,lp),ident) if(.not.ident) go to 900 700 continue nch=1 900 return END subroutine edgabt ! **deck edgfgi subroutine edgfgi (iul,kedg,ijfg, nm,nn,nefgsa, kkmp) implicit double precision (a-h,o-z) dimension nm(1:*), nn(1:*), nefgsa(1:*) ! ! given an edge fine grid point specified by (iul,kedg,ijfg), ! generate the global edge-fine-grid-index kkmp. Note that ! the upper and lower surface points are distinguished. ! ! iul in int upper/lower index, 1=u, 2=l ! kedg in int global edge index = ksd + 4*(knet-1) ! ijfg in int fine grid index along edge kedg ! nm in int counts of row meshpoints, all nw's ! nn in int counts of col meshpoints, all nw's ! nefgsa in int cum count of fine grid edge mesh points, upper ! and lower surfaces distinguished. ! kkmp out int global fine grid edge mesh point, upper and ! lower surface distinguished. ! ijx = ijfg knet = (kedg+3)/4 ksd = kedg - 4*(knet-1) np = nn(knet) if ( ksd.eq.2 .or. ksd.eq.4 ) np = nm(knet) ! if point is the last point on side ! ksd, consider it as the first point ! on the next edge. npfg = 2*np - 1 if ( ijx.eq.npfg ) then ijx = 1 ksd = mod(ksd,4) + 1 endif np = nn(knet) if ( ksd.eq.2 .or. ksd.eq.4 ) np = nm(knet) kedgx = ksd + 4*(knet-1) kkmp = nefgsa(kedgx) + (iul-1)*(2*np-2) + ijx ! return END subroutine edgfgi ! **deck edgind subroutine edgind (isd,nmk,nnk, kzedg,kncedg,kncint,knedg) implicit double precision (a-h,o-z) ! define edge indexing information go to (100,200,300,400), isd ! 100 continue kzedg = 1 kncedg = nmk kncint = 1 knedg = nnk go to 950 ! 200 continue kzedg = 1 + (nnk-1)*nmk kncedg = 1 kncint = -nmk knedg = nmk go to 950 ! 300 continue kzedg = nmk*nnk kncedg = -nmk kncint = -1 knedg = nnk go to 950 ! 400 continue kzedg = nmk kncedg = -1 kncint = nmk knedg = nmk ! 950 continue return END subroutine edgind ! **deck edgls subroutine edgls(d,w,a) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * compute value of function f(x) at x=0 in terms of values * ! * of f at points x1,x2,x3 and x4 by using a weighted least * ! * square quadratic fit. it is assumed that * ! * (x1).le.(2.*x2).le.(0.).le.(2.*x3).le.(x4) . * ! * it is also assumed that the weights at x2 and x3 are * ! * infinite. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * find quadratic distribution y(x) such that y(x2)=f(x2), * ! * y(x3)=f(x3), and p=w1*(y(x1)-f(x1))**2+w4*(y(x4)-f(x4))**2 is* ! * minimized. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * a argument output vector such that the estimated* ! * value of f at x=0 is * ! * a(1)*f(x1)+a(2)*f(x2) * ! * +a(3)*f(x3)+a(4)*f(x4) * ! * * ! * d argument input lengths of intervals for which* ! * x1,x2,x3 and x4 are midpoints.* ! * it is assumed that x=0 is an * ! * endpoint of the second and * ! * third intervals. * ! * * ! * w argument input least square weights at each * ! * point x1,x2,x3 and x4 * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! dimension d(4),w(4),a(4) !c ! * compute values of a immediately if x3=x2=0. * ! a(1)=0.d0 a(2)=.5d0 a(3)=.5d0 a(4)=0.d0 if((d(2).eq.0.d0).and.(d(3).eq.0.d0)) go to 900 !c ! * compute x1,x2,x3 and x4 * ! x1=-d(2)-.5d0*d(1) x2=-.5d0*d(2) x3=.5d0*d(3) x4=d(3)+.5d0*d(4) !c ! * compute values of a from least square fit * ! w1=w(1) w4=w(4) f=w1*((x1-x3)*(x1-x2))**2+w4*((x4-x3)*(x4-x2))**2 a(1)=w1*x2*x3*(x1-x3)*(x1-x2)/f a(2)=x3*(w1*x1*(x1-x2)*(x1-x3)**2+w4*x4*(x4-x2)*(x4-x3)**2)/ & &(f*(x3-x2)) a(3)=-x2*(w1*x1*(x1-x3)*(x1-x2)**2+w4*x4*(x4-x3)*(x4-x2)**2)/ & &(f*(x3-x2)) a(4)=w4*x2*x3*(x4-x3)*(x4-x2)/f 900 return END subroutine edgls ! **deck edgmpi subroutine edgmpi (kedg,imp,nedmpa, iedmp) implicit double precision (a-h,o-z) dimension nedmpa(1:*) ! determine the global edge mesh point index, given the edge (ke ! the mesh point on the edge (imp), and the global edge point ma knet = (kedg-1)/4 + 1 ksd = kedg - 4*(knet-1) knedg = nedmpa(kedg+1) - nedmpa(kedg) + 1 if ( imp .ge. knedg ) go to 100 ! imp .lt. knedg iedmp = nedmpa(kedg) + imp go to 950 ! imp .eq. knedg 100 if ( ksd.le.3 ) iedmp = nedmpa(kedg+1) + 1 if ( ksd.eq.4 ) iedmp = nedmpa(1+4*(knet-1)) + 1 go to 950 ! 950 continue return END subroutine edgmpi ! **deck edgseg subroutine edgseg (s, m,ds,incs, ii,tii) implicit double precision (a-h,o-z) dimension ds(incs*m) ! ! find the index (ii) such that ds(ii-1) .lt. stest .le. ds(ii) ! where stest = s * ds(m) ! lsfin = 1 + (m-1)*incs stest = s*ds(lsfin) ls = 1 do 100 i = 2,m ls = ls + incs iisv = i if ( stest .le. ds(ls) ) goto 110 100 continue 110 continue ! ds(ls-incs) .lt. stest .le ds(ls) dds = ds(ls) - ds(ls-incs) if ( dds.gt. 0.d0) tii = (stest-ds(ls-incs))/dds ii = iisv return END subroutine edgseg ! **deck edgspl subroutine edgspl (x,w,a) implicit double precision (a-h,o-z) dimension x(4), w(4), a(4) ! a(1) = 0.d0 a(2) = .5d0 a(3) = .5d0 a(4) = 0.d0 ! if ( x(2).eq.0.d0 .and. x(3).eq.0.d0 ) go to 900 ! f = w(1) * ( ( x(1)-x(3) ) * ( x(1)-x(2) ) )**2 + & & w(4) * ( ( x(4)-x(3) ) * ( x(4)-x(2) ) )**2 ! a(1) = w(1) * x(2) * x(3) * ( x(1)-x(2) )*( x(1)-x(3) ) / f a(4) = w(4) * x(2) * x(3) * ( x(4)-x(2) )*( x(4)-x(3) ) / f g2 = w(1) * x(1) * ( x(1)-x(2) ) * ( x(1)-x(3) )**2 + & & w(4) * x(4) * ( x(4)-x(2) ) * ( x(4)-x(3) )**2 g3 = w(1) * x(1) * ( x(1)-x(3) ) * ( x(1)-x(2) )**2 + & & w(4) * x(4) * ( x(4)-x(3) ) * ( x(4)-x(2) )**2 a(2) = x(3) * g2 /( f*( x(3)-x(2) ) ) a(3) = -x(2) * g3 /( f*( x(3)-x(2) ) ) 900 continue return END subroutine edgspl ! **deck edgtau subroutine edgtau (ze,ince,ne,dze, te, taue) implicit double precision (a-h,o-z) dimension ze(3,1) ! compute the edge tau parameter taue for a point on an edge ! whose t-parameter is te . ie = te if ( ie.lt.1 ) go to 300 if ( ie.ge.ne ) go to 400 dz = 0.d0 if ( 2.gt.ie ) go to 110 do 100 i = 2,ie kz1 = 1 + (i-2)*ince kz2 = kz1 + ince call distnc (ze(1,kz1),ze(1,kz2),d) dz = dz + d 100 continue 110 continue ! kz1 = 1 + (ie-1)*ince kz2 = kz1 + ince call distnc (ze(1,kz1),ze(1,kz2),d) tau = te - ie dz = dz + tau*d taue = dz/dze return ! 300 continue taue = 0.d0 return ! 400 continue taue = 1.d0 return ! END subroutine edgtau ! **deck edpang subroutine edpang (z,mpt,npt,lsd,ind,cp,ijpan,diam) implicit double precision (a-h,o-z) dimension z(3,mpt,npt), cp(3,4), cpz(3), w(3) !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs ! ! ! ! *** common /edpangx/ ncall ! *** data ncall /0/ ! if ( lsd.eq.1 ) ipan = 1 if ( lsd.eq.2 ) ipan = ind if ( lsd.eq.3 ) ipan = mpt-1 if ( lsd.eq.4 ) ipan = mpt-ind ! if ( lsd.eq.1 ) jpan = ind if ( lsd.eq.2 ) jpan = npt-1 if ( lsd.eq.3 ) jpan = npt-ind if ( lsd.eq.4 ) jpan = 1 ! ijpan = ipan + (jpan-1)*(mpt-1) call xfera ( z(1,ipan ,jpan ), cp(1,1), 3) call xfera ( z(1,ipan ,jpan+1), cp(1,2), 3) call xfera ( z(1,ipan+1,jpan+1), cp(1,3), 3) call xfera ( z(1,ipan+1,jpan ), cp(1,4), 3) ! cpz(1) = .25d0*( cp(1,1) + cp(1,2) + cp(1,3) + cp(1,4) ) cpz(2) = .25d0*( cp(2,1) + cp(2,2) + cp(2,3) + cp(2,4) ) cpz(3) = .25d0*( cp(3,1) + cp(3,2) + cp(3,3) + cp(3,4) ) ! diam = 0.d0 do 100 j = 1,4 call vadd (cp(1,j),-1.d0,cpz,w,3) call compip (w,w,compd,abetms,ww) diam = max ( diam, ww) 100 continue ! diam = 2.d0*sqrt(diam) ! ! *** ncall = ncall + 1 ! *** if ( ncall.gt.20 ) return ! *** call outlin ('edpang...',8,mpt,npt,lsd,ind,ijpan,diam,ipan,jpan) ! *** call outmat ('cp',3,3,4,cp) return END subroutine edpang ! **deck eivc subroutine eivc (mtched,npnmts,ipnmts,nceivc & & ,nedaba,kfdseg,kfdkey,kfdsgn,nedmpa,tauemp & & ) implicit double precision (a-h,o-z) dimension ipnmts(10) !-- dimension nedaba(mxnabt+1), kfdseg(4*mxfdsg) !-- x , kfdkey(mxfdsg), kfdsgn(mxfdsg) !-- x , nedmpa(4*mxnett+1), tauemp(mxempt) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call symm common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym !end symm !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt ! FORMAL PARAMETER DECLARATIONS dimension nedaba(mxnabt+1), kfdseg(4*mxfdsg) & & , kfdkey(mxfdsg), kfdsgn(mxfdsg) & & , nedmpa(4*mxnett+1), tauemp(mxempt) !call enrchx common /enrchx/ senrch !end enrchx dimension zk(3), dz(3), phi(9), phis(9), phit(9) dimension ps(3), pt(3), pst(3), as(3), at(3), enintr(3) dimension enunit(3), enu(3) dimension dvdd(9), dvss(5), dv(25) dimension zch(3) logical ident !call indedg ! /indedg/ common /indedg/ kokseg, kedseg, i1kseg, i2kseg & & , lokseg, ledseg, i1lseg, i2lseg !end indedg ! character*8 imatch ! ! get the fundamental segment of the c. iabt = iabs( kabmtc ) nedg = nedaba(iabt+1) - nedaba(iabt) kfsg = kfsgc call icopy (4, kfdseg(4*kfsg-3),1, kokseg,1) knet = (kedseg+3)/4 ksd = kedseg - (knet-1)*4 ksgn = isign( 1, kfdsgn(kfsg) ) ! perform a quick check on the panel ijpan = ipnf - npa(kpf) call mnmod (ijpan, nm(kpf)-1, ipan, jpan) mpan = nm(kpf) - 1 npan = nn(kpf) - 1 if ( ipan.ne.1 .and. ipan.ne.mpan & & .and. jpan.ne.1 .and. jpan.ne.npan ) go to 950 ! ================= dup some cards here ================= call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) call enrchg (kc,ifn,jfn,zch) sclzch = senrch sclpan = 0.d0 do 30 j = 1,4 sclpan = max (sclpan, ddot(3, cpf(1,j),1,cpf(1,j),1) ) 30 continue scldz = max ( sclzch, sqrt(sclpan) ) if ( nceivc.ne.2 ) go to 40 write (6,'(1x,a10,1x, 4i12,f12.6,i12,3f12.6)') & & 'cp,kc,i,j',jcn,kc,ifn,jfn,tauc,kfsgc & & ,zch(1),zch(2),zch(3) write (6,'(1x,a10,1x, 5i12)') & & 'panel ',ipnf,kpf,ipan,jpan,mpan call outmat ('mesh points',3,3,4,cpf) 40 continue ! do 100 ie = 1,nedg le = ie iedg = ie + nedaba(iabt) lfsg = kfdkey(iedg) call icopy (4, kfdseg(4*lfsg-3),1, lokseg,1) lnet = (ledseg+3)/4 if ( lnet.ne.kpf ) go to 100 lsd = ledseg - (lnet-1)*4 go to (51,52,53,54), lsd 51 continue if ( ipan.ne.1 ) go to 100 l1 = jpan go to 60 52 continue if ( jpan.ne.npan ) go to 100 l1 = ipan go to 60 53 continue if ( ipan.ne.mpan ) go to 100 l1 = npan + 1 - jpan go to 60 54 continue if ( jpan.ne.1 ) go to 100 l1 = mpan + 1 - ipan go to 60 ! 60 continue if ( nceivc.eq.2 ) write (6,'(1x,a10,1x, 6i12)') & & 'check 1',ie,lnet,lsd,l1 & & ,le,mtched l2 = l1 + 1 if ( l1.lt.i1lseg .or. l2.gt.i2lseg ) go to 100 ! edge lsd of the panel is involved ! in the abutment for which the current ! control point does matching. check ! that this network has not yet been ! accounted for and that the tau values ! match up. mbit = 2**(le-1) if ( mod(mtched,2*mbit) .ge. mbit ) go to 100 ! lsgn = isign( 1, kfdsgn(lfsg) ) if ( l1.eq.i1lseg ) taul1 = (1-lsgn)/2 if ( l2.eq.i2lseg ) taul2 = (1+lsgn)/2 call edgmpi (ledseg,l1,nedmpa, iedmp1) call edgmpi (ledseg,l2,nedmpa, iedmp2) if ( l1.ne.i1lseg ) taul1 = tauemp(iedmp1) if ( l2.ne.i2lseg ) taul2 = tauemp(iedmp2) taumin = min ( taul1, taul2) taumax = max ( taul1, taul2) dtau = taumax - taumin ic1 = lsd ic2 = mod(lsd,4) + 1 call distnc (cpf(1,ic1),cpf(1,ic2),dzedg) tolscl = .0001d0 * dtau * diamf if ( nceivc.eq.2 ) write (6,'(1x,a10,1x, 7f12.6)') & & 'check 2',taumin,tauc,taumax & & ,dzedg,tolscl,dtau,diamf if ( (tauc-taumax)*dzedg .gt. tolscl ) go to 100 if ( (taumin-tauc)*dzedg .gt. tolscl ) go to 100 ! things look promising. make one ! last check call cptls (cpf(1,ic1), cpf(1,ic2), zch, zk, t) call distnc (zch,zk,dzqp) ident = dzqp .le. (1.d-10 * scldz) imatch = 'match-cp' if ( .not. ident ) imatch = 'notmatch' if ( nceivc.eq.2 ) write (6,6745) imatch, zk, zch 6745 format (' check 3 ',a8,3e24.16 & & ,/, ' ',8x,3e24.16 ) if ( .not.ident ) go to 100 ! all tests passed if ( iedgep .le. 0 ) go to 110 write (6,'(1x,a10,1x, 1i12)') & & '== success',1 write (6,6001)jcn,knet,ksd, kabmtc,kfsgc,ksgn,tauc & & ,kpf,ipan,jpan,lsd, dzedg,taumin,taumax,lsgn & & ,le,mtched 6001 format (' eivc match: jcn',i4,' nw',i3,' side',i2 & & ,' abut',i4,' fd seg',i4,' ksgn',i3,' tau-jc',f12.8 & &,/,14x,' panel: nw',i3,' row',i3,' col',i3,' side',i3 & & ,' lth/edge',f12.8,' taumin',f12.8,' taumax',f12.8 & &,/,14x,' sgn',i3,' le',i3,' match',i10) go to 110 ! 100 continue go to 950 ! ! ! a panel involved with the current ! matching condition has been found ! ! 110 continue mtched = mtched + mbit ! if current nw is null mu, exclude if ( ntd(lnet).eq.0 ) goto 950 npnmts = npnmts + 1 ipnmts(npnmts) = lsgn*( (ipnf-1)*4 + lsd ) ! 950 continue return END subroutine eivc ! **deck ellpt subroutine ellpt(k) implicit double precision (a-h,o-z) !call propre !c !******************************************************************* ! ! note ! ! ! A502 was developed by: ! ! The Boeing Company ! Boeing Commercial Airplanes ! Aerodynamics Research Group ! ! Individuals who have contributed to its development ! include: ! ! Forrester T. Johnson ! F. Edward Ehlers ! Michael A. Epton ! Larry L. Erickson (NASA) ! Paul E. Rubbert ! Gary R. Saaris ! Edward N. Tinoco ! ! !c !*********************************************************************** ! !end propre ! purpose - to generate a body network having an elliptical cross- ! section !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits dimension xs(300),r(300),th(100) dimension r2(300),z(300) character*90 qline !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !call inp3 common /inp3/ ntsin,ntsout !end inp3 ra=pi/180.d0 read (ntsin,'( a )') qline read(qline,4000,err=9950) anopt, iduser(k) 4000 format(e10.0,60x,a) write(6, 5075) k, iduser(k) 5075 format(5x,25hnetwork # being processed,i4,66x,a,/) nopt=anopt read (ntsin,'( a )') qline read (qline,5000,err=9950) em m = em nm(k)=m do 15 i1 = 1,m,2 i2 = min(m,i1+1) read (ntsin,'( a )') qline read(qline,5000,err=9950)(xs(i),r(i),r2(i),i=i1,i2) 15 continue if (nopt) 40,40,20 20 continue do 25 i1 = 1,m,6 i2 = min(m,i1+5) read (ntsin,'( a )') qline read(qline,5000,err=9950)(z(i),i=i1,i2) 25 continue go to 80 40 do 60 i = 1,m 60 z(i) = 0.d0 80 continue read (ntsin,'( a )') qline read (qline,5000,err=9950) en n = en nn(k)=n do 83 i1 = 1,n,6 i2 = min(n,i1+5) read (ntsin,'( a )') qline read(qline,5000,err=9950)(th(i),i=1,n) 83 continue do 90 j = 1,n st = sin(th(j)*ra) ct = cos(th(j)*ra) do 90 i = 1,m iv = (j-1)*m + i +nza(k) zm(1,iv) = xs(i) den = sqrt (r2(i)*r2(i)*ct*ct + r(i)*r(i)*st*st) if (den.gt.0.d0) go to 85 zm(2,iv)=0.d0 zm(3,iv)= z(i) go to 90 85 zm(2,iv) = r(i) * r2(i) * ct / den zm(3,iv) = z(i) + r(i)*r2(i)*st / den 90 continue nza(k+1)=nza(k)+n*m return ! *** format statements *** 5000 format(6e10.0) ! ! read error handling ! 9950 continue write (6,9960) 'ellpt', qline, ((lll,lll=1,10),kkk=1,8) 9960 format (' read error occurred in subroutine ',a & & ,/,' INPUT LINE:',a90 & & ,/,' columns:',80i1,4x,'line # (see list of a502 input)' ) call a502er('ellpt',' program failure due to ill-formatted data') return ! END subroutine ellpt ! **deck emark subroutine emark (label) implicit double precision (a-h,o-z) character*(*) label write (6,6001) label 6001 format ('0*e*',a8) return END subroutine emark ! **deck en2xfm subroutine en2xfm (en,a) implicit double precision (a-h,o-z) dimension en(3), a(3,3) ! ! given a normal vector, generate an orthogonal transformation ! having that normal vector (normalized) as its last row ! dimension em(3), u(3), v(3) ! call dcopy (3, en,1, em,1) call uvect (em) ! ix = idamax (3,em,1) iy = mod(ix,3) + 1 iz = mod(iy,3) + 1 u(ix) = em(iy) u(iy) = -em(ix) u(iz) = 0.d0 call uvect (u) ! call cross (em,u,v) ! do 100 j = 1,3 a(1,j) = u(j) a(2,j) = v(j) a(3,j) = em(j) 100 continue ! return END subroutine en2xfm ! **deck enrchg subroutine enrchg(k,m,n,z) implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index dimension z(3) !call enrchx common /enrchx/ senrch !end enrchx n1=(n+1)/2 n2=(n+2)/2 m1=(m+1)/2 m2=(m+2)/2 l1=m1+nm(k)*(n1-1)+nza(k) l2=m1+nm(k)*(n2-1)+nza(k) l3=m2+nm(k)*(n1-1)+nza(k) l4=m2+nm(k)*(n2-1)+nza(k) do 100 i=1,3 100 z(i)=.25d0*(zm(i,l1)+zm(i,l2)+zm(i,l3)+zm(i,l4)) s1 = zm(1,l1)**2 + zm(2,l1)**2 + zm(3,l1)**2 s2 = zm(1,l2)**2 + zm(2,l2)**2 + zm(3,l2)**2 s3 = zm(1,l3)**2 + zm(2,l3)**2 + zm(3,l3)**2 s4 = zm(1,l4)**2 + zm(2,l4)**2 + zm(3,l4)**2 smax = max ( s1,s2,s3,s4) senrch = sqrt(smax) return END subroutine enrchg ! **deck epoint subroutine epoint (z,incz,nz, t,zt) implicit double precision (a-h,o-z) dimension z(3,1), zt(3) ! compute the point on the edge ! (z,incz,nz) associated with the ! parameter t . anz = nz-1 it = max( 1.d0, min( anz, t ) ) lz1 = 1 + (it-1)*incz lz2 = lz1 + incz tau = t - it tauc = 1.d0-tau ! zt(1) = tauc*z(1,lz1) + tau*z(1,lz2) zt(2) = tauc*z(2,lz1) + tau*z(2,lz2) zt(3) = tauc*z(3,lz1) + tau*z(3,lz2) return END subroutine epoint ! **deck errdiv subroutine errdiv ! ! error handler for: divide checks ! CALL REMARX('divide check error') CALL AbortPanair('errdiv') END subroutine errdiv ! **deck errinv subroutine errinv ! ! error handler for: invalid operation errors ! CALL Remarx('invalid arithmetic error') CALL AbortPanair('errinv') END subroutine errinv ! **deck errmsg subroutine errmsg (l) implicit double precision (a-h,o-z) character*(*) l write (6,10) l 10 format (' error message ',a40) return END subroutine errmsg ! **deck errovf subroutine errovf ! ! error handler for: overflow errors ! CALL Remarx('overflow error') CALL AbortPanair('errovf') END subroutine errovf ! **deck errund subroutine errund ! ! error handler for: underflow errors ! CALL Remarx('underflow error') CALL AbortPanair('errund') END subroutine errund ! **deck etdprt subroutine etdprt(n,a,h,b,c,u,v,ier) ! !****** ! etdprt finds all zeros of a real polynomial using simultaneous newton ! and bairstow iterations. convergence criteria based on adam,cacm - ! oct,67. ! ! input - n degree of polynomial ! a polynomial coefficients ( low order first) ! ! output- u,v real and imaginary parts of roots ! ier success/error code ! .eq. 0 results ok ! .eq. -1 n.le.0 or n.gt.60 ! ( u(1),v(1) are clobbered ) ! .eq. -2 a(n+1).eq.0 ! ( u(1),v(1) are clobbered ) ! .lt. -9 only k roots could be found where ! k = -ier-10 and k could be 0 ! ( u(k+1),v(k+1) are clobbered ) ! ! scratch-h,b,c, used for internal calc. ! ! adapted from the ibm procedure proot for the purpose of ! providing a common usage procedure that contains code with a ! a higher degree of portability. ! ! !****** ! double precision a(*),u(*),v(*),h(*),b(*),c(*) ! !--- double precision hdmcon double precision bm1,bm2,bm3,cbar,conv,d,e,f double precision p,pp,q,qp,r,rm,rnd,y2,zm integer i,n,nc,m,nl,i1,ier,irev,k,np,j ! ier = 0 !--- rnd = hdmcon(5) !--- if ( hdmcon(7) .eq. 2.d0 ) rnd = rnd+rnd rnd = 2.d-14 ! ! increment degree to get size of ! coefficient array. ! if ( n.le.0 .or. n.gt.60 ) go to 90 nc=n+1 ! ! check to see if high order ! coefficient = 0. ! if (a(nc).eq.0.d0) go to 92 !--- 1 conv=hdmcon(4) 1 continue conv = 1.d-38 ! ! store coefficients in working array ! do 2 i=1,nc 2 h(i)=a(i) ! ! set starting values for quadratic ! and linear factors,x**2 + p*x + q ! and x-r. ! p=0.0d0 q=0.0d0 r=0.0d0 ! ! set polynomial reversal switch ! irev=1 ! ! check for low order coefficient = 0 ! 3 if (h(1)) 6,4,6 ! ! if low order coefficient = 0, reduce ! degree by one and set one root = 0. ! 4 nc=nc-1 v(nc)=0.0d0 u(nc)=0.0d0 ! ! shift coefficient array to ! compensate for extraction of zero ! root ! do 5 i=1,nc 5 h(i)=h(i+1) go to 3 ! ! test for degree = 0. ! 6 if (nc-1) 7,100,7 ! ! test for degree = 1. ! 7 if (nc-2) 9,8,9 ! ! if degree = 1, solve linear. ! 8 r=-h(1)/h(2) go to 50 ! ! if degree = 2, solve quadratic. ! 9 if (nc-3) 11,10,11 10 p=h(2)/h(3) q=h(1)/h(3) go to 70 ! ! make test for reversal ! 11 if (dabs(h(nc))-dabs(h(1))) 12,19,19 ! set reversal switch and reverse ! ! coefficients. ! 12 irev=-irev m=nc/2 do 13 i=1,m nl=nc+1-i f=h(nl) h(nl)=h(i) 13 h(i)=f ! ! alter p,q and r due to reversal. ! if (q) 15,14,15 14 p=0.0d0 go to 16 15 p=p/q q=1.0d0/q 16 if (r) 17,19,17 17 r=1.0d0/r ! ! 19 continue ! ! initialize newton-bairstow loop. ! b(nc)=h(nc) c(nc)=h(nc) np=nc-1 ! ! begin newton-bairstow loop. ! 20 do 40 j=1,1000 ! ! divide polynomial by x-r. ! e=dabs(h(nc))/2.d0 rm=dabs(r) do 21 i1=1,np i=nc-i1 b(i)=h(i)+r*b(i+1) e=e*rm+dabs(b(i)) 21 c(i)=b(i)+r*c(i+1) ! ! test remainder ! bm1=dabs(b(1)) e=rnd*(e+e-bm1) if(bm1-e) 50,50,22 ! ! test derivative evaluated at r for ! zero. ! 22 if (c(2)) 24,23,24 ! ! if derivative zero, newton is in ! trouble so perturb root by 1. ! 23 r=r+1.0d0 go to 25 ! ! apply newton-correction ! 24 r=r-b(1)/c(2) ! ! divide polynomial by x**2 + p*x + q ! 25 e = 0.75d0*dabs(h(nc)) zm=dsqrt(dabs(q)) b(nc-1) = h(nc-1) - p*b(nc) e = e*zm + dabs(b(nc-1)) c(nc-1) = b(nc-1) - p*c(nc) do 30 i1 = 2,np i=nc-i1 b(i)=h(i)-p*b(i+1)-q*b(i+2) e=e*zm+dabs(b(i)) 30 c(i)=b(i)-p*c(i+1)-q*c(i+2) ! ! make convergence criterion tests ! bm3=p*b(2)/2.d0 bm1=dabs(b(1)+bm3) bm2=dabs(b(2)) e = (rnd*(4.d0*e-3.d0*(bm1+zm*bm2)+dabs(bm3)))**2 y2=dabs(q-p**2/4.d0) if(bm1**2+y2*bm2**2-e) 60,60,34 34 cbar=c(2)-b(2) d=c(3)**2-cbar*c(4) if (d)36,35,36 ! ! pertub p if d=0. ! 35 p=p-2.0d0 q=q*(q+1.0d0) go to 40 ! ! add bairstow corrections t0 p and q. ! 36 p=p+(b(2)*c(3)-b(1)*c(4))/d q=q+(-b(2)*cbar+b(1)*c(3))/d ! ! end loop ! ! 40 continue ! iteration failed - note how many roots yet ier = nc-n-11 go to 94 ! ! if newton converged reduce degree by ! one ! 50 nc=nc-1 conv= max (e,conv) ! ! set imaginary part to zero ! v(nc)=0.0d0 ! ! test for reversal ! if (irev)51,52,52 51 u(nc)=1.0d0/r go to 53 52 u(nc)=r ! ! store reduced polynomial in working ! array ! 53 do 54 i=1,nc 54 h(i)=b(i+1) ! ! return to solve reduced polynomial ! go to 6 ! ! if quadratic factor found reduce ! degree by 2 ! ! 60 e=dsqrt(e) conv= max (e,conv) ! test for reversal and solve ! quadratic accordingly ! 70 nc=nc-2 if (irev)71,72,72 71 qp=1.0d0/q pp=p/(q*2.0d0) go to 73 72 qp=q pp=p/2.0d0 73 f=(pp)**2-qp if (f)74,75,75 74 u(nc+1)=-pp u(nc)=-pp v(nc+1)=dsqrt(-f) v(nc)=-v(nc+1) go to 76 75 u(nc+1)=-dsign(dabs(pp)+dsqrt(f),pp) v(nc+1)=0.0d0 u(nc)=qp/u(nc+1) v(nc)=0.0d0 ! ! store reduced polynomial in working ! array. ! 76 do 77 i=1,nc 77 h(i)=b(i+2) ! ! return to solve reduced polynomial. ! go to 6 ! !**** error exits and normal return ! 90 ier = -1 go to 94 92 ier = -2 94 k = max (-ier-10,0) ! move data if necessary if (k .eq. 0) go to 98 do 96 i = 1, k u(i) = u(nc) v(i) = v(nc) nc = nc+1 96 continue 98 continue ! !--- u(k+1) = hdmcon(1) u(k+1) = 1.d38 v(k+1) = u(k+1) 100 return END subroutine etdprt ! **deck evalhp subroutine evalhp (cp, sv,tv, zc) implicit double precision (a-h,o-z) dimension cp(3,4), zc(3) ! ! evaluate the coordinates zc of a point on a panel given by ! H-P coordinates (sv,tv) ! dimension bl(2,2) ! call blbfun (sv,tv, bl) do 100 k = 1,3 zc(k) = cp(k,1)*bl(1,1) & & +cp(k,2)*bl(1,2) & & +cp(k,3)*bl(2,2) & & +cp(k,4)*bl(2,1) 100 continue ! return END subroutine evalhp ! **deck evldmz subroutine evldmz (sgip,sgjp,qs,qt,qst,amz) implicit double precision (a-h,o-z) dimension qs(3), qt(3), qst(3), amz(3) dimension sws(9), swt(9), tws(9), twt(9) dimension stws(9), stwt(9), swst(9), twst(9), stwst(9) ! ! evaluate amz using direct evaluation techniques (see dsnfmc). ! this routine is used by chkdmz to perform a finite difference ! consistency check of the computation of moment derivatives ! by dsnfmc. ! p33 = 1.d0/3.d0 do 100 j = 1,3 do 90 i = 1,3 ij = i + (j-1)*3 sws (ij) = qs (i)*qs (j) tws (ij) = qt (i)*qs (j) swt (ij) = qs (i)*qt (j) twt (ij) = qt (i)*qt (j) ! stws (ij) = qst(i)*qs (j) stwt (ij) = qst(i)*qt (j) swst(ij) = qs (i)*qst(j) twst(ij) = qt (i)*qst(j) stwst(ij) = qst(i)*qst(j) 90 continue 100 continue sis = ddot(3, qs,1, qs,1) sit = ddot(3, qs,1, qt,1) tit = ddot(3, qt,1, qt,1) stis = ddot(3, qst,1, qs,1) stit = ddot(3, qst,1, qt,1) stist = ddot(3, qst,1, qst,1) ! ! compute amz: get coeffs of qs,qt,qst amzqs = sgip*sit + sgjp*tit & & +p33*stis + 2.d0*sgip*sgjp*stit +p33*sgjp*stist amzqt = -sgjp*sit - sgip*sis & & -p33*stit - 2.d0*sgip*sgjp*stis -p33*sgip*stist amzqst = -p33*sis + p33*tit & & +p33*sgip*stit - p33*sgjp*stis ! do 390 kk = 1,3 amz(kk) = amzqs*qs(kk) + amzqt*qt(kk) + amzqst*qst(kk) 390 continue ! return END subroutine evldmz ! **deck exitms subroutine exitms (lun,msg) character*(*) msg ! issue a fatal error message from the readms/writms pkg write (6,6000) lun,msg 6000 format (' exitms: fatal error on unit',i3,' msg:',a) call remarx (msg) CALL AbortPanair('exitms') return END subroutine exitms ! **deck exwsdn subroutine exwsdn (cp,wsdn) implicit double precision (a-h,o-z) dimension cp(3,9), wsdn(3,3,8) dimension en(3), wp(3,9), isx(3) ! ! evaluate exact reference mass-flux vectors for the sphere ! problem at M=0. ! do 100 j = 1,9 call dcopy (3, cp(1,j),1, en(1),1) call uvect (en(1)) enx = en(1) wp(1,j) = .5d0*( 1.d0 - 3.d0*enx*en(1)) wp(2,j) = .5d0*( - 3.d0*enx*en(2)) wp(3,j) = .5d0*( - 3.d0*enx*en(3)) 100 continue ! do 250 is = 1,8 if ( is.le.4 ) then isx(1) = is isx(2) = is+4 isx(3) = mod(is+2,4)+5 else isx(1) = 9 isx(2) = mod(is+2,4)+5 isx(3) = is endif do 240 kk = 1,3 call dcopy (3, wp(1,isx(kk)),1, wsdn(1,kk,is),1) 240 continue 250 continue return END subroutine exwsdn ! **deck f10fmt subroutine f10fmt (x,chx) implicit double precision (a-h,o-z) character*10 chx ! ! take the f.p. number x (input) and generate a good f-format ! text image of x in the array chx(2) (2a5) ! character*10 fmtx(11), temp data fmtx / '(1p,e10.3)', '(f10.7)', '(f10.7)','(f10.7)' & & , '(f10.6)' , '(f10.5)', '(f10.4)', '(f10.3)' & & , '(f10.2)' , '(f10.1)', '(1p,e10.3)' / ! ix = max( 1.d0, log10( max( 1.d-20, abs(x)*1.01d0) ) +4.d0) ix = min ( 11, ix) write (temp,fmtx(ix)) x chx = temp return END subroutine f10fmt ! **deck fcncpx subroutine fcncpx (nxlam,xlam, dvdlam,vic,aic & & ,rhs,fcnmax, ljac,jacob,prtcp2,cp2sum & & ) implicit double precision (a-h,o-z) dimension xlam(nxlam,1), dvdlam(4,1), vic(3,2,1), aic(1) dimension rhs(*) logical jacob, prtcp2, cp2sum ! ! evaluate the nonlinear components of the function box and ! if requested, the corresponding function sensitivities. ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call cp2mcd ! /cp2mcd/: common region for list of all cp(second order) b.c.' ! jcncp2 = list of control points ! irwcp2 = list of aic rows ! inacp2 = list of corresponding entries in idcp2(1:3 parameter (maxcp2=1000) common /cp2mcd/ nbccp2, jcncp2(maxcp2), irwcp2(maxcp2) & & , inacp2(maxcp2) !end cp2mcd !call cp2aul ! /cp2aul/ = index for abutments having a cp(2nd order) ! matching condition. common /cp2aul/ ncp2ab, idcp2(3,50) & & , ablcp2(50), keycp2(50) integer ablcp2 !end cp2aul !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call bcon common /bcon/ & & cu1,cl1,tu1(3),tl1(3),du1,dl1,bet1(4),nct1,nlopt1,nropt1,necpt1 & & ,klopt1,kldum1,betin1(4) & & ,cu2,cl2,tu2(3),tl2(3),du2,dl2,bet2(4),nct2,nlopt2,nropt2,necpt2 & & ,klopt2,kldum2,betin2(4) & & ,ndbcon !end bcon ! dimension pv(3,2), knetul(2), dcpx(6) dimension dvsrc(3,3), dvdbl(3,9), dvs(3,9), dvd(3,25) dimension delvs(3,4), delvd(3,4), delv(3,4), vavg(3,4) dimension dsg(3), phvmu(4,9), enscl(3) dimension zch(3), zk(3) dimension ipnul(2), jpnul(2) dimension cpv(2), dcpv(3,2) logical ident data njac/0/ ! ! ! rewind ljac if ( cp2sum ) write (6,6006) do 1000 ibccp2 = 1,nbccp2 jc = jcncp2(ibccp2) iaic = irwcp2(ibccp2) icp2ab = inacp2(ibccp2) call btrns (jc,cu1) call ctrns (jc,zc) call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) call enrchg (kc,ifn,jfn,zch) call dcip (znc,znc,fac) call vmul (znc, 1.d0/fac, enscl, 3) if ( prtcp2 ) & & write (6,6001) ibccp2,iaic,icp2ab,ifn,jfn,jc,zch 6001 format (' fcncpx ibccp2=',i3,' iaic=',i4,' icp2ab=',i4 & & ,' ifn,jfn=',2i4,' jc=',i4,' zch=',3f12.6) if ( jacob ) call zero (vic,6*nsngt) if ( icp2ab.eq.0 ) go to 410 ! ! multiple nw cp matching on an abutment ! ivchek = 0 indjc = idcpmc iabt = idcp2(1,icp2ab) if ( nbinmc.eq.1 ) betn = bet1(iacase) if ( nbinmc.eq.2 ) betn = bet2(iacase) do 400 iuplo = 1,2 sgnul = 3 - 2*iuplo kedsgn = idcp2(iuplo+1,icp2ab) sgnsrf = isign(1,kedsgn) kedsrf = iabs(kedsgn) ! get the panel index for the upper/lowe ! surface pt. involved in the matching do 210 j = 1,npnmtc ipndat = iabs(ipnmtc(j)) call mnmod (ipndat,4,ksd,ipanel) call ibsrch (npa,nnett+1,ipanel,knet) kedge = ksd + 4*(knet-1) if ( kedge.eq.kedsrf ) go to 220 210 continue call a502er ('fcncpx','missing nw edge in abutment match') 220 continue ! calculate del(v) at the upper/lower ! surface pt. involved in the matching call strns (ipanel,cp) if ( its.ne.1 .and. its.ne.3 ) ins = 0 if ( its.ne.2 .and. its.ne.3 ) ind = 0 knetul(iuplo) = isign(1,kedsgn)*knet ipnw = ipanel - npa(knet) call mnmod (ipnw,nm(knet)-1, ipnul(iuplo),jpnul(iuplo)) ksdp1 = mod(ksd,4) + 1 call cptls (cp(1,ksd),cp(1,ksdp1),zch,zk,t) call pident (zch,zk,ident) if(.not.ident)call a502wr ('fcncpx','zch .ne. zk, c.p. mismatch') call stedge (ksd,t,sval,tval) call dvcalc (zch,sval,tval,dvsrc,dvdbl) if ( ins.ne.0 ) call mxma (dvsrc,1,3, asts,1,3, dvs,1,3, 3,3,ins) if ( ind.ne.0 ) call mxma (dvdbl,1,3, astd,1,9, dvd,1,3, 3,9,ind) call delvca (nxlam,1,xlam, dvs,iis,ins, delvs) call delvca (nxlam,1,xlam, dvd,iid,ind, delvd) call vadd (delvs, 1.d0, delvd, delv,3) if ( prtcp2 ) & & write (6,6002) ipanel,knet,ksd,(delv(i,1),i=1,3) 6002 format (' panel',i4,' knet',i4,' ksd',i2,' delv',3f12.6) ! calculate the perturbation velocity on ! wetted surface, given the velocity jump iapotk = iabs( ipot(kc) ) go to (300, 310, 320, 330, 340, 350), (iapotk+1) ! 300 continue if ( ipanel.ne.ipc ) call a502er ('fcncpx' & & ,'panel index mismatch, vic-s unavailable ') if ( ivchek.eq.0 ) then call vtrns (jc,dvdlam) call mxma (dvdlam(2,1),1,4, xlam,1,nxlam, vavg,1,3 & & ,3,nsngt,1) endif ivchek = 1 call vadd (vavg, .5d0*sgnsrf, delv, pv(1,iuplo), 3) go to 350 ! 310 continue 320 continue if ( sgnsrf*ipot(kc) .le. 0.d0 ) call a502er ('fcncpx' & & ,'error at stmts 310/320 ') call vmul (delv,sgnsrf,pv(1,iuplo),3) go to 350 ! 330 continue 340 continue if ( sgnsrf*ipot(kc) .le. 0.d0 ) call a502er ('fcncpx' & & ,'error at stmts 330/340 ') call vadd (pvdry(1,iacase),sgnsrf,delv,pv(1,iuplo),3) go to 350 ! 350 continue ! calculate the sensitivity of the upper ! surface perturbation velocity w.r.t. l if ( .not. jacob ) go to 390 if ( iapotk .eq. 0 ) & & call mcopy (3,nsngt, dvdlam(2,1),1,4, vic(1,iuplo,1),1,6) fac = sgnsrf if ( iapotk.eq.0 ) fac = .5d0*sgnsrf do 360 j = 1,ins vic(1,iuplo,iis(j)) = vic(1,iuplo,iis(j)) + fac*dvs(1,j) vic(2,iuplo,iis(j)) = vic(2,iuplo,iis(j)) + fac*dvs(2,j) vic(3,iuplo,iis(j)) = vic(3,iuplo,iis(j)) + fac*dvs(3,j) 360 continue do 370 j = 1,ind vic(1,iuplo,iid(j)) = vic(1,iuplo,iid(j)) + fac*dvd(1,j) vic(2,iuplo,iid(j)) = vic(2,iuplo,iid(j)) + fac*dvd(2,j) vic(3,iuplo,iid(j)) = vic(3,iuplo,iid(j)) + fac*dvd(3,j) 370 continue 390 continue 400 continue go to 610 ! ! ! evaluate upper and lower surface ! perturbation velocities (and sens- ! itivities, if requested) at ! cp-matching control point. 410 continue call strns (ipc,cp) if ( its.ne.1 .and. its.ne.3 ) ins = 0 if ( its.ne.2 .and. its.ne.3 ) ind = 0 knetul(1) = kp knetul(2) = -kp ipnw = ipc - npa(kc) call mnmod (ipnw,nm(kc)-1, ipnul(1),jpnul(1)) ipnul(2) = ipnul(1) jpnul(2) = jpnul(1) nb = 0 if ( nlopt1.ge.18 .and. nlopt1.le.20 ) nb = 1 if ( nlopt2.ge.18 .and. nlopt2.le.20 ) nb = nb + 2 if ( nb.ne.1 .and. nb.ne.2 ) call a502er ('fcncpx' & & ,'no cp matching condition found, 410') if ( nb.eq.1 ) then betn = bet1(iacase) indjc = nlopt1 - 17 endif if ( nb.eq.2 ) then betn = bet2(iacase) indjc = nlopt2 - 17 endif call sincs (zc,dsg) call mxm (enscl, 3, dsg, 1, dvsrc, 3) call sincd (zc,phvmu,icc) call mcopy (3,9, phvmu(2,1),1,4, dvdbl,1,3) if ( ins.ne.0 ) call mxma (dvsrc,1,3, asts,1,3, dvs,1,3, 3,3,ins) if ( ind.ne.0 ) call mxma (dvdbl,1,3, astd,1,9, dvd,1,3, 3,9,ind) call delvca (nxlam,1,xlam, dvs,iis,ins, delvs) call delvca (nxlam,1,xlam, dvd,iid,ind, delvd) call vadd (delvs, 1.d0, delvd, delv,3) if ( prtcp2 ) & & write (6,6003) ipc,kp,indjc,(delv(i,1),i=1,3) 6003 format (' panel',i4,' kc',i4,' ind',i2,' delv',3f12.6) call vtrns (jc,dvdlam) call mxma (dvdlam(2,1),1,4, xlam,1,nxlam, vavg,1,3, 3,nsngt,1) do 450 iuplo = 1,2 fac = .5d0*(3-2*iuplo) call vadd (vavg, fac, delv, pv(1,iuplo), 3) call mcopy (3,nsngt, dvdlam(2,1),1,4, vic(1,iuplo,1),1,6) do 420 j = 1,ins vic(1,iuplo,iis(j)) = vic(1,iuplo,iis(j)) + fac*dvs(1,j) vic(2,iuplo,iis(j)) = vic(2,iuplo,iis(j)) + fac*dvs(2,j) vic(3,iuplo,iis(j)) = vic(3,iuplo,iis(j)) + fac*dvs(3,j) 420 continue do 430 j = 1,ind vic(1,iuplo,iid(j)) = vic(1,iuplo,iid(j)) + fac*dvd(1,j) vic(2,iuplo,iid(j)) = vic(2,iuplo,iid(j)) + fac*dvd(2,j) vic(3,iuplo,iid(j)) = vic(3,iuplo,iid(j)) + fac*dvd(3,j) 430 continue 450 continue go to 610 ! ! ! 610 continue do 650 iuplo = 1,2 call cpcalx (knetul(iuplo),indjc,pv(1,iuplo) & & ,cpv(iuplo), jacob, dcpv(1,iuplo)) if ( .not. prtcp2 ) go to 650 write (6,6004) ibccp2,iuplo,indjc,(pv(i,iuplo),i=1,3) & & ,cpv(iuplo),(dcpv(i,iuplo),i=1,3) 6004 format (' ibccp2',i3,' u/l',i2,' ind',i2,' pv',3f12.6 & & ,' cp',f12.6,' dcp/dv',3f12.6 ) 650 continue ! rhs(ibccp2) = betn - ( cpv(1) - cpv(2) ) if ( .not. jacob ) go to 810 call dcopy (6, dcpv,1, dcpx,1) call dscal (3, -1.d0, dcpx(4),1) call mxma (dcpx,1,1, vic,1,6, aic,1,1, 1,6,nsngu) write (ljac) (aic(j),j=1,nsngu) 810 continue if ( .not.cp2sum ) goto 900 write (6,6005) ibccp2,jc,kc,ifn,jfn,indjc & & ,((pv(i,k),i=1,3),cpv(k),knetul(k),ipnul(k),jpnul(k),k=1,2) 6005 format (1x,i4,i5 ,i4,i4,i4,i2 & & ,2x,3f10.6, f11.6, i4,2i3 & & ,2x,3f10.6, f11.6, i4,2i3 & & ) 6006 format (1x,'nlbc',3x,'jc' ,2x,'nw',1x,'ifn',1x,'jfn',1x,'p' & &,2x,' upper surface: perturbation v cp ',' nw ip jp' & &,2x,' lower surface: perturbation v cp ',' nw ip jp' & & ) 900 continue ! 1000 continue ! ! ! imax = idamax(nbccp2,rhs,1) fcnmax = abs( rhs(imax) ) ! return END subroutine fcncpx ! **deck ffdqg subroutine ffdqg implicit double precision (a-h,o-z) ! * w /skrch3/ scratch s * subpanel normal, used in * ! * computing w-moments * ! * * ! * w1 /pandq/ output doublet potential monopoles * ! * * ! * w2 /pandq/ output doublet potential dipoles * ! * * ! * w4 /pandq/ output doublet potential quadrupoles * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !call frwi common/frwi/nfdq,nsf,nrf,ntf,nref,ninf,nunf !end frwi !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq dimension z(3), enq(3) !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !call cvxerr common /cvxerr/ ncvxer !end cvxerr dimension pft(9), prjen(3,3), dcp(3,4) ! nfdq = locfcn(indrqf) - locfcn(cpfz) call dlocfx (nfdq) call jzero (cpfz,nfdq) ntdk = ntd(kp) sf=sbetam sgxf=sgx(5) ajf = aj(5) rf=iin(5) rfmin = rf call dcopy (3,cp(1,9),1,cpfz,1) call dcopy (9,ar(1,5),1,af,1) call trans(af,aft,3,3) call qcof(ar(1,5),cp,qa) insf = ins indf = ind if ( its.ne.1 .and. its.ne.3 ) insf = 0 if ( its.ne.2 .and. its.ne.3 ) indf = 0 if ( insf.ne.0 ) call xfera (asts,astsf,ncs*insf) ! form qa*astd for FF outer spline ! for std wakes. data is complex for ! type 18/20 wakes in unsteady flow itp = 1 if ( ntdk.eq.18 .or. ntdk.eq.20 ) itp = ityprc ncdtp = ncd*itp do 50 ktp = 1,itp if ( indf.ne.0 ) & & call hsmmp1 (6,ncd,indf, qa,1,6, astd(ktp),itp,ncdtp & & ,astdf(ktp),itp,6*itp) 50 continue if ( ( its.eq.2 .or. its.eq.3 ) .and. indf.le.0 ) go to 100 if ( ( its.eq.1 .or. its.eq.3 ) .and. insf.le.0 ) go to 100 go to 150 ! 100 continue ipk = ipn - npa(kp) call mnmod (ipk, nm(kp)-1, ipan, jpan) write (6,6002) kp, ipan, jpan 6002 format ('0 the panel at nw',i5,', row',i5,', column',i5 & & ,' has been found to have a null spline matrix. ' & &,/, ' check the abutments and abutment intersections in' & &,' the neighborhood of this panel. (its,insf,indf)=',3i4 ) call a502ms('ffdqg','see the description of the problem above') ! 150 continue ! itsf=its icsf=ics nsff = 4 diamf=diam ipnf=ipn kpf=kp call dcopy (12,cp,1,cpf,1) do 300 is=1,4 call unipan(ar(1,5),cp(1,9),cp(1,is),pf(1,is)) z(1)=cp(1,is)-cp(1,9) z(2)=cp(2,is)-cp(2,9) z(3)=cp(3,is)-cp(3,9) call compip(z,z,compd,betams,zbz) zx=z(1)*compd(1)+z(2)*compd(2)+z(3)*compd(3) alis=zx-sqrt(abs(zx*zx-zbz)) if(is.eq.1) al=alis al= min (al,alis) 300 continue pwf(1)=cp(1,9)+al*compd(1) pwf(2)=cp(2,9)+al*compd(2) pwf(3)=cp(3,9)+al*compd(3) pxf = 1.d20 do 350 is=1,4 isp3=mod(is+2,4)+1 if ( is.eq.ics .or. isp3.eq.ics ) go to 320 if ( iin(is) .lt. 0.d0 ) rfmin = -1.d0 320 continue if ( is.eq.ics ) go to 350 pxis=(cp(1,is)-pwf(1))*compd(1)+(cp(2,is)-pwf(2))*compd(2) & &+(cp(3,is)-pwf(3))*compd(3) if(is.eq.1) pxf=pxis pxf= min (pxf,pxis) 350 continue call cnvxhl (pf,nsff,icsf,qcvxhl,kcvxhl) if ( kcvxhl .ne. 0 ) go to 370 ncvxer = ncvxer + 1 ijpan = ipn - npa(kp) call mnmod (ijpan,nm(kp)-1,ipan,jpan) write (6,6001) ncvxer, kp,ipan,jpan 6001 format (' nonconvex panel error. error no.',i4,' nw',i4 & & ,' panel row',i5,' panel column',i5 ) 370 continue call ccaln (p,ics,cf,4,6) aratff = 1.d0 ! compute max distance from panel ! to mean plane ( x(bar) ) qdltf = 0.d0 if ( ics.ne.0 ) go to 650 ! call dcopy (3,en(1,5),1,enq,1) call cscal1 ( 1.d0/betam, enq, 1) call uvect (enq) call cscal1 ( betam, enq, 1) do 640 is = 1,4 dist = enq(1)*( cpf(1,is) - cpfz(1) ) & & + enq(2)*( cpf(2,is) - cpfz(2) ) & & + enq(3)*( cpf(3,is) - cpfz(3) ) qdltf = max ( qdltf, abs(dist) ) 640 continue 650 continue qdltf = qdltf + .01d0*diamf ! calculate rqff, encf and qcminf indrqf = 1 call mxma (ggcpit,1,3, af(3),3,1, encf,1,3, 3,3,1) call uvect (encf) if ( rfmin.lt.0.d0 ) go to 750 call xfera (ggcp,pft,9) go to 780 ! 750 continue do 760 i = 1,3 do 755 j = 1,3 prjen(i,j) = -encf(i)*encf(j) 755 continue prjen(i,i) = 1.d0 + prjen(i,i) 760 continue call mxm (prjen,3,ggcp,3,pft,3) go to 780 ! 780 continue do 790 j = 1,4 dcp(1,j) = cpf(1,j) - cpfz(1) dcp(2,j) = cpf(2,j) - cpfz(2) dcp(3,j) = cpf(3,j) - cpfz(3) 790 continue call mxm (pft,3,dcp,3,rqff,4) ! define iisf and iidf call ifera (iisgp,iisf,insf) call ifera (iidgp,iidf,indf) 950 continue return END subroutine ffdqg ! **deck ffdqgv subroutine ffdqgv implicit double precision (a-h,o-z) !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !call pandfx common /pandfx/ hm(10,6), hbm(2,6,3), bavf(10) & & , hmasts(6,9), hmastd(6,21) !end pandfx !call pandfv common /pandfv/ dvz(9,4), amuxz(3,4), sv1(3,4), dv1(6,4) & & , sv2(3,2,4), dv2(10,2,4) & & , sv8(3,8,4), dv8( 6,8,4) & & , usv(6,4), uvmv(4,6,4), amsv(3,3,4), amdv(3,3,4) & & , lpandv !end pandfv !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call sngval common /sngval/ nsngv, nsolv !end sngval ! equivalence (its,itsv) dimension sval(10), dval(25) dimension sc1(3), dc1(10), uvm(4,6) dimension mi(10), nj(10), fcc(10) dimension x(2) data mi/ 0, 1, 0, 2, 1, 0, 3, 2, 1, 0/ data nj/ 0, 0, 1, 0, 1, 2, 0, 1, 2, 3/ data fcc/ 1.d0,1.d0,1.d0,2.d0,1.d0,2.d0,6.d0,2.d0,2.d0,6.d0/ ! pif = 1.d0/( pi*(3.d0+sf) ) fh = sf*pif ng = 3 nf = 6 ! h moments do 10 ka = 1,10 do 10 kb = 1,6 hm ( ka,kb) = fh *cf( 1+mi(ka)+mi(kb), 1+nj(ka)+nj(kb)) / & & (fcc(ka)*fcc(kb)) 10 continue ! hb moments do 20 ka = 1,6 ! do 20 kb = 1,3 ! hbm(1,ka,kb) = fh *cf( 2+mi(ka)+mi(kb), 1+nj(ka)+nj(kb)) / ! x (fcc(ka)*fcc(kb)) ! hbm(2,ka,kb) = fh *cf( 1+mi(ka)+mi(kb), 2+nj(ka)+nj(kb)) / ! x (fcc(ka)*fcc(kb)) hbm(1,ka,1) = hm(ka,2) hbm(1,ka,2) = hm(ka,4) * 2.d0 hbm(1,ka,3) = hm(ka,5) hbm(2,ka,1) = hm(ka,3) hbm(2,ka,2) = hm(ka,5) hbm(2,ka,3) = hm(ka,6) * 2.d0 20 continue ! ! ! fs = -sf * ajf do 1000 insol = 1,nsolv call xfera (sv1(1,insol),sc1,3) call xfera (dv1(1,insol),dc1,6) do 400 j = 1,6 if(itsv.eq.2)go to 100 xs = ddot (ng,sc1,1,hm(1,j),1) usv(j,insol) = fs*xs uvm(1,j)= ajf*xs ! 100 continue if(itsv.eq.1)go to 400 uvm(2,j) = ddot (nf,dc1,1,hm(1,j),1) uvm(3,j)= dc1(2)*hm(1,j) + dc1(4)*hm(2,j) + dc1(5)*hm(3,j) uvm(4,j)= dc1(3)*hm(1,j) + dc1(5)*hm(2,j) + dc1(6)*hm(3,j) if ( nf.eq.6 ) go to 400 uvm(3,j)= uvm(3,j) + & & dc1(7)*hm(4,j) + dc1(8)*hm(5,j) + dc1( 9)*hm(6,j) uvm(4,j)= uvm(4,j) + & & dc1(8)*hm(4,j) + dc1(9)*hm(5,j) + dc1(10)*hm(6,j) 400 continue ! rs = rf*sf f1 = -ajf*rs f2 = -ajf do 500 j = 1,3 if(itsv.eq.1)go to 550 fac = dc1(2)*hbm(1,1,j)+dc1(4)*hbm(1,2,j)+dc1(5)*hbm(1,3,j) & & +dc1(3)*hbm(2,1,j)+dc1(5)*hbm(2,2,j)+dc1(6)*hbm(2,3,j) if ( nf.eq.10 ) fac = fac + & & dc1(7)*hbm(1,4,j)+dc1(8)*hbm(1,5,j)+dc1( 9)*hbm(1,6,j) & & +dc1(8)*hbm(2,4,j)+dc1(9)*hbm(2,5,j)+dc1(10)*hbm(2,6,j) call vmul (aft(7),fac,amdv(1,j,insol),3) ! 550 continue if(itsv.eq.2)go to 500 x(1) = ddot (ng,sc1,1,hbm(1,1,j),2) x(2) = ddot (ng,sc1,1,hbm(2,1,j),2) x(1) = f1*x(1) x(2) = f2*x(2) call mxma (aft,1,3 ,x,1,2 ,amsv(1,j,insol),1,3 ,3,2,1) 500 continue call xfera (uvm,uvmv(1,1,insol),24) 1000 continue return END subroutine ffdqgv ! **deck ffdqgx subroutine ffdqgx (indpbl) implicit double precision (a-h,o-z) !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !call pandfx common /pandfx/ hm(10,6), hbm(2,6,3), bavf(10) & & , hmasts(6,9), hmastd(6,21) !end pandfx !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf dimension mi(10), nj(10), fcc(10) logical astcpx data mi/ 0, 1, 0, 2, 1, 0, 3, 2, 1, 0/ data nj/ 0, 0, 1, 0, 1, 2, 0, 1, 2, 3/ data fcc/ 1.d0,1.d0,1.d0,2.d0,1.d0,2.d0,6.d0,2.d0,2.d0,6.d0/ ! pif = 1.d0/( pi*(3.d0+sf) ) fh = sf*pif ! h moments do 10 ka = 1,10 do 10 kb = 1,6 hm ( ka,kb) = fh *cf( 1+mi(ka)+mi(kb), 1+nj(ka)+nj(kb)) / & & (fcc(ka)*fcc(kb)) 10 continue ! hb moments do 20 ka = 1,6 ! do 20 kb = 1,3 ! hbm(1,ka,kb) = fh *cf( 2+mi(ka)+mi(kb), 1+nj(ka)+nj(kb)) / ! x (fcc(ka)*fcc(kb)) ! hbm(2,ka,kb) = fh *cf( 1+mi(ka)+mi(kb), 2+nj(ka)+nj(kb)) / ! x (fcc(ka)*fcc(kb)) hbm(1,ka,1) = hm(ka,2) hbm(1,ka,2) = hm(ka,4) * 2.d0 hbm(1,ka,3) = hm(ka,5) hbm(2,ka,1) = hm(ka,3) hbm(2,ka,2) = hm(ka,5) hbm(2,ka,3) = hm(ka,6) * 2.d0 20 continue ! average values for cubic basis fcns. do 30 ka = 1,10 bavf(ka)= cf( 1+mi(ka), 1+nj(ka) ) / ( fcc(ka)*cf(1,1) ) 30 continue ! unstdy wake nw's have complex splines astcpx = .false. !-- if ( ntd(kpf).eq.8 .or. ntd(kpf).eq.10 .or. !-- x ntd(kpf).eq.18 .or. ntd(kpf).eq.20 ) astcpx = .true. if ( astcpx ) goto 50 ! build hmasts, hmastd phic moments ! where the spline data is real call hsmmp1 (6,3,insf ,hm,10,1 ,astsf,1,3 ,hmasts,1,6) call hsmmp1 (6,6,indf ,hm,10,1 ,astdf,1,6 ,hmastd,1,6) goto 70 ! build hmasts, hmastd phic moments ! where the spline data is complex 50 continue if ( 2*insf.gt.9 .or. 2*indf.gt.21 ) call a502er ('ffdqgx' & & ,' overflow of complex spline data, /pandfx/' ) call rcmmp1 (6,3,insf ,hm,10,1 ,astsf,1,3 ,hmasts,1,6) call rcmmp1 (6,6,indf ,hm,10,1 ,astdf,1,6 ,hmastd,1,6) goto 70 ! 70 continue ! return END subroutine ffdqgx ! **deck ffgen subroutine ffgen (nedaba,kfdseg,kfdkey,kfdsgn,nedmpa & & ,tauemp,iskmp,scr) implicit double precision (a-h,o-z) character msg*8 !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call bcon common /bcon/ & & cu1,cl1,tu1(3),tl1(3),du1,dl1,bet1(4),nct1,nlopt1,nropt1,necpt1 & & ,klopt1,kldum1,betin1(4) & & ,cu2,cl2,tu2(3),tl2(3),du2,dl2,bet2(4),nct2,nlopt2,nropt2,necpt2 & & ,klopt2,kldum2,betin2(4) & & ,ndbcon !end bcon !call cntrq common /cntrq/ zc(3), znc(3), zdc, tauc & & , ipc, icc, jcn, kc, jzc, kabmtc, kfsgc, ijfgc & & , nbinmc, idcpmc, nec & & , npnmtc, ipnmtc(10) & & , ndcntq !end cntrq !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !call irwi common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21) !end irwi !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call gsqrwi parameter (npagpx=400) common /gsqrwi/ nsqg, npagp, npngrp(npagpx), nspgrp(npagpx) & & , ndsgrp, nptgrp(npagpx) !end gsqrwi !call hsqrwi common /hsqrwi/ nsqh !end hsqrwi !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !call solnt common/solnt/naic,nrhs,nans,nsc1,nsc2,nsc3,nsc4,iray(10),mtitle(5) !end solnt !ca locinf ! /locinf/ common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i double precision rlocdm !end locinf !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt ! ! FORMAL PARAMETER DECLARATIONS ! dimension nedaba(mxnabt+1), kfdseg(4*mxfdsg) & & , kfdkey(mxfdsg), kfdsgn(mxfdsg) & & , nedmpa(4*mxnett+1), tauemp(mxempt) dimension scr(200,28) dimension iskmp(mxsngt) ! !call mspnts common/mspnts/zm(3,maxpts) !end mspnts !call iduser character*10 iduser common /iduser/ iduser(150) !end iduser !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf !call compsp ! /compsp/ ! contains info relating mu on edges 2 or 4 of ntdk=6 nw's ! to panel interior values common /compsp/ bpsp(6,200,2) & & , kntpsp, npsp(200,2), kkpsp(200,2), iipsp(6,200,2) !end compsp !call ffgedg ! /ffgedg/ common /ffgedg/ lokseg, ledseg, i1lseg, i2lseg !end ffgedg dimension ipnmts(10), mtched(1), zch(3) integer pplcnt ! ! ! call xtrns (16,nedaba,nx16) call xtrns ( 7,kfdseg,nx7) nfdseg = nx7/4 call xtrns ( 5,kfdkey,nx5) call xtrns ( 6,kfdsgn,nx6) call xtrns ( 9,nedmpa,nx9) call xtrns (13,tauemp,nx13) nedmp = nx13/kklr2i call xtrns (37,iskmp,nsngn) !--- call outvec ('iskmp',nsngn,iskmp) ! put in final sp indices in the psp ! (provisional singularity parameters ! associated w edges 2 and 4 of type 6 do 600 knet = 1,nnett if ( ntd(knet).ne.6 ) goto 600 m = nm(knet) nw = m*28 call ytrns (knet,scr,nw) call upkpsp (200,m, npsp,kkpsp,iipsp,bpsp, 200*28,scr) do 310 jx = 1,2 do 300 i = 1,m lnaif = kkpsp(i,jx) lfinal = iskmp(lnaif) kkpsp(i,jx) = lfinal nk = npsp(i,jx) do 250 k = 1,nk lnaif = iipsp(k,i,jx) lfinal = iskmp(lnaif) iipsp(k,i,jx) = lfinal 250 continue 300 continue 310 continue call pakpsp (200,m, npsp,kkpsp,iipsp,bpsp, 200*28,scr) call iytrns (knet,scr,nw) 600 continue do 950 ip = 1,npant !c ! * retrieve panel defining quantities * ! call strns(ip,cp) if(its.eq.2) go to 925 do 920 ic=1,ins is=iis(ic) is=iskmp(is) isa=iabs(is) iis(ic) = isa if(is.ge.0) go to 920 do 918 i=1,ncs ll = i + ncs*(ic-1) 918 asts(ll) = -asts(ll) 920 continue call scmpkt(asts,iis,ncs,ins) 925 if(its.eq.1) go to 935 if ( ntd(kp).ne.18 .and. ntd(kp).ne.20 ) goto 927 ! for standard wakes, spline matrices a ! complex and must be treated different do 926 ic = 1,ind is = iid(ic) is = iskmp(is) isa = iabs(is) iid(ic) = isa if ( is.ge.0 ) goto 926 ll = 1 + ncd*ityprc*(ic-1) call dscal (ityprc*ncd, -1.d0, astd(ll),1) 926 continue call scmpkt (astd,iid,ityprc*ncd,ind) goto 935 ! ordinary (real) doublet splines 927 continue do 930 ic=1,ind is=iid(ic) is=iskmp(is) isa=iabs(is) iid(ic) = isa if(is.ge.0) go to 930 do 928 i=1,ncd ll = i + ncd*(ic-1) 928 astd(ll) = -astd(ll) 930 continue call scmpkt(astd,iid,ncd,ind) if ( inmux.le.0 ) goto 933 do 932 ic = 1,inmux is = iskmp( iimux(ic) ) isa = iabs(is) iimux(ic) = isa if ( is.lt.0 ) call dscal (3, -1.d0, astmux(1,ic),1) 932 continue ijpan = ipn - npa(kp) call mnmod (ijpan,nm(kp)-1,ipan,jpan) !== write (6,'('' ffgen, astmux construction'',3i6)')kp,ipan,jpan != call outvci ('iid',ind,iid) != call outmtx ('astd',9,9,ind,astd) != call outvci ('iimux',inmux,iimux) != call outmtx ('astmux',3,3,inmux,astmux) 933 continue ntdk = ntd(kp) knet = kp if ( ntdk.eq.18 .or. ntdk.eq.20 ) then if ( iextrp.ge.2 ) then write (6,'( '' ===ffgen, k,ipn,nt '',4i6)' ) knet,ipn,ntdk call outvci ('iid',ind,iid) call outmat ('astd',9,9,ind,astd) endif endif 935 continue call ffdqg call istrns (ip,cp) 940 continue 950 continue ! ! mtcher = 0 do 1200 jcx = 1,nctrt call ctrns (jcx,zc) jc = jcn ne = nec mtched(1) = 0 iszc = 1 npnmts = 0 call jzero (ipnmts,10) if ( nbinmc.eq.0 ) go to 1000 if ( iedgep.ge.2 ) & &write (6,'(1x,a10,1x, 5i12)') & & '==jcx==',jcx,jc,ne,nbinmc,kabmtc ! matching condition iabt = iabs( kabmtc ) iedg1 = nedaba(iabt) + 1 iedg2 = nedaba(iabt+1) do 980 iedg = iedg1,iedg2 ifsg = kfdkey(iedg) call icopy (4, kfdseg(4*ifsg-3),1, lokseg,1) call mnmod (ledseg,4,lsd,lnet) kpf = lnet kntpan = nm(kpf) - 1 if ( lsd.eq.1 .or. lsd.eq.3 ) kntpan = nn(kpf) - 1 lzk = nza(kpf) + 1 ! if ( iedgep.ge.2) & &write (6,'(1x,a10,1x, 9i12)') & & 'knet,ksd',kpf,lsd,nm(kpf),nn(kpf),kntpan,lzk & & ,kabmtc,iedg,ifsg nceivc = 1 960 continue mtchin = mtched(1) do 970 intpan = 1,kntpan call edpang (zm(1,lzk),nm(kpf),nn(kpf),lsd,intpan,cpf,ipnf,diamf) ipnf = ipnf + npa(kpf) call eivc (mtched,npnmts,ipnmts,nceivc & & ,nedaba,kfdseg,kfdkey,kfdsgn,nedmpa,tauemp & & ) 970 continue mtcho = mtched(1) if ( mtchin.ne.mtcho ) go to 975 if ( nceivc.gt.1 ) go to 975 nceivc = nceivc + 1 nedg = iedg2 - iedg1 + 1 write (6,6701) jcx,jc,nedg,iedg,mtchin,mtcho,kpf,kntpan,zc 6701 format ('0======== bad match, rerun with scan flag ======' & & ,/,' jcx,jc ',2i7,' nedg,iedg ',2i5 & & ,/,' mtchin,out ',2i7,' kpf,kntpan',2i5 & & ,/,' zc ',3f12.6 ) go to 960 975 continue ! 980 continue ! 1000 continue npnmtc = npnmts call ifera (ipnmts,ipnmtc,10) if ( nbinmc.eq.0 ) go to 1040 if ( kabmtc.eq.0 ) go to 1040 iabt = iabs(kabmtc) nedg = nedaba(iabt+1) - nedaba(iabt) nedgx = pplcnt( mtched(iszc) ) msg = ' ' if ( nedg.ne.nedgx ) msg = 'mtch err' if ( nedg.eq.nedgx ) go to 1040 mtcher = mtcher + 1 write (6,6109) jcn,kabmtc,nedg,nedgx,mtched(iszc),msg 6109 format (' cp,abut,nedg,nedgx,mtched',5i6,a8) 1040 continue if ( nbinmc.eq.0 .or. iedgep.eq.0 ) go to 1100 ! print matching data call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn) call enrchg (kc,ifn,jfn,zch) write (6,6120) jc,kc,ifn,jfn,(zch(i),i=1,3) 6120 format ('0matching at jc',i4,' nw',i4,' ifn,jfn',2i4 & & ,' zch',3f12.6) do 1050 ipx = 1,npnmtc ipndat = ipnmtc(ipx) isgn = isign(1,ipndat) ipndat = iabs(ipndat) call mnmod (ipndat,4,ksd,ipanel) do 1045 k = 1,nnett knet = k if ( ipanel.le.npa(k+1) ) go to 1046 1045 continue 1046 continue ijpan = ipanel - npa(knet) call mnmod (ijpan,nm(knet)-1,ipan,jpan) write(6,6130)isgn,knet,ipanel,ipan,jpan,ksd,iduser(knet) 6130 format (' sign',i4,' nw',i4,' panel',i6 & & ,' ipan',i4,' jpan',i4,' side',i2,2x,a) 1050 continue 1100 continue ! call ictrns (jcx,zc) 1200 continue if ( mtcher.gt.0 ) call a502er ('ffgen' & & ,'not all matching conditions found. q.v.') return END subroutine ffgen ! **deck ffpic subroutine ffpic (zp,iflu,ne,nf,dvs,dvd) implicit double precision (a-h,o-z) dimension dvs(4,6), dvd(4,10) dimension & & pl(3), h(10), g(6), hb(2,6), zh(10) & & , gk(6), hk(6), pc(3) dimension zp(3) ! !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs equivalence (pcm,p1) !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf !call pandfx common /pandfx/ hm(10,6), hbm(2,6,3), bavf(10) & & , hmasts(6,9), hmastd(6,21) !end pandfx !call dsnpic common /dsnicr/ phsdsn(6), vsdsn(3,6), phxdsn(3,4), phydsn(3,4) common /dsnicl/ dsnic logical dsnic !end dsnpic dimension vs(3,10) ! equivalence (x,pl(1)), (y,pl(2)), (z,pl(3)) ! integer nt(0:3) data nt/0,1,3,6/ ! initialization pc(1) = zp(1) - cpfz(1) pc(2) = zp(2) - cpfz(2) pc(3) = zp(3) - cpfz(3) ! x = af(1)*pc(1) + af(4)*pc(2) + af(7)*pc(3) y = af(2)*pc(1) + af(5)*pc(2) + af(8)*pc(3) z = af(3)*pc(1) + af(6)*pc(2) + af(9)*pc(3) ! p1 = 1.d0 / sqrt( rf*x*x + sf*y*y + rf*sf*z*z ) p2 = p1*p1 p3 = p2*p1 ! fs = -ajf * sf ! ng = (3,6) as nf = (6,10) ng = 3*( 1 + nf/10 ) ! set processing flags nex = ne ngx = ng itsx = itsf if ( dsnic ) then nex = max(ne,1) !------ nex = 4 ; phxdsn ngx = 6 if ( mod(itsx,2).eq.0 ) itsx = itsx+1 endif ! yp = y*p1*sf xp = x*p1*rf ! compute kernel moments if ( iflu - 2 ) 210,220,240 ! quadrupole 240 continue p5t3 = 3.d0*p2*p3 hk(4) = p5t3 * (5.d0*xp*xp - rf) hk(5) = p5t3 * 5.d0*xp*yp hk(6) = p5t3 * (5.d0*yp*yp - sf) ! if ( itsx.eq.2 ) goto 220 gk(4) = fs * p3 * (3.d0*xp*xp- rf ) gk(5) = fs * p3 * 3.d0*xp*yp gk(6) = fs * p3 * (3.d0*yp*yp- sf ) ! dipole 220 continue p4t3 = 3.d0*p2*p2 hk(2) = p4t3*xp hk(3) = p4t3*yp ! if ( itsx.eq.2 ) goto 210 gk(2) = fs * p2 * xp gk(3) = fs * p2 * yp ! monopole 210 continue hk(1) = p3 gk(1) = fs * p1 ! kernel moments ready, go. if ( nex.gt.1 ) go to 500 ! potential alone if ( itsx.ne.2 ) then call mxma (hm,1,10 ,gk,1,nt(iflu) ,phsdsn,1,ng ,ng,nt(iflu),1) if ( itsf.ne.2 ) call dcopy (ng, phsdsn,1, dvs,1) endif if ( itsf.eq.1 ) go to 950 call mxma (hm,1,10 ,hk,1,nt(iflu) ,h,1,nf & & ,nf,nt(iflu),1) call vmul (h,z,dvd,nf) go to 950 ! potential and velocity 500 continue ! get h integrals nh = max( nf, ngx) if ( itsx.eq.1 ) nh = ngx call mxma (hm,1,10 ,hk,1,nt(iflu) ,h,1,nh & & ,nh,nt(iflu),1) ! get hb integrals if ( iflu.eq.1 ) then call zero (hb,2*ngx) else call mxma (hbm,1,12 ,hk,1,nt(iflu-1) ,hb,1,2*ngx & & ,2*ngx,nt(iflu-1),1) endif ! do 550 k1 = 1,ngx hb(1,k1) = hb(1,k1) - x*h(k1) hb(2,k1) = hb(2,k1) - y*h(k1) 550 continue if (itsx.eq.2) go to 700 ! source aic"s call mxma (hm,1,10 ,gk,1,nt(iflu) ,g,1,ngx & & ,ngx,nt(iflu),1) ajrs = ajf*rf*sf ajrz = ajf * rf * z do 600 j = 1,ngx phsdsn(j) = g(j) vs(1,j) = -ajrs*hb(1,j) vs(2,j) = -ajf*hb(2,j) vs(3,j) = ajrz* h(j) 600 continue call hsmmp1 (3,3,ngx, aft,1,3, vs,1,3, vsdsn,1,3) ! transform dvs to global if (itsf.eq.2) goto 700 if ( ne.eq.1 ) then call dcopy (ng, phsdsn,1, dvs,ne) else do 650 j = 1,ng dvs(1,j) = phsdsn(j) dvs(2,j) = vsdsn(1,j) dvs(3,j) = vsdsn(2,j) dvs(4,j) = vsdsn(3,j) 650 continue endif if ( itsf.eq.1 ) go to 950 ! doublet aic"s 700 continue if ( ne.eq.4 ) goto 750 ! potential alone (nex=4, ne=1) call vmul (h,z,dvd,nf) goto 950 ! potential and velocity (ne=4) 750 continue call vmul (h,z,zh,nf) dvd(1, 1) = zh(1) dvd(1, 2) = zh(2) dvd(1, 3) = zh(3) dvd(1, 4) = zh(4) dvd(1, 5) = zh(5) dvd(1, 6) = zh(6) ! dvd(2, 1) = 0.d0 dvd(2, 2) = zh(1) dvd(2, 3) = 0.d0 dvd(2, 4) = zh(2) dvd(2, 5) = zh(3) dvd(2, 6) = 0.d0 ! dvd(3, 1) = 0.d0 dvd(3, 2) = 0.d0 dvd(3, 3) = zh(1) dvd(3, 4) = 0.d0 dvd(3, 5) = zh(2) dvd(3, 6) = zh(3) ! dvd(4, 1) = 0.d0 dvd(4,2) = hb(1,1) dvd(4,3) = hb(2,1) dvd(4,4) = hb(1,2) dvd(4,5) = hb(1,3) + hb(2,2) dvd(4,6) = hb(2,3) ! if ( nf.eq.6 ) go to 800 ! cubic doublet terms dvd(1, 7) = zh( 7) dvd(1, 8) = zh( 8) dvd(1, 9) = zh( 9) dvd(1,10) = zh(10) ! dvd(2, 7) = zh( 4) dvd(2, 8) = zh( 5) dvd(2, 9) = zh( 6) dvd(2,10) = 0.d0 ! dvd(3,7 ) = 0.d0 dvd(3,8 ) = zh(4 ) dvd(3,9 ) = zh(5 ) dvd(3,10) = zh(6 ) ! dvd(4,7) = hb(1,4) dvd(4,8) = hb(1,5) + hb(2,4) dvd(4,9) = hb(1,6) + hb(2,5) dvd(4,10) = hb(2,6) ! ! transform dvd to global 800 continue do 1200 j = 2,nf c11 = aft(1)*dvd(2,j) + aft(4)*dvd(3,j) + aft(7)*dvd(4,j) c21 = aft(2)*dvd(2,j) + aft(5)*dvd(3,j) + aft(8)*dvd(4,j) c31 = aft(3)*dvd(2,j) + aft(6)*dvd(3,j) + aft(9)*dvd(4,j) dvd(2,j) = c11 dvd(3,j) = c21 dvd(4,j) = c31 1200 continue ! return 950 continue return END subroutine ffpic ! **deck ffpiv subroutine ffpiv (ivzp,zp,iflu,vphx) implicit double precision (a-h,o-z) dimension vph(8),zp(3),vphx(4) ! dimension hk(6), pl(3), pc(3), xs(3), xd(3) ! !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call pandf common /pandf/ cpfz(3),cpf(3,16),astsf(216),astdf(600),pf(3,16) & & , qcvxhl(2,16) & & , qlf(3,17), zxyf(2,17), b1234f(10,17) & & , af(9), aft(9), ajf, sf, rf, rfmin, qdltf, aratff & & , cf(6,6), pwf(3), pxf, diamf, sgxf & & , iisf(36), iidf(60), indf, insf, itsf, icsf, ipnf & & , kpf, nsff & & , indrqf, rqff(3,16), encf(3), qcminf !end pandf !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call pandfv common /pandfv/ dvz(9,4), amuxz(3,4), sv1(3,4), dv1(6,4) & & , sv2(3,2,4), dv2(10,2,4) & & , sv8(3,8,4), dv8( 6,8,4) & & , usv(6,4), uvmv(4,6,4), amsv(3,3,4), amdv(3,3,4) & & , lpandv !end pandfv dimension us(6), uvm(4,6), ams(3,3), amd(3,3) ! equivalence (x,pl(1)), (y,pl(2)), (z,pl(3)) ! dimension uv(4) equivalence (uv(1),vsx) & & ,(uv(2),udx) & & ,(uv(3),vd1) & & ,(uv(4),vd2) ! integer nuv(3), lf(3) ! integer ntz(4), nt(3) equivalence (nt,ntz(2)) ! data ntz/0,1,3,6/ data nuv/1,3,4/, lf/1,2,1/ ! initialization call xfera (usv(1,ivzp),us,6) call xfera (uvmv(1,1,ivzp),uvm,24) call xfera (amsv(1,1,ivzp),ams,9) call xfera (amdv(1,1,ivzp),amd,9) call zero(vph,8) pc(1) = zp(1) - cpfz(1) pc(2) = zp(2) - cpfz(2) pc(3) = zp(3) - cpfz(3) ! x = af(1)*pc(1) + af(4)*pc(2) + af(7)*pc(3) y = af(2)*pc(1) + af(5)*pc(2) + af(8)*pc(3) z = af(3)*pc(1) + af(6)*pc(2) + af(9)*pc(3) ! p1 = sqrt( rf*x*x + sf*y*y + rf*sf*z*z ) if ( p1.eq.0.d0 ) write (6,'(1x,a10,1x, 8f12.6)') & & 'ffpiv',rf,sf & & ,cpfz(1),cpfz(2),cpfz(3),pc(1),pc(2),pc(3) if ( p1.eq.0.d0 ) call outmat (' ',3,3,3,af) if ( p1.eq.0.d0 ) call a502er ('ffpiv' & & ,' divide check in ffpiv ') p1 = 1.d0/p1 p2 = p1*p1 p3 = p2*p1 ! yp = y*p1*sf xp = x*p1*rf rs = rf*sf ! phs = 0.d0 ! compute kernel moments if ( iflu - 2 ) 210,220,240 ! quadrupole 240 continue p5 = p2*p3 hk(4) = p5 *(15.d0*xp*xp-3.d0*rf) hk(5) = p5 * 15.d0*xp*yp hk(6) = p5 *(15.d0*yp*yp-3.d0*sf) ! if ( itsf.eq.2 ) go to 220 phs = p3*( us(4) * (3.d0*xp*xp-rf) & & + us(5) * 3.d0*xp*yp & & + us(6) * (3.d0*yp*yp-sf) ) ! dipole 220 continue p4 = p2*p2 hk(2) = p4 * 3.d0*xp hk(3) = p4 * 3.d0*yp ! if (itsf.ne.2) phs = phs + p2*(us(2)*xp+us(3)*yp) ! monopole 210 continue hk(1) = p3 if ( itsf.ne.2 ) & &phs = phs + p1*us(1) ! kernel moments ready, go. 500 continue call mxma (uvm(lf(itsf),1),1,4 ,hk,1,nt(iflu) & & ,uv(lf(itsf)),1,nuv(itsf) ,nuv(itsf),nt(iflu),1) if ( itsf.eq.2 ) go to 600 ! source vph(1) = phs ! xs(1) = x*rs*vsx xs(2) = y *vsx xs(3) = z*rf*vsx ! vph(2) = aft(1)*xs(1) + aft(4)*xs(2) + aft(7)*xs(3) vph(3) = aft(2)*xs(1) + aft(5)*xs(2) + aft(8)*xs(3) vph(4) = aft(3)*xs(1) + aft(6)*xs(2) + aft(9)*xs(3) ! if ( iflu.eq.1 ) go to 600 vph(2) = vph(2) + ams(1,1)*hk(1) vph(3) = vph(3) + ams(2,1)*hk(1) vph(4) = vph(4) + ams(3,1)*hk(1) if ( iflu.eq.2 ) go to 600 vph(2) = vph(2) + ams(1,2)*hk(2) + ams(1,3)*hk(3) vph(3) = vph(3) + ams(2,2)*hk(2) + ams(2,3)*hk(3) vph(4) = vph(4) + ams(3,2)*hk(2) + ams(3,3)*hk(3) ! 600 continue if ( itsf.eq.1 ) go to 700 ! doublet vph(5) = z*udx ! xd(1) = z*vd1 xd(2) = z*vd2 xd(3) = -x*vd1 - y*vd2 ! vph(6) = aft(1)*xd(1) + aft(4)*xd(2) + aft(7)*xd(3) vph(7) = aft(2)*xd(1) + aft(5)*xd(2) + aft(8)*xd(3) vph(8) = aft(3)*xd(1) + aft(6)*xd(2) + aft(9)*xd(3) ! if ( iflu.eq.1 ) go to 700 vph(6) = vph(6) + amd(1,1)*hk(1) vph(7) = vph(7) + amd(2,1)*hk(1) vph(8) = vph(8) + amd(3,1)*hk(1) if ( iflu.eq.2 ) go to 700 vph(6) = vph(6) + amd(1,2)*hk(2) + amd(1,3)*hk(3) vph(7) = vph(7) + amd(2,2)*hk(2) + amd(2,3)*hk(3) vph(8) = vph(8) + amd(3,2)*hk(2) + amd(3,3)*hk(3) ! return 700 continue do 800 i = 1,4 800 vphx(i) = vph(i) + vph(i+4) return END subroutine ffpiv ! **deck fhybrj subroutine fhybrj (n,x,f,lunaj,naj,iflag & & ,dvdl,vica,vicd,aic & & ,alam,fv,dldx,dfdl,aj & & ,nsngtp,sols) implicit double precision (a-h,o-z) dimension x(n), f(n) ! local scratch dimension dvdl(4,*), vica(3,*), vicd(3,*), aic(*) parameter (nb=20) dimension alam(*), fv(n), dldx(n), dfdl(nb,*), aj(nb,*) dimension sols(nsngtp,4) ! ! function box for a nonlinear equation solver used to impose ! cp(2nd order) and cp(isentropic) matching conditions. these ! conditions are typically applied along wake leading edges ! and in wake design (type 6) networks. ! ! n i int dimension of n.l. fcn to be driven to zero ! x i r*8 function argument vector ! f o r*8 function value, pressure diff's at req'd c.p ! lunaj i int unit to which the jacobian is written, 1 rec ! naj i int row dimension for jacobian, if routine chang ! iflag i int use 1 for fcn only, 2 for fcn+jacobian ! ----- scratch storage for fhybrj ------ ! dvdl s r*8 dvdl(4,nsngt) = output array for fcncpx' ! call to vtrns ! vica s r*8 vica(3,nsngt) = scratch array for v/avg ! influence coefficients, fcncpx ! vicd s r*8 vicd(3,nsngt) = scratch array for v/dif ! influence coefficients, fcncpx ! aic s r*8 used for d( f(i) )/d( lambda ), the sensitiv ! of one component of the residual vector w.r. ! lambda, in fcncpx ! alam s r*8 alam(nsngt) = scratch array for current est. ! of 'lambda', the singularity vector ! fv s r*8 fcncpx result vector, nonlinear residuals ! dldx s r*8 dldx(n), used for the sensitivity of the ! entries of lambda w.r.t. the unknowns for ! the nonlinear problem ! dfdl s r*8 dfdl(nb,nsngu): block of sensitivities of ! of 'f' w.r.t. the lambda[unknown] ! aj s r*8 aj(nb,n): block of sensitivities of 'f' ! w.r.t. the unknowns for the nonlinear proble ! ! file activity: ! lunaj w output file containing the jacobian matrix, if req ! file is a readms/writms file with data stored one ! per record. ! lans r input file containing the results of the linear so ! process: beyond the first nacase+1 positions, the ! dependency of each entry in lambda upon the canoni ! parameters x(1:n) of the nonlinear iteration. ! ! michael epton, 30 november 1988 ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits dimension ans(4) !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call cp2mcd ! /cp2mcd/: common region for list of all cp(second order) b.c.' ! jcncp2 = list of control points ! irwcp2 = list of aic rows ! inacp2 = list of corresponding entries in idcp2(1:3 parameter (maxcp2=1000) common /cp2mcd/ nbccp2, jcncp2(maxcp2), irwcp2(maxcp2) & & , inacp2(maxcp2) !end cp2mcd !call cp2aul ! /cp2aul/ = index for abutments having a cp(2nd order) ! matching condition. common /cp2aul/ ncp2ab, idcp2(3,50) & & , ablcp2(50), keycp2(50) integer ablcp2 !end cp2aul ! !call chybrj ! /chybrj/ ! unit numbers and scratch memory addresses in sinver common /chybrj/ ljac, ljly, lans & & , lldvdl, llvica, llvicd, llaic !end chybrj !call cp2flg ! /cp2flg/: newton iteration, lambda print and cp2 print flags common /cp2flg/ istcp2, iexcp2, nitcp2 !end cp2flg !call cjacnm common /cjacnm/ ajacnm !end cjacnm ! dimension fmax(4) logical jacob, prtcp2, cp2sum ! data ncall /0/ ! ! ! ncall = ncall + 1 if ( istcp2.ge.4 ) write (6,'(1x,a10,1x, 3i12)') & & 'fhybrj in',ncall,iflag,iacase ! form the lambda vector (alam) corresp ! to the current value of the n-vector rewind lans do 100 i = 1,nsngu read (lans) (ans(j),j=1,nacase),ansx,(dldx(j),j=1,n) alam(i) = ans(iacase) + ddot(n, dldx,1, x,1) 100 continue ! put the known s.p.'s for case iacase ! the current estimate of lambda (alam) call dcopy (nsngk, sols(nsngu+1,iacase),1, alam(nsngu+1),1) ! set processing flags req'd by fcncpx jacob = iflag.ge.2 prtcp2 = iexcp2.gt.1 cp2sum = istcp2.ge.3 call fcncpx (nsngt,alam, dvdl,vica,aic & & ,fv,fmax, ljac,jacob,prtcp2,cp2sum) ! if ( istcp2.ge.4 ) write (6,'(1x,a10,1x, 1pe12.4)') & & '++fmax++',fmax call dscal (n, -1.d0, fv,1) !---- if ( ncall.le.2 ) call outvcx ('alam',nsngt,alam) !---- call outvcx ('f(x)',n,fv) !---- call outvcx (' x ',n,x) ! if ( iflag.ne.2 ) call dcopy (n, fv,1, f,1) if ( .not. jacob ) go to 900 ! ! form the product: ! ! ( df/dlam ) * ( dlam/dx ) ! n x nsngu nsngu x n ! unit ljac unit lans ! by rows by rows ! rewind ljac ! for each block of nb rows in ( df/dla ! read that block into the array 'dfdl' ! and accumulate: ! ! aj <-- aj + ( df/dlam ) ( i1:i2, j) * ( dlam/dx ) ( j, 1:n) ! ajacnm = 1.d-6 do 200 i1 = 1,n,nb call dcopy (nb*n, 0.d0,0, aj,1) i2 = min( n, i1 + nb - 1) ni = i2 - i1 + 1 do 140 i = i1,i2 read (ljac) (alam(k),k=1,nsngu) call dcopy (nsngu, alam,1, dfdl(i-i1+1,1),nb) 140 continue rewind lans do 160 j = 1,nsngu read (lans) (ans(k),k=1,nacase),ansx,(dldx(k),k=1,n) call hsmmp2 (ni,1,n, dfdl(1,j),1,nb, dldx,1,1 & & ,aj,1,nb) 160 continue ! put current block of rows out to luna do 180 i = i1,i2 call dcopy (n, aj(i-i1+1,1),nb, fv,1) call writmd (lunaj,fv,n,i,-1,0) ajnm = 0.d0 do 170 jj = 1,n ajnm = ajnm + abs(fv(jj)) 170 continue ajacnm = max ( ajnm, ajacnm) 180 continue 200 continue ! 900 continue return END subroutine fhybrj ! **deck flgcor subroutine flgcor (l1,l2,l3) logical l1,l2,l3 !call dynmap ! /dynmap/ parameter (nlev=15) parameter (nlws=200) common /dynmap/ realth, intlth, nrl2in & & , levdyn, lwsdyn & & , levprt, lwsprt, sumprt & & , maxdyn, maxlev, maxlws & & , mxxdyn, mxxlev, mxxlws & & , llwstg, llmplv, llmlws & & , incrdf, npadio & & , maplev(3,nlev), maplws(3,nlws) double precision realth logical levprt, lwsprt, sumprt ! common /dynchr/ iniset, chrlev(nlev), chrlws(nlws) character*8 iniset, chrlev, chrlws !end dynmap levprt = l1 lwsprt = l2 sumprt = l3 return END subroutine flgcor ! **deck flow subroutine flow implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to guide flow of computations from input to output inclusive.* ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * flow calls overlays to read input, compute panel geometry * ! * defining quantities, compute singularity defining quantities,* ! * compute control point defining quantities, analyze boundary * ! * conditions, compute potential and velocity influence * ! * coefficients, compute boundary value problem left hand side * ! * influence coefficient and right hand side matrices, solve * ! * problem matrix equation, and calculate and print output. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * aarg -local- - - - - angle of attack (radians) * ! * current case * ! * * ! * abetms /comprs/ -local- absolute value of betams * ! * * ! * alpc /comprs/ -local- compressibility direction * ! * angle of attack * ! * * ! * alpha /acase/ -local- angles of attack * ! * * ! * amach /acase/ -local- freestream mach number * ! * * ! * arotc /comprs/ -local- orthogonal matrix transforming* ! * global coordinates to fluid * ! * axis coordinates * ! * * ! * arotci /comprs/ -local- inverse of arotc * ! * * ! * barg -local- - - - - angle of sideslip (radians) * ! * * ! * beta /acase/ -local- angles of sideslip * ! * * ! * betam /comprs/ -local- square root of abetms * ! * * ! * betams /comprs/ -local- 1.-(freestream mach number)**2* ! * * ! * betc /comprs/ -local- compressibility direction * ! * angle of sideslip * ! * * ! * compd /comprs/ -local- compressibility direction * ! * vector * ! * * ! * czinv /comprs/ -local- compressibility matrix * ! * * ! * fsv /acase) -local- (multiple) freestream velocity* ! * * ! * * ! * fsvm /acase/ -local- magnitudes of freestream * ! * velocity vectors * ! * * ! * iacase /acase/ -local- index of loop over cases * ! * * ! * ipot /index/ -local- indicator for alternate * ! * potential and velocity * ! * computations * ! * =-2 lower surface values to be* ! * computed from singularity * ! * splines only * ! * =-1 lower surface values to be* ! * computed from singularity * ! * splines and influence * ! * coefficients * ! * =0 values to be computed * ! * from influence * ! * coefficients only * ! * =+1 upper surface values to be* ! * computed from singularity * ! * splines and influence * ! * coefficients * ! * =+2 upper surface values to be* ! * computed from singularity * ! * splines only * ! * * ! * nacase /acase/ -local- number of freestream cases * ! * for simultaneous solution * ! * * ! * nbc /index/ output number of boundary condition * ! * records for each network * ! * * ! * nbcot /index/ -local- total number of boundary * ! * conditions * ! * * ! * nc /index/ -local- array containing number of * ! * control points in each network* ! * * ! * nctrt /index/ -local- total number of control points* ! * * ! * ndtchk /datchk/ -local- data check flag ! * =1 data check only desired * ! * full solution otherwise * ! * * ! * nm /index/ -local- array containing number of * ! * rows in each network corner * ! * point grid * ! * * ! * nn /index/ -local- array containing number of * ! * columns in each network corner* ! * point grid * ! * * ! * nnett /index/ -local- total number of networks * ! * * ! * np /index/ -local- array containing number of * ! * panels in each network * ! * * ! * * ! * npant /index/ -local- total number of panels * ! * * ! * nsngk /index/ -local- total number of known * ! * singularity parameters * ! * * ! * nsngu /index/ -local- total number of unknown * ! * singularity parameters * ! * * ! * nsd /index/ -local- number of doublet singularity* ! * parameters in each network * ! * * ! * nsngt /index/ -local- number of total singularity * ! * parameters * ! * * ! * nss /index/ -local- number of source singularity * ! * parameters in each network * ! * * ! * ntd /index/ -local- array containing network * ! * doublet types * ! * * ! * nts /index/ -local- array containing network * ! * source types * ! * * ! * ntsin /cm03/ -local- system input device * ! * * ! * ntsout /cm03/ -local- system output device * ! * * ! * nz /index/ -local- array containing number of * ! * grid points in each network * ! * * ! * nzmpt /index/ -local- total number of grid points * ! * * ! * pi2 /ncons/ input 2 pi * ! * * ! * sbetam /comprs/ -local- sign of betams * ! * * ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call dbname common /dipdb/ dip, dipdbd(3), dipst(4), dipmdd(3), dippw integer dipst dimension idb(3) equivalence (idb,dipdbd) common /mecdb/ mec, mecdbd(3), mecst(4), mecmdd(3), mecpw integer mecst !end dbname !call global common /global/ netall, netord(150) !end global !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call titles common /titles/ title1(20),title2(20) character*4 title1, title2 !end titles !call nflowv ! * this common for calling overlay for off-body computation. ! * nflowv = 0 do not call (default value) ! * = 1 call ! * common /nflowv/ nflowv !end nflowv !call kstmln !** !** this common is used to pass information to streamline !** overlay 14b. various global parameters are set in subroutine !** input !** !** nstmln - stream line computation flag !** = 0 no (default value) !** = 1 yes !** numpts - no of streamlines to be computed. maximum = 500 !** default = 0 !** hmin - absolute value of minimum step size allowed !** default = 0.0000001 !** hmax - absolute value of maximum step size allowed !** default = 10000.0 !** maxstm - maximum no. of integration points allowed per !** streamline. default = 1000 !** mxordr - maximum order allowed during integration. default=6 !** abserr - maximum error allowed in integration step !** default = 0.000001 !** mxarr1 - size of work array to be used. default = 10000 !** isprnt - print streamline file flag. !** = 1 print, = 0 doo not print (default) !** tpsl - type of streamline flag. !** =0.0 for mass flux. any other value gives !** velocity. !** tpoff - type of offbody point flag. !** = 0.0 for mass flux. any other value gives velocity. !** ntsmln - tape for streamline points. !** common /kstmln/ nstmln, numpts, hmin, hmax, maxstm, mxordr, & & abserr,mxarr1,isprnt,tpsl,tpoff,ntsmln & & , indvsl(4), ncassl !end kstmln !call xcntrl common /xcntrl/ icntrl,jcntrl !end xcntrl !call acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !call ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !call datchk ! /datchk/ common/datchk/ndtchk !end datchk !call secprp common /secprp/ optcrd(5), optmrp(5), cutdat(9,5,25) & & , actfx, actfy, actfz, actmx, actmy, actmz, actar & & , refeta(5) & & , numgrp, numnet(5), netdat(5,150,2), numcut(5) & & , igrps, isecpr(5) & & , iprtnf(5), iprtpp(5), ixyzop(5), iform(150,2) & & , nosnet, icomop, isignl, icomtd(150) !end secprp !call lofdat common/lofdat/nloft,nslof,loft1,loft2,loft3 !end lofdat !call chkpnt common /chkpnt/ nckaic, nckusp !end chkpnt !call vrwi common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp) !end vrwi !call symm common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym !end symm !c ! * read input * !call rrwi common /rrwi/ nrdq, ntr, npanr !end rrwi !call slstat common /slstat/ tpvcal, tpivv, npicsl(7), npvcal, nphvsl !end slstat !call a502cn common /a502cn/ i502er !end a502cn !ca limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !ca lndblx ! /lndblx/ common /lndblx/ genwak(3,mxnett), slndbl(mxnett) & & , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett) !end lndblx !ca glopar ! /glopar/ common /glopar/ omgbin, kontrl, inplot, ilstdy, ktype & & , icamax & & , kutflg(150) logical ilstdy !end glopar !ca freqdt ! /freqdt/ common /freqdt/ omgbar, omegb, omg, omgabs !---- complex*16 omgbar, omegb, omg !end freqdt common /freqer/ ndpher !ca rzrth ! /rzrth/ common /rzrth/ rzrkic(3,150,5), thkic(3,150,5), pzkic(3,150,5) complex*16 thkic !end rzrth !ca outdat ! /outdat/ logical lstdy common/outdat/iflag,lstdy !end outdat !ca bcon common /bcon/ & & cu1,cl1,tu1(3),tl1(3),du1,dl1,bet1(4),nct1,nlopt1,nropt1,necpt1 & & ,klopt1,kldum1,betin1(4) & & ,cu2,cl2,tu2(3),tl2(3),du2,dl2,bet2(4),nct2,nlopt2,nropt2,necpt2 & & ,klopt2,kldum2,betin2(4) & & ,ndbcon !end bcon !ca brwi parameter (nsbp=6) common/brwi/nbdq,nsb,nrb,ntb,nnb,nib((maxcp+nsbp-1)/nsbp+1) !end brwi !ca acurhg ! /acurhg/ common /acurhg/ ihgram(60,5), thgram(7) & & , ihgdrd(60), ihgdph(60), ihgevl(60), ihgavl(60) & & , ihgtot !end acurhg !ca unstim ! /unstim/ common /unstim/ nuns(10), tuns(10) !end unstim !ca lfqprm ! /lfqprm/ ! major flags for controlling the low-frequency features ! mlofrq = 0, normal run ! = 1, ph/0 run, low frequency theory ! = 2, (d/dt) ph/0 run, low frequency theory ! = 3, ph/1,h run, low frequency theory ! adjgeo = .true., include ztz corrections in geometry ! (full low frequency theory) ! = .false., do not include ztz corrections in geometry, ! (linearized low frequency theory) ! adjwak = .true., adjust wake zeta's, fixing trailing edges ! .false., accept user's values of wake zeta's as given ! inczex = .true., include zeta terms for nropt =4,9 (exhaust bc's) ! = .false., exclude zeta terms for nropt =4,9 ! lfqind controls the type of processing done and implies that ! mlofrq will take on certain values ! lfqind = 0, standard a502 run; mlofrq = 0 [bconcl] ! = 1, low frequency theory with current geometry ! mlofrq = 1 [bconcl]; 2,3 [lfqg23] ! = 2, low frequency theory with linearized solution ! mlofrq = 0 [bconcl]; 1,2,3 [lfq123] common /lfqprm/ mlofrq, adjgeo, adjwak, inczex & & , lfqind logical adjgeo, adjwak, inczex ! !end lfqprm !call c2grwi ! /c2grwi/ ! File containing spline info for dsnfmc to generate surface ! velocity distributions from panel center velocity data. ! ! ntc2g unit number [49] ! nnc2g number of records [3*nnett+1], 3 per nw + index record ! nic2g index array of dimension [mxnett+1] ! common /c2grwi/ ntc2g, nnc2g, nic2g(5*mxnett+1) !end c2grwi !call mspnts common/mspnts/zm(3,maxpts) !end mspnts ! !call blkprm ! /blkprm/ ! nppblk i*4 flow block size for out-of-core solver ! nqqblk i*4 flow sub-block size for blkaic blocking algorithm ! nqblk i*4 flow (nppblk+nqqblk-1)/nqqblk # of row sub-blocks ! npblk i*4 flow (nsngu +nppblk-1)/nppblk # of row blocks ! kinblk i*4 flow nqqblk*nppblk+2, size of index array for lint ! klublk i*4 flow nppblk*nppblk+2, size of index array for llu ! nwwblk i*4 flow scratch size for blkaic calls from saical ! common /blkprm/ nppblk, nqqblk, npblk, nqblk, kinblk, klublk & & , nwwblk !end blkprm !call factrd ! /factrd/ common /factrd/ ifact !end factrd !call rlcplx ! /rlcplx/ ! ityprc i*4 fee real/complex indicator, = 1,real; = 2,complex ! this parameter is used to diminish the changes ! needed to generate the unsteady version common /rlcplx/ ityprc !end rlcplx !call skrch1 common /skrch1/ w(9000000) !end skrch1 ! --- dimension zctr(3,maxpan), pvactr(4,maxpan) ! !ca prntxt ! /prntxt/ common /prntxt/ iextra !end prntxt i502er = 0 lfqind = 0 ! set default frequency values omgbar = 0.d0 omegb = 0.d0 omg = 0.d0 omgabs = 0.d0 ! set mlofrq in accordance with lfqind ! to the appropriate value for bconcl adjgeo = .false. if ( lfqind.eq.0 ) then mlofrq = 0 endif if ( lfqind.eq.1 ) then mlofrq = 1 adjgeo = .true. endif if ( lfqind.eq.2 ) then mlofrq = 0 endif call sinput !c ! * print out the cost and job status for step completed * ! call cstprt ('init ') !c ! * calculate panel geometry defining quantities and store * ! * on i/o unit 2 * ! call sgeomc if ( i502er.gt.0 ) call a502er ('flow' & & ,'a502 abort, datacheck-2. see above') if ( ndtchk.ge.2 ) return !c ! * calculate singularity distribution defining quantities * ! * and store on i/o unit 2 along with panel geometry defining * ! * quantities computed above * ! call ssing !c ! * calculate control point defining quantities and store on * ! * i/o unit 3 * ! call scntrl !c ! * analyze boundary conditions * ! call sbcond !c ! * if data check only desired omit remainder of calculations * ! call ixtrns (41,nm,nnett) call ixtrns (42,nn,nnett) call ixtrns (43,nssa,nnett+1) call ixtrns (44,nsda,nnett+1) if ( i502er.gt.0 ) then call a502er ('flow','program abort due to above noted errors') endif if(ndtchk.eq.1) return !c ! * compute potential and velocity influence coefficients * ! * * if ( nckaic.ne.0 ) goto 800 call svinfc go to 850 ! set up /vrwi/ for execution of aical ! after a run that has saved a copy of ! the ic file, tape4 (ntv) 800 continue nvdq = nsngt ! collection point for restart and ! non-restart runs. 850 continue ! set blocking parameters, /blkprm/ nppblk = 249 if ( ityprc.eq.2 ) nppblk = 193 nppblk = min(nppblk,nsngu) nwwblk = max(150000, ityprc*( 2*nppblk*nppblk + nppblk ) ) nqqblk = nwwblk/(nsngu*ityprc) nqqblk = min(nqqblk,nppblk) nqblk = (nppblk+nqqblk-1)/nqqblk npblk = (nsngu+nppblk-1)/nppblk kinblk = nqblk*npblk+2 klublk = npblk*npblk+2 ! set nsngkq to avoid zero length ! allocations in getcor calls nsngkq = max( 1, nsngk) ! if ( nckusp.ne.0 .and. mlofrq.eq.0 ) goto 900 !c ! * compute boundary value problem left hand side influence * ! * coefficient and right hand side matrices * call setcor ('saical') call getcor ('scr', llscr, 4*ityprc*nsngkq) call getcor ('dvdf',lldvdf,4*ityprc*nsngt) call getcor ('s' ,lls, ityprc*nsngt) call igtcor ('jcnu',lljcnu, nsngt) call getcor ('bbta',llbbta, ityprc*nsngt) call getcor ('brhs',llbrhs, ityprc*nsngt) call saical (w(llscr),w(lldvdf),w(lls),w(lljcnu) & & ,w(llbbta),w(llbrhs)) call frecor ('saical') if ( i502er.gt.0 ) then call a502er('flow', & & 'termination due to errors in aic construction') endif !c ! * solve problem matrix equation * ! call setcor ('sinver') call getcor ('sols',llsols,4*ityprc*nsngt) call sinver (nsngt,w(llsols)) call frecor ('sinver') 900 continue call setcor ('pppdq') call getcor ('sngv',llsngv,4*ityprc*nsngt) call pppdq (nsngt,w(llsngv)) call frecor ('pppdq') if ( lfqind.eq.0 ) goto 960 ! low frequency theory if ( lfqind.eq.2 ) goto 930 ! lfqind = 1: do basic theory ! mlofrq=2: solve for d/dt phi(0) nacase = 1 mlofrq = 2 call setcor ('saical') call getcor ('scr', llscr, 4*ityprc*nsngkq) call getcor ('dvdf',lldvdf,4*ityprc*nsngt) call getcor ('s' ,lls, ityprc*nsngt) call igtcor ('jcnu',lljcnu, nsngt) call getcor ('bbta',llbbta, ityprc*nsngt) call getcor ('brhs',llbrhs, ityprc*nsngt) call saical (w(llscr),w(lldvdf),w(lls),w(lljcnu) & & ,w(llbbta),w(llbrhs)) call frecor ('saical') call setcor ('sinver') call getcor ('sols',llsols,4*ityprc*nsngt) call sinver (nsngt,w(llsols)) call frecor ('sinver') ! mlofrq=3: solver for phi(1,h) mlofrq = 3 call setcor ('saical') call getcor ('scr', llscr, 4*ityprc*nsngkq) call getcor ('dvdf',lldvdf,4*ityprc*nsngt) call getcor ('s' ,lls, ityprc*nsngt) call igtcor ('jcnu',lljcnu, nsngt) call getcor ('bbta',llbbta, ityprc*nsngt) call getcor ('brhs',llbrhs, ityprc*nsngt) call saical (w(llscr),w(lldvdf),w(lls),w(lljcnu) & & ,w(llbbta),w(llbrhs)) call frecor ('saical') call setcor ('sinver') call getcor ('sols',llsols,4*ityprc*nsngt) call sinver (nsngt,w(llsols)) call frecor ('sinver') ! goto 950 ! lfqind = 2: do linearized theory 930 continue nacase = 2 do 940 mlofrq = 1,3 call setcor ('saical') call getcor ('scr', llscr, 4*ityprc*nsngkq) call getcor ('dvdf',lldvdf,4*ityprc*nsngt) call getcor ('s' ,lls, ityprc*nsngt) call igtcor ('jcnu',lljcnu, nsngt) call getcor ('bbta',llbbta, ityprc*nsngt) call getcor ('brhs',llbrhs, ityprc*nsngt) call saical (w(llscr),w(lldvdf),w(lls),w(lljcnu) & & ,w(llbbta),w(llbrhs)) call frecor ('saical') call setcor ('sinver') call getcor ('sols',llsols,4*ityprc*nsngt) call sinver (nsngt,w(llsols)) call frecor ('sinver') 940 continue goto 950 ! generate U&L f.g. pert v 950 continue goto 1000 ! ! ! 960 continue call jzero (npicsl,7) nphvsl = 0 tpvcal = 0.d0 tpivv = 0.d0 npvcal = 0 if(nloft .gt. 0) call sloft ! generate v-spline data for F&M calc. call setcor ('dsnc2g') call openms (ntc2g,nic2g,nnc2g,0) ! do 980 knet = 1,nnett call setcor ('knetloop') mk = nm(knet) nk = nn(knet) mnk = mk*nk nzap1 = nza(knet) + 1 call igtcor ('lc2g', lllc2g, mnk) call igtcor ('klc2g',llkc2g, 9*mnk) call getcor ('cc2g', llcc2g,36*mnk) call icopy ( mnk, 0,0, w(lllc2g),1) call icopy ( 9*mnk, 0,0, w(llkc2g),1) call dcopy (36*mnk, 0.d0,0, w(llcc2g),1) call dsnc2g (knet,mk,nk,zm(1,nzap1) & & ,w(lllc2g),w(llkc2g),w(llcc2g)) ! ! ------- write (6,'('' FLOW: '',4i6)') knet,mk,nk,mnk ! call writms (ntc2g,w(lllc2g), mnk,knet, -1,0) call writms (ntc2g,w(llkc2g), 9*mnk,knet+nnett, -1,0) call writmd (ntc2g,w(llcc2g),36*mnk,knet+2*nnett, -1,0) ! call frecor ('knetloop') 980 continue call closms (ntc2g) call frecor ('dsnc2g') call sutput !c ! * if either streamlines or offbody points overlays are called * ! * for, write tape with /sdcv/ quantities. * ! if((nflowv.eq.0).and.(nstmln.eq.0)) go to 1000 call soffbd !c ! * compute flow quantities at offbody points. * !c ! * streamline computation. * ! call outvci ('npicsl',7,npicsl) if(nstmln.eq.0) go to 1000 call stmlne 1000 continue !c ! * calculate and print output * ! return END subroutine flow ! **deck fmcal subroutine fmcal (pres,nrow,ncol,npa,za,npanfp,prcoef,agpspc) implicit double precision (a-h,o-z) !***created on 78.060 w.o. no. 0 version fee.01 ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * p u r p o s e * * * * ! * - - - - - - - * ! * * ! * to compute panel and network force and moment * ! * coefficients from pressure coefficient data * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * m e t h o d * * * * ! * - - - - - - * ! * * ! * the routine calculates panel and network force * ! * and moment coefficients from pressure coefficients * ! * at the control points of each panel. * ! * the routine first computes linear distributions * ! * of pressure coefficients on each panel by the method * ! * of weighted least squares. these coefficients are then * ! * integrated to obtain panel force and moment coefficients. * ! * these coefficients are accumulated to obtain coefficients for* ! * each column of the network as well as for the network * ! * as a whole. in addition the coefficients for each network * ! * are accumulated for total configuration coefficients. * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * !c * * * * d e f i n i t i o n o f v a r i a b l e s * * * * ! * - - - - - - - - - - - - - - - - - - - - - - - * ! * * ! * variable storage in/output description * ! * * ! * ak /lsqsfc/ in/out generalized inverse from * ! * least square fit * ! * * ! * al /pandq/ input area jacobian from global to * ! * local sub-panel coordinates * ! * * ! * aqi /pandq/ input transformation matrix from * ! * near plane to global * ! * coordinate system * ! * * ! * ar /pandq/ input transformation from global to * ! * local sub-panel coordinates * ! * * ! * ari /pandq/ input transformation from local sub-* ! * panel to global coordinates * ! * * ! * * ! * bref /fmcof/ input reference length for moment * ! * about x axis * ! * * ! * cp /pandq/ input nine canonical panel points * ! * (includes corner points,edge * ! * midpoints and center) * ! * * ! * cref /fmcof/ input reference length for moment * ! * about y axis * ! * * ! * c /pandq/ in/out array of panel moments * ! * * ! * dref /fmcof/ input reference length for moment * ! * z axis * ! * * ! * fc /tfmq/ output accumulated force, moment * ! * coefficients and areas of * ! * networks * ! * * ! * fc /tfmq/ output accumulated force * ! * coefficients of networks * ! * * ! * fmc /tfmq/ output accumulated moment * ! * coefficients of networks * ! * * ! * fmrt -local- - - - - running accumulator for * ! * panel column moments * ! * * ! * fmt -local- - - - - running accumulator for * ! * network moments * ! * * ! * frt -local- - - - - running accumulator for * ! * panel column forces * ! * * ! * ft -local- - - - - running accumulator for * ! * network forces * ! * * ! * igrps /secprp/ output group number (often used as an* ! * index) * ! * * ! * iis /pandq/ in/out array containing indices of * ! * free parameters on which * ! * spline coefficients depend * ! * * ! * ip -local- - - - - panel index * ! * * ! * its /pandq/ in/out panel singularity type * ! * * ! * m -local- - - - - index of loop over panel rows * ! * * ! * ncol argument input number of panel columns in * ! * network * ! * * ! * netdat /secprp/ output data about the network's part * ! * in the group * ! * * ! * netwrk /secprp/ output network number (an index) * ! * * ! * no /lsqsfc/ output order of least squares fit * ! * =2 for quadratic fit * ! * =1 for linear fit * ! * * ! * npa argument input total number of panels in * ! * previous networks * ! * * ! * npk /lsqsfc/ output number of data points used * ! * in least square fit * ! * * ! * nrow argument input number of rows of panel * ! * in network * ! * * ! * n -local- - - - - index of loop over panel * ! * columns * ! * * ! * numgrp /secprp/ output number of groups of data * ! * * ! * numnet /secprp/ output number of networks in a group * ! * * ! * prcoef /secprp/ output pressure coefficients data for* ! * networks in a group * ! * * ! * pres argument input upper, lower, and * ! * difference pressure * ! * coefficients * ! * * ! * sref /fmcof/ input reference area for force * ! * and moment calculations * ! * * ! * * ! * ta -local- - - - - running accumulator for * ! * network area * ! * * ! * tca /tfmq/ output accumulated surface area of * ! * networks * ! * * ! * tra -local- - - - - running accumulator for * ! * panel column area * ! * * ! * wtk /lsqsfc/ in/out weights used in least squres * ! * fit * ! * * ! * xref /fmcof/ input global x coordinate of * ! * origin for moment calculations* ! * * ! * yref /fmcof/ input global y coordinate of * ! * origin for moment calculations* ! * * ! * za argument input panel control point locations * ! * at which pressure * ! * coefficients are calculated * ! * * ! * zk /lsqsfc/ in/out x,y,z coordinates of corner * ! * points used in least square * ! * fit * ! * * ! * zref /fmcof/ input global z coordinate of * ! * origin for moment calculations* ! * * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! !call limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !call secprp common /secprp/ optcrd(5), optmrp(5), cutdat(9,5,25) & & , actfx, actfy, actfz, actmx, actmy, actmz, actar & & , refeta(5) & & , numgrp, numnet(5), netdat(5,150,2), numcut(5) & & , igrps, isecpr(5) & & , iprtnf(5), iprtpp(5), ixyzop(5), iform(150,2) & & , nosnet, icomop, isignl, icomtd(150) !end secprp !call prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !call comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !call fmcof common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof !end fmcof !call pandq common/pandq/cp(3,9),ar(9,5),ari(9),en(3,5),aq(9),aqi(9),aj(5), & &sgx(5),p(3,4),alam(9,4),rc(9,3),c(3,3),c1,c2,c3,diam,asts(27), & &astd(189),astmux(3,5),iis(9),iid(21),iimux(5),ins,ind,inmux, & &ncs,ncd,its,ics,iin(5),ipn,kp, & & isqn, strc(2,3), iisgp(9), iidgp(25), iimuxg(6) & & , qa(6,9) & & , qk(10,9,2), pk(3,3,2), rk(3,3,2) & & , qq( 6,9,8), pp(3,3,8), rr(3,3,8) !end pandq !call tfmq common/tfmq/fc(3,3),fmc(3,3),tca !end tfmq !call lsqsfc ! /lsqsfc/ common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk !end lsqsfc dimension pr(3),fi(3),fmi(3),frt(3,3),fmrt(3,3),ft(3,3), & &fmt(3,3),ce(3),cg(3),r0(3) !call agps ! common /agps/ jacase,iagpsf ! agpspc - all 3 components of the pressure coefficients on ! every panel for every case ! jacase - particular case being dealt with ! iagpsf - name of file having pressure data for agps plotting ! !end agps dimension pres(3,1250),za(3,1250) dimension prcoef(3,npanfp,5), agpspc(3,4,npanfp) !call secscr common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin & & , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2) !end secscr data wt /1.d4/ if( ifmcpr .ne. 0 ) write(6,3000) netwrk, netwrk 3000 format(1h1,/,'0*b*for-mom-net#-',i3,/,46x, & & 'force / moment data for network ',i5,////) !c ! * initialize network area and force/moment coefficients * ! ta=0.d0 call zero(ft,9) call zero(fmt,9) no=1 !c ! * loop ranges over panel columns * ! do 699 n=1,ncol !c ! * initialize column area and force/moment coefficients * ! tra=0.d0 call zero(frt,9) call zero(fmrt,9) !c ! * loop ranges over panel rows * ! do 698 m=1,nrow !c ! * calculate index of this panel (row m, column n) * ! ip=m+nrow*(n-1)+npa !c ! * load the panel information for the ip th panel * ! call strns(ip,cp) al=aj(5) npk=0 !c ! * assemble panel and its neighbors - control point locations * ! * for computing least square coefficients for linear * ! * distribution of pressure coefficients * ! !c ! * loop ranges over columns of panel neighborhood * ! do 629 j=1,3 nj=n+j-2 if((nj.lt.1).or.(nj.gt.ncol)) go to 629 !c ! * loop ranges over rows of panel neighborhood * ! do 628 i=1,3 mi=m+i-2 if((mi.lt.1).or.(mi.gt.nrow)) go to 628 npk=npk+1 !c ! * load information for panel mi,nj * ! lmn=mi+nrow*(nj-1) !c ! * transform coordinates to local and put in least squares data * ! * array * ! wtk(npk)=1.d0 if((i.eq.2).and.(j.eq.2)) wtk(npk)=wt iis(npk)=lmn call lproj(aqi(7),cp(1,9),za(1,lmn),zk(1,npk)) call unipan(ar(1,5),cp(1,9),zk(1,npk),zk(1,npk)) if((i.ne.2).or.(j.ne.2)) go to 628 if(nrow.gt.1) go to 625 !c ! * process additional points when number of panel rows is one * ! * so that variation in row direction will be constant * ! npk=npk+1 wtk(npk)=1.d0 iis(npk)=iis(npk-1) call lproj(aqi(7),cp(1,9),cp(1,5),zk(1,npk)) call unipan(ar(1,5),cp(1,9),zk(1,npk),zk(1,npk)) npk=npk+1 wtk(npk)=1.d0 iis(npk)=iis(npk-1) call lproj(aqi(7),cp(1,9),cp(1,7),zk(1,npk)) call unipan(ar(1,5),cp(1,9),zk(1,npk),zk(1,npk)) 625 if(ncol.gt.1) go to 628 !c ! * process additional poionts when number of panel columns is * ! * one so that variation in column direction will be constant * ! npk=npk+1 wtk(npk)=1.d0 iis(npk)=iis(npk-1) call lproj(aqi(7),cp(1,9),cp(1,6),zk(1,npk)) call unipan(ar(1,5),cp(1,9),zk(1,npk),zk(1,npk)) npk=npk+1 wtk(npk)=1.d0 iis(npk)=iis(npk-1) call lproj(aqi(7),cp(1,9),cp(1,8),zk(1,npk)) call unipan(ar(1,5),cp(1,9),zk(1,npk),zk(1,npk)) 628 continue 629 continue !c ! * least square fit to panel control points * ! call lsqsf !c ! * sum up the pressures for this neighborhood by multiplying by * ! * the least squares inverse matrix * ! !c ! * loop ranges over the upper, lower and difference quantities * ! do 690 i=1,3 sgni=al*(-1.d0)**i !c ! * calculate linear distribution of pressure coefficients * ! !c ! * loop ranges over columns of coefficient matrices * ! do 650 j=1,3 z=0.d0 !c ! * loop ranges over panel in neighborhood * ! do 648 k=1,npk l=iis(k) 648 z=z+ak(j,k)*pres(i,l) 650 pr(j)=z ! do 652 igrps = 1,numgrp if( netdat(igrps,netwrk,1) .eq. 0) go to 652 if( .not. ( i .eq. netdat(igrps,netwrk,2) ) ) go to 652 do 651 ll=1,3 prcoef (ll,ip,igrps) = pr(ll) 651 continue ! diagnostic printout *** ! if(i .eq. 1) isrfcd = 6hupper ! if(i .eq. 2) isrfcd = 6hlower ! if(i .eq. 3) isrfcd = 6hdiffer ! if( isecpr(igrps) .eq. 1 ) ! 1 write(6,1000) ip, (prcoef(ll,ip,igrps), ll=1,3), isrfcd !1000 format(1h ,48hpanel no., pressure coefficients, surface code: , ! 1 i5,3x,3e15.6,a10) ! end diagnostic printout *** ! 652 continue ! ! save data for agps program if( .not. (i.eq.1) ) go to 653 agpspc( 1, jacase, ip) = pr(1) agpspc( 2, jacase, ip) = pr(2) agpspc( 3, jacase, ip) = pr(3) 653 continue !c ! * compute integral of pressure over panel * ! cf=sgni*(pr(1)*c(1,1)+pr(2)*c(2,1)+pr(3)*c(1,2))/sref call mxm (cf,1,en(1,5),1,fi,3) !c ! * compute integral of pressure times local position vector * ! * over panel * ! ce(1)=sgni*(pr(1)*c(2,1)+pr(2)*c(3,1)+pr(3)*c(2,2))/sref ce(2)=sgni*(pr(1)*c(1,2)+pr(2)*c(2,2)+pr(3)*c(1,3))/sref ce(3)=0.d0 call mxm (ari,3,ce,3,cg,1) call cross(cg,en(1,5),ce) call vadd(cp(1,9),-1.d0,xref,r0,3) call cross(r0,fi,fmi) call vadd(fmi,1.d0,ce,fmi,3) fmi(1)=fmi(1)/bref fmi(2)=fmi(2)/cref fmi(3)=fmi(3)/dref !c ! * accumulate areas and force/moment coefficients * ! !c ! * loop ranges over columns of coefficient matrices * ! do 665 j=1,3 ft(i,j)=ft(i,j)+fi(j) fmt(i,j)=fmt(i,j)+fmi(j) frt(i,j)=frt(i,j)+fi(j) fmrt(i,j)=fmrt(i,j)+fmi(j) fc(i,j)=fc(i,j)+fi(j) fmc(i,j)=fmc(i,j)+fmi(j) 665 continue 690 continue ta=ta+al*c(1,1) tra=tra+al*c(1,1) tca=tca+al*c(1,1) 698 continue !c ! * print the data for this column * ! if ( ifmcpr.ne.1 ) go to 699 write(6,3500) n 3500 format(//,1x,17htotals for column,2x,i5,10x,4harea,5x, & &6x,2hfx,12x,2hfy,12x,2hfz,12x,2hmx,12x,2hmy,12x,2hmz,6x,//) write(6,3001) tra, frt(1,1), frt(1,2), frt(1,3) & & ,fmrt(1,1),fmrt(1,2),fmrt(1,3) & & ,tra, frt(2,1), frt(2,2), frt(2,3) & & ,fmrt(2,1),fmrt(2,2),fmrt(2,3) & & ,tra, frt(3,1), frt(3,2), frt(3,3) & & ,fmrt(3,1),fmrt(3,2),fmrt(3,3) 3001 format(30x,7f14.5) 699 continue !c ! * print the data for this network * ! if( iform(netwrk,1) .eq. 0 ) go to 810 actfx = actfx + ft( iform(netwrk,2), 1 ) actfy = actfy + ft( iform(netwrk,2), 2 ) actfz = actfz + ft( iform(netwrk,2), 3 ) actmx = actmx + fmt( iform(netwrk,2), 1 ) actmy = actmy + fmt( iform(netwrk,2), 2 ) actmz = actmz + fmt( iform(netwrk,2), 3 ) actar = actar + ta 810 continue ! if ( ifmcpr.eq.0 ) go to 950 write(6,4000) 4000 format(//,1x,18htotals for network,16x,4harea,5x, & &6x,2hfx,12x,2hfy,12x,2hfz,12x,2hmx,12x,2hmy,12x,2hmz,6x,//) write(6,4001) ta, ft(1,1), ft(1,2), ft(1,3) & & ,fmt(1,1),fmt(1,2),fmt(1,3) & & ,ta, ft(2,1), ft(2,2), ft(2,3) & & ,fmt(2,1),fmt(2,2),fmt(2,3) & & ,ta, ft(3,1), ft(3,2), ft(3,3) & & ,fmt(3,1),fmt(3,2),fmt(3,3) 4001 format(30x,7f14.5) !c ! * print data accumulated over all networks so far * ! write(6,5000) 5000 format(//,1x,30htotals for all networks so far,5x,4harea,5x, & &6x,2hfx,12x,2hfy,12x,2hfz,12x,2hmx,12x,2hmy,12x,2hmz,6x,//) write(6,5001) tca, fc(1,1), fc(1,2), fc(1,3) & & ,fmc(1,1),fmc(1,2),fmc(1,3) & & ,tca, fc(2,1), fc(2,2), fc(2,3) & & ,fmc(2,1),fmc(2,2),fmc(2,3) & & ,tca, fc(3,1), fc(3,2), fc(3,3) & & ,fmc(3,1),fmc(3,2),fmc(3,3) 5001 format(30x,7f14.5) 950 continue call emark('for-mom ') return END subroutine fmcal ! **deck fmcale subroutine fmcale (isol,ksurf,rz, knet,m,n,q & & ,lc2g,klc2g,cc2g & & ,pres,cpc & & ,af,am, aft,amt,tca & & ) implicit double precision (a-h,o-z) dimension rz(3), q(3,m,n) dimension lc2g(m-1,n-1), cc2g(4,9,m-1,n-1), klc2g(9,m-1,n-1) dimension pres(3, (m-1)*(n-1)), cpc( ((m-1)*(n-1)), 2) dimension af(3), am(3), aft(3,3), amt(3,3) ! ! replacement for fmcal using H-P element integration and 'c2g' ! spline technology. ! ! ksurf i i*4 wetted surface indicator: [1,U; 2,L; 3,U+L] ! rz i r*8 center of moment ! knet i i*4 nw index ! m i i*4 number of meshpoints per row ! n i i*4 number of meshpoints per column ! q i r*8 network meshpoints ! lc2g i i*4 lc2g(k,l) gives the number of panel center v's ! that the velocity distribution on panel (k,l) ! depends upon ! cc2g i r*8 dependency of cornerpoint v's on panel center v's ! klc2g i i*4 panel center (kl) indices for cc2g dependencies ! cpc o r*8 panel center cp's, upper and lower ! af o r*8 force vector for this network ! am o r*8 moment vector for this network ! ! afe s r*8 transpiration contribution to force ! ame s r*8 transpiration contribution to moment ! !ca limits ! maximum number of control points parameter (maxcp = 24000) ! maximum number of mesh points parameter (maxpts = 20000) ! maximum number of panels parameter (maxpan = 18000) ! maximum number of panels in a network parameter (mxntpn = 8000) ! maximum known singularities parameter (mxsngk = 18000) ! maximum unknown singularities parameter (mxsngu = 24000) ! total singularities (mxsngk+mxsngu) parameter (mxsngt = 42000) ! maximum number of singularities per network parameter (mxsgpn = 17500) !end limits !ca limabt ! maximum number of networks parameter (mxnett=150) ! maximum number of pairwise abutments parameter (mxiabt=2400) ! maximum number of abutments parameter (mxnabt=1000) ! maximum number of edges in an abutment parameter (mxeiab=10) ! maximum number of fundamental segments parameter (mxfdsg=1500) ! maximum number of edge mesh points parameter (mxempt=8000) ! maximum number of edge mesh points per nw edge parameter (mxedmp=400) ! maximum number of abutment intersections parameter (mxnai=750) ! maximum number of points in an eq. class of mesh points parameter (mxnpec=6000) !end limabt !ca index common/index/nts(150),ntd(150),nm(150),nn(150),nza(151),npa(151), & & nssa(151),nsda(151),nca(151),nbca(151),ipot(150),nwofb(150) & & ,nmapca(151) & & ,nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot,nnwofb !end index !ca comprs common/comprs/amach,betams,betam,sbetam,abetms,alpc,betc, & &compd(3),arotc(9),arotci(9),czinv(3,3) & & , ggcp(3,3), ggcpit(3,3), btsqi, akap, akapin !end comprs !ca acase common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4) & & , iacase, nacase, fsvhat(3,4), pvdry(3,4) !end acase !ca fmcof common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof !end fmcof !ca prnt common /prnt/ igeomp, isingp, icontp, ibconp, iedgep, & & isings, ipraic, ipartp, iparts & & , ioutpr, ifmcpr, icostp, iextrp, ispmap & & , icpmap, ibcmap !end prnt !ca ncons common /ncons/ pi,pi2,pi4i,twopi,pio2 !end ncons !ca secprp common /secprp/ optcrd(5), optmrp(5), cutdat(9,5,25) & & , actfx, actfy, actfz, actmx, actmy, actmz, actar & & , refeta(5) & & , numgrp, numnet(5), netdat(5,150,2), numcut(5) & & , igrps, isecpr(5) & & , iprtnf(5), iprtpp(5), ixyzop(5), iform(150,2) & & , nosnet, icomop, isignl, icomtd(150) !end secprp ! dimension qz(3), qs(3), qt(3), qst(3), qmr(3) ! dimension qsxqt(3), qsxqst(3), qstxqt(3) dimension enp(3,0:2) equivalence (qsxqt,enp(1,0)), (qsxqst,enp(1,1)), (qstxqt,enp(1,2)) ! dimension fklij(3), amklij(3) dimension amz(3), qmrxf(3) dimension aa(4,4) dimension sgp(0:1) dimension ampan(3), afpan(3) dimension afc(3,3), amc(3,3), afnw(3,3), amnw(3,3) dimension arotfs(3,3), afrot(3) ! dimension hh(0:2) dimension faii(0:2,0:1,0:1) integer alfb(0:3), betb(0:3) dimension ipar(4), jpar(4) logical jac, prtcpc ! data ipar /0,1,0,1/ data jpar /0,0,1,1/ data alfb /0,1,0,1/ data betb /0,0,1,1/ ! data aa / .25d0, -.25d0, -.25d0, .25d0 & & , .25d0, .25d0, -.25d0, -.25d0 & & , .25d0, -.25d0, .25d0, -.25d0 & & , .25d0, .25d0, .25d0, .25d0 / ! ! 0,0 1,0 0,1 1,1 ! aa = (1/4) [ 1 1 1 1 ] <-- qz ! [ -1 1 -1 1 ] <-- qs ! [ -1 -1 1 1 ] <-- qt ! [ 1 -1 -1 1 ] <-- qst ! prtcpc = .false. ! p33 = 1.d0/3.d0 p066 = 1.d0/15.d0 sgp(0) = -p33 sgp(1) = p33 if( ifmcpr .ne. 0 ) write(6,3000) knet, knet ! hh(0) = 2.d0 hh(1) = 0.d0 hh(2) = 2.d0/3.d0 ! set integral coefficients faii ! faii(ialf,i,ip) = ! ! int s^ialf b[i](s) b[ip](s) ds ! ! where b[i] = (1 - (-1)^i s )/2 ! ! faii = [ 2/3 1/3 1/3 2/3 ] ! [-1/3 0 0 1/3 ] ! [ 4/15 1/15 1/15 4/15] ! faii(0,0,0) = 2.d0*p33 faii(0,1,0) = p33 faii(0,0,1) = p33 faii(0,1,1) = 2.d0*p33 faii(1,0,0) = -p33 faii(1,1,0) = 0.d0 faii(1,0,1) = 0.d0 faii(1,1,1) = p33 faii(2,0,0) = 4.d0*p066 faii(2,1,0) = p066 faii(2,0,1) = p066 faii(2,1,1) = 4.d0*p066 ! mfn = 2*m-1 nfn = 2*n-1 ! compute pressure at panel centers do 200 iul = 1,2 do 190 l = 1,n-1 do 180 k = 1,m-1 kl = k + (l-1)*(m-1) cpc(kl,iul) = pres(iul,kl) 180 continue 190 continue 200 continue if ( prtcpc ) then if ( mod(ksurf,2).eq.1 ) & & call outmat ('cpc/up',m-1,m-1,n-1,cpc) if ( ksurf.ge.2 ) & & call outmat ('cpc/lo',m-1,m-1,n-1,cpc(1,2)) endif ! COMPUTE THE QUANTITIES: ! af, d(f)/d(q(i,j)), d(f)/d(v(k,l)+-) ! am, d(m)/d(q(i,j)), d(m)/d(v(k,l)+-) call dcopy (3, 0.d0,0, af,1) call dcopy (3, 0.d0,0, am,1) ! sgul = 1 [U]; -1 [L] ! iul = 1 [U]; 2 [L] ! ! Even though the force vector is ! defined as: F = - int p n dS, ! we actually compute the quantity: ! ! int_U (p n dS) - int_L (p n dS) ! ! because the normal we compute in ! this routine is oppositely directed ! from the regular (a502) panel normal ! due to the "left handed" nature of ! the regular (a502) panel normal errmax = 0.d0 call dcopy (9, 0.d0,0, afnw,1) call dcopy (9, 0.d0,0, amnw,1) ta = 0.d0 mpan = m-1 npan = n-1 ! do 605 l = 1,n-1 call dcopy (9, 0.d0,0, afc,1) call dcopy (9, 0.d0,0, amc,1) tra = 0.d0 ! do 600 k = 1,m-1 kl = k + (l-1)*(m-1) sgul = -1.d0 ! basic geometry data for panel do 320 i = 1,3 qz(i) = .25d0*( q(i,k,l)+q(i,k+1,l)+q(i,k,l+1)+q(i,k+1,l+1)) qs(i) = .25d0*(-q(i,k,l)+q(i,k+1,l)-q(i,k,l+1)+q(i,k+1,l+1)) qt(i) = .25d0*(-q(i,k,l)-q(i,k+1,l)+q(i,k,l+1)+q(i,k+1,l+1)) qst(i)= .25d0*( q(i,k,l)-q(i,k+1,l)-q(i,k,l+1)+q(i,k+1,l+1)) qmr(i)= qz(i) - rz(i) 320 continue call cross (qs, qt, qsxqt ) call cross (qs, qst, qsxqst) call cross (qst, qt, qstxqt ) areakl = 4.d0 * sqrt( ddot( 3, qsxqt,1, qsxqt,1) ) tra = tra + areakl ! sis = ddot(3, qs,1, qs,1) sit = ddot(3, qs,1, qt,1) tit = ddot(3, qt,1, qt,1) stis = ddot(3, qst,1, qs,1) stit = ddot(3, qst,1, qt,1) stist = ddot(3, qst,1, qst,1) ! loop over upper and lower surfaces do 590 iul = 1,2 sgul = -sgul sgfme = 2.d0*sgul/( fsvm(isol)**2 ) if ( iul.ne.ksurf .and. ksurf.ne.3 ) goto 590 ksf = (3-2*iul)*knet ! call dcopy (3, 0.d0,0, afpan,1) call dcopy (3, 0.d0,0, ampan,1) ! loop over 4 panel corner points ijp = 0 do 550 jp = 0,1 sgjp = sgp(jp) do 540 ip = 0,1 ijp = ijp + 1 sgip = sgp(ip) i = k+ip j = l+jp ij = i + (j-1)*m cpgg = 0.d0 npk