! **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     =  lc2g(k,l)
               do 480 ll = 1,npk
                  klc     =  klc2g(ll,k,l)
                  if ( klc.eq.0 ) goto 480
                  cc2gx   =  cc2g(ijp,ll,k,l)
                  cpgg    =  cpgg + cc2gx*cpc(klc,iul)
  480          continue
               sgulcp  =  sgul*cpgg
!                                  accumulate into dfdv
!                    fklij  =   (q x q ) + sg  (q x q  ) + sg  (q  x q )
!                                 s   t      i'  s   st      j'  st   t
               fklij(1) = qsxqt(1) +sgip*qsxqst(1) +sgjp*qstxqt(1)
               fklij(2) = qsxqt(2) +sgip*qsxqst(2) +sgjp*qstxqt(2)
               fklij(3) = qsxqt(3) +sgip*qsxqst(3) +sgjp*qstxqt(3)
               call daxpy (3,  sgulcp,  fklij,1,  af,1)
               call daxpy (3,  sgulcp,  fklij,1,  afpan,1)
               call cross (qmr,fklij,qmrxf)
!                                  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 490 kk = 1,3
                  amz(kk) = amzqs*qs(kk) + amzqt*qt(kk) + amzqst*qst(kk)
!                                   m = m(0) + (qz - rz) x f
                  amklij(kk) = amz(kk) + qmrxf(kk)
  490          continue
               call daxpy (3,  sgulcp,  amklij,1,  am,1)
               call daxpy (3,  sgulcp,  amklij,1,  ampan,1)
!                                  end of loops on panel's 4 corners
  540       continue
  550    continue
         call dscal (3,  1.d0/sref,  afpan,1)
         call dscal (3,  1.d0/sref,  ampan,1)
         ampan(1) = ampan(1)/bref
         ampan(2) = ampan(2)/cref
         ampan(3) = ampan(3)/dref
!--         write (6,6002) knet,k,l,afpan,ampan
 6002    format (' FMCALE-PANEL:',3i4,3x,3f12.7,3x,3f12.7)
!
         call daxpy (3,  1.d0,  afpan,1,  afc(1,iul),1)
         call daxpy (3,  1.d0,  ampan,1,  amc(1,iul),1)
         call daxpy (3,  1.d0,  afpan,1,  afc(1,3),1)
         call daxpy (3,  1.d0,  ampan,1,  amc(1,3),1)
!                                 end up loop on upper/lower surfaces
  590 continue
!                                 end of loop on rows in network
  600 continue
      if ( ifmcpr.ne.1 ) goto 601
         write (6,3500) l
         write (6,3001) tra, (afc(kk,1),kk=1,3)                         &
     &                     , (amc(kk,1),kk=1,3)                         &
     &                 ,tra, (afc(kk,2),kk=1,3)                         &
     &                     , (amc(kk,2),kk=1,3)                         &
     &                 ,tra, (afc(kk,3),kk=1,3)                         &
     &                     , (amc(kk,3),kk=1,3)
  601 continue
      call daxpy (9,  1.d0,  afc,1,  afnw,1)
      call daxpy (9,  1.d0,  amc,1,  amnw,1)
      ta      =  ta + tra
!                                 end of loop on columns in network
  605 continue
!                                 accumulate configuration F&M sums
      call daxpy (9,  1.d0,  afnw,1,  aft,1)
      call daxpy (9,  1.d0,  amnw,1,  amt,1)
      tca     =  tca + ta
!                                 standard printout
      if ( ifmcpr.eq.0 ) go to 950
      write (6,4000)
      write (6,4001) ta, (afnw(kk,1),kk=1,3)                            &
     &                 , (amnw(kk,1),kk=1,3)                            &
     &              ,ta, (afnw(kk,2),kk=1,3)                            &
     &                 , (amnw(kk,2),kk=1,3)                            &
     &              ,ta, (afnw(kk,3),kk=1,3)                            &
     &                 , (amnw(kk,3),kk=1,3)
!
      write (6,5000)
      write (6,5001) tca, (aft(kk,1),kk=1,3)                            &
     &                  , (amt(kk,1),kk=1,3)                            &
     &              ,tca, (aft(kk,2),kk=1,3)                            &
     &                  , (amt(kk,2),kk=1,3)                            &
     &              ,tca, (aft(kk,3),kk=1,3)                            &
     &                  , (amt(kk,3),kk=1,3)
  950 continue
!                                 accumulate for F&M summary
      if ( iform(knet,1) .eq. 0 ) goto 970
         isurf   =  iform(knet,2)
         if ( isurf.ne.ksurf .and. ksurf.ne.3 ) call a502er ('fmcale'   &
     &        ,' isurf/ksurf incompatibility in fmcale' )
         call daxpy (3,  1.d0,  afnw(1,isurf),1,  actfx,1)
         call daxpy (3,  1.d0,  amnw(1,isurf),1,  actmx,1)
         actar   =  actar + ta
  970 continue
!
      radfac  =  pi/180.d0
      aarg    =  alpha(isol)*radfac
      barg    =   beta(isol)*radfac
      call rotate (arotfs,  aarg,barg)
!                                 apply scale factors to output
      call dscal (3,  1.d0/sref,  af,1)
      call dscal (3,  1.d0/sref,  am,1)
      am(1) = am(1)/bref
      am(2) = am(2)/cref
      am(3) = am(3)/dref
!
      call outvec ('afe-exact',3,af)
      call outvec ('ame-exact',3,am)
      call hsmmp1 (3,3,1,  arotfs,1,3,  af,1,3,  afrot,1,3)
      call outvec ('CD/CY/CL K',3,afrot)
      return
!
!                                  formats for standard printout
 3000 format(1h1,/,'0*b*for-mom-net#-',i3,/,46x,                        &
     &       'force / moment data for network ',i5,////)
 3500 format(//,1x,17htotals for column,2x,i5,10x,4harea,5x,            &
     &6x,2hfx,12x,2hfy,12x,2hfz,12x,2hmx,12x,2hmy,12x,2hmz,6x,//)
 3001 format(30x,7f14.5)
 4000 format(//,1x,18htotals for network,16x,4harea,5x,                 &
     &6x,2hfx,12x,2hfy,12x,2hfz,12x,2hmx,12x,2hmy,12x,2hmz,6x,//)
 4001 format(30x,7f14.5)
 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,//)
 5001 format(30x,7f14.5)
!
      END subroutine fmcale
! **deck fmkal
      subroutine fmkal  (isol,ksurf,rz,  knet,m,n,q                     &
     &                  ,lc2g,klc2g,cc2g,vc                             &
     &                  ,cpc,dcpc                                       &
     &                  ,af,am,  aft,amt,  afkl,amkl                    &
     &                  )
      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 vc(3,((m-1)*(n-1)),2)
!---  dimension wc(3,((m-1)*(n-1)),2)
      dimension cpc( ((m-1)*(n-1)), 2), dcpc(3, ((m-1)*(n-1)), 2)
!
      dimension af(3), am(3), aft(3,3), amt(3,3)
      dimension afkl(3,m-1,n-1), amkl(3,m-1,n-1)
!
!     given the upper/lower surface velocities at panel centers (vc),
!     compute the force (af) and moment (am) vector for a network and
!     update the sensitivities of the total force and moment vectors
!     with respect to lambda (dfdlam and dmdlam).
!
!     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
!     vc     i   r*8  panel center velocities, upper and lower
!     wc     i   r*8  panel center INCREMENTAL mass flux, upper OR lower
!                     (assumes perturbation mass flux on either U or L
!                      and that ksurf = 1 or 2, as appropriate, never 3)
!     cpc    o   r*8  panel center cp's, upper and lower
!     dcpc   o   r*8  d(cp)/d(v) at panel centers, upper and lower
!     af     o   r*8  force vector for this network
!     am     o   r*8  moment vector for this network
!
!     wc     i   r*8  incremental panel center mass flux vectors
!     afe    s   r*8  transpiration contribution to force
!     ame    s   r*8  transpiration contribution to moment
!     wb     s   r*8  corner mass fluxes (may be total or perturbation)
!     vb     s   r*8  corner velocities (total)
!     mvflux l   log  flag indicating whether or not momentum flux
!                     term should be included
!
!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 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
!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 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
!
      dimension qz(3), qs(3), qt(3), qst(3), qmr(3), dd(3,0:3)
      equivalence (qz(1),dd(1,0)),  (qs(1),dd(1,1))                     &
     &          , (qt(1),dd(1,2)), (qst(1),dd(1,3))
      dimension cpgx(4), ddxvb (3,3,4), wkl(3), vkl(3)
!
      dimension qsxqt(3), qsxqst(3), qstxqt(3)
      dimension enp(3,0:2), enpt(3,0:2), enpw(0:2,4)
      equivalence (qsxqt,enp(1,0)), (qsxqst,enp(1,1)), (qstxqt,enp(1,2))
!
      dimension afe(3), ame(3), dfedv(3,3), dmedv(3,3), wb(3,4), vb(3,4)
      dimension fklij(3), dfdvij(9), amklij(3), dmdvij(9)
      dimension amz(3), qmrxf(3), qmrxfe(3)
      dimension dsdfs(16), dddfs(4,25), dvs(3,16), dvd(3,25)
      dimension dfsng(3,25), dmsng(3,25)
      dimension aa(4,4)
      dimension sgp(0:1)
      dimension zncfac(3)
      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 vbent(9)
      dimension dfedvx(3,3), fex(3)
      dimension dfedvy(3,3), fey(3)
      dimension afet(3), amet(3), hh(0:2), amex(3), dxn(3)
      dimension faii(0:2,0:1,0:1)
      integer alfb(0:3), betb(0:3)
      dimension ipar(4), jpar(4)
      logical jac, mvflux, prtcpc, prtvel, prtphi, prtcdl
      integer ppp, qqq
!
      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.
      prtvel  =  .false.
      prtphi  =  .false.
      prtcdl  =  .true.
!
      p33     =  1.d0/3.d0
      p066    =  1.d0/15.d0
      sgp(0)  =  -p33
      sgp(1)  =   p33
      mvflux  =  .true.
      if( ifmcpr .ne. 0 ) write(6,3000) knet, knet
      write (6,'(''  mvflux = '',l4)') mvflux
!
      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
!                                  GIVEN vc; lc2g,klc2g,cc2g
!                                  COMPUTE: cpg,dcpg
      jac     =  .true.
!                                  nprcof = [1,2,3,4]
!                                  as: [linear,slender,2nd,isen]
!                                  indp = [1,2,3] as: [linear,2nd,isen]
!                                  with slender mapped to 2nd order
      indp    =  2
      if ( nprcof.eq.1 ) indp = 1
      if ( nprcof.eq.4 ) indp = 3
!                                  compute pressure and d(cp)/d(v) 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)
            ksf     =  (3-2*iul)*knet
            call cpcalx (ksf,indp,vc(1,kl,iul),cpc(kl,iul)              &
     &                  ,jac,dcpc(1,kl,iul))
  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)
      call dcopy (3,  0.d0,0,  afet,1)
      call dcopy (3,  0.d0,0,  amet,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
      tra    =  0.d0
      ta     =  0.d0
      tca    =  0.d0
      call dcopy (9,  0.d0,0,  afnw,1)
      call dcopy (9,  0.d0,0,  amnw,1)
      mpan    =  m-1
      npan    =  n-1
      call dcopy (3*mpan*npan,  0.d0,0,  afkl,1)
      call dcopy (3*mpan*npan,  0.d0,0,  amkl,1)
!
      do 605 l = 1,n-1
      call dcopy (9,  0.d0,0,  afc,1)
      call dcopy (9,  0.d0,0,  amc,1)
!
      do 600 k = 1,m-1
         kl      =  k + (l-1)*(m-1)
         sgul    =  -1.d0
!
         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)
!                                  panel center velocity and massflux
         call dcopy (3,  vc(1,kl,iul),1,  vkl,1)
         call cmpscl (betams,compd,vkl,wkl)
         call daxpy (3,  1.d0,  fsv(1,isol),1,  vkl,1)
         call daxpy (3,  1.d0,  fsv(1,isol),1,  wkl,1)
!
         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 )
         call cmpscl (betams,compd,   qsxqt  , enpt(1,0))
         call cmpscl (betams,compd,   qsxqst , enpt(1,1))
         call cmpscl (betams,compd,  qstxqt  , enpt(1,2))
!                                  update crude estimates of the total
!                                  contributions of afe, ame
!
         call dcopy (3,  0.d0,0,  fex,1)
!                                  fey = sgfme*( int n dS ).W/c V/c
         diag = ddot(3,  qsxqt,1,  wkl,1)
         do 330 kk = 1,3
            fey(kk) = 4.d0*sgfme*diag*vkl(kk)
  330    continue
         if ( mvflux ) then
            call daxpy (3,  1.d0,  fey,1,  afet,1)
            call daxpy (3,  1.d0,  fey,1,  fex,1)
         endif
!                                  sg * ( int n dS ) C/p
         cpckl   =  sgul*cpc(kl,iul)
         call daxpy (3,  4.d0*cpckl,  qsxqt,1,  afet,1)
         call daxpy (3,  4.d0*cpckl,  qsxqt,1,  fex,1)
!                                  extra term in the moment estimator,
!                                  (q(0)-r(0)) x sgfme (int ndS).W/c V/c
         call cross (qmr,fey,qmrxf)
         call daxpy (3,  1.d0,  qmrxf,1,  amet,1)
!                                  pressure term
!                                  (q(0)-r(0)) x sg * int c/p  n dS
         call cross (qmr,qsxqt,qmrxf)
         call daxpy (3,  4.d0*cpckl,  qmrxf,1,  amet,1)
!
         call dcopy (3,  0.d0,0,  amex,1)
         do 340 qqq = 1,3
            call cross (dd(1,qqq),vkl,qmrxf)
            sum      =  0.d0
            do 335 ppp = 0,2
               sum  =  sum + sgfme * hh(alfb(ppp)+alfb(qqq))            &
     &                             * hh(betb(ppp)+betb(qqq))            &
     &                             * ddot (3,  wkl,1,  enp(1,ppp),1)
!                                   sg * c/p * int ( D_q x N_p )
               facx  =  cpckl * hh(alfb(ppp)+alfb(qqq))                 &
     &                        * hh(betb(ppp)+betb(qqq))
               call cross (dd(1,qqq),enp(1,ppp),dxn)
               call daxpy (3,  facx,  dxn,1,  amet,1)
  335       continue
            if ( mvflux ) call daxpy (3,  sum,  qmrxf,1,  amex,1)
  340    continue
         if ( mvflux ) call daxpy (3,  1.d0,  amex,1,  amet,1)
!                                   DIAGNOSTIC PRINTOUT
 6001    format (' FMKAL:',3i3,f9.4,1x,3f9.4,1x,3f9.4,1x,3f9.4)
!----         write (6,6001) knet,k,l,cpc(kl,iul),qsxqt,vkl,fex
!
         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 velocities and mass flux
!                                   at panel corners
         call dcopy (3*4,  0.d0,0,  vb,1)
         call dcopy (3*4,  0.d0,0,  wb,1)
         ijp     =  0
         do 400 jp = 0,1
            do 380 ip = 0,1
               ijp     =  ijp + 1
               i       =  k+ip
               j       =  l+jp
               ij      =  i + (j-1)*m
               npk     =  lc2g(k,l)
               do 350 ll = 1,npk
                  klc     =  klc2g(ll,k,l)
                  cc2gx   =  cc2g(ijp,ll,k,l)
                  call daxpy (3, cc2gx, vc(1,klc,iul),1, vb(1,ijp),1)
!--                  call daxpy (3, cc2gx, wc(1,klc,iul),1, wb(1,ijp),1)
  350          continue
!                                   use next 2 lines if wc not given
               call cmpscl (betams,compd,vb(1,ijp),wb(1,ijp))
               call daxpy (3, 1.d0, fsv(1,isol),1, wb(1,ijp),1)
!                                   add in free stream
               call daxpy (3,  1.d0,  fsv(1,isol),1,  vb(1,ijp),1)
               do 360 ppp = 0,2
                  enpw(ppp,ijp) = ddot(3,  enp(1,ppp),1,  wb(1,ijp),1)
  360          continue
               do 380 qqq = 1,3
                  call cross (dd(1,qqq),vb(1,ijp),ddxvb(1,qqq,ijp))
  380          continue
  400    continue
!
         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
!                                     compute afe, ame and derivs
               call dcopy (3,  0.d0,0,  afe,1)
               call dcopy (3,  0.d0,0,  ame,1)
               do 450 ijpp = 1,4
                  ipp     =  ipar(ijpp)
                  jpp     =  jpar(ijpp)
                  do 430 ppp = 0,2
                     facx = sgfme  * faii(alfb(ppp),ip,ipp)             &
     &                             * faii(betb(ppp),jp,jpp)
                     facf = facx * enpw(ppp,ijp)
                     call daxpy (3, facf, vb(1,ijpp),1, afe,1)
                     facf  =  facx * enpw(ppp,ijpp)
                     do 420 qqq = 1,3
                        facx = sgfme                                    &
     &                              *faii(alfb(qqq)+alfb(ppp),ip,ipp)   &
     &                              *faii(betb(qqq)+betb(ppp),jp,jpp)
                        facm = facx * enpw(ppp,ijp)
                        call daxpy (3,facm,ddxvb(1,qqq,ijpp),1,ame,1)
!
  420                continue
  430             continue
  450          continue
!                                   perform origin shift for moment ints
               call cross (qmr,afe,qmrxfe)
               call daxpy (3,  1.d0,  qmrxfe,1,  ame,1)
!
               cpgg    =  0.d0
               npk     =  lc2g(k,l)
               do 480 ll = 1,npk
                  klc     =  klc2g(ll,k,l)
                  if ( klc.eq.0 ) goto 480
                  cc2gx   =  cc2g(ijp,ll,k,l)
                  cpgg    =  cpgg + cc2gx*cpc(klc,iul)
  480          continue
               cpgx(ijp) = cpgg
               sgulcp  =  sgul*cpgg
!                                  accumulate into dfdv
!                    fklij  =   (q x q ) + sg  (q x q  ) + sg  (q  x q )
!                                 s   t      i'  s   st      j'  st   t
               fklij(1) = qsxqt(1) +sgip*qsxqst(1) +sgjp*qstxqt(1)
               fklij(2) = qsxqt(2) +sgip*qsxqst(2) +sgjp*qstxqt(2)
               fklij(3) = qsxqt(3) +sgip*qsxqst(3) +sgjp*qstxqt(3)
               call daxpy (3,  sgulcp,  fklij,1,  af,1)
               call daxpy (3,  sgulcp,  fklij,1,  afpan,1)
               call cross (qmr,fklij,qmrxf)
!                                  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 490 kk = 1,3
                  amz(kk) = amzqs*qs(kk) + amzqt*qt(kk) + amzqst*qst(kk)
!                                   m = m(0) + (qz - rz) x f
                  amklij(kk) = amz(kk) + qmrxf(kk)
  490          continue
               call daxpy (3,  sgulcp,  amklij,1,  am,1)
               call daxpy (3,  sgulcp,  amklij,1,  ampan,1)
!                                  ADD IN EXTRA TERM CONTRIBUTIONS
               if ( mvflux ) then
                  call daxpy (3,  1.d0,  afe,1,  af,1)
                  call daxpy (3,  1.d0,  ame,1,  am,1)
                  call daxpy (3,  1.d0,  afe,1,  afpan,1)
                  call daxpy (3,  1.d0,  ame,1,  ampan,1)
               endif
!                                  end of loops on panel's 4 corners
  540       continue
  550    continue
         call dscal (3,  1.d0/sref,  afpan,1)
         call dscal (3,  1.d0/sref,  ampan,1)
         ampan(1) = ampan(1)/bref
         ampan(2) = ampan(2)/cref
         ampan(3) = ampan(3)/dref
!--         write (6,6002) knet,k,l,afpan,ampan
 6002    format (' FMKAL-PANEL:',3i4,3x,3f12.7,3x,3f12.7)
!
         call daxpy (3,  1.d0,  afpan,1,  afc(1,iul),1)
         call daxpy (3,  1.d0,  ampan,1,  amc(1,iul),1)
         call daxpy (3,  1.d0,  afpan,1,  afc(1,3),1)
         call daxpy (3,  1.d0,  ampan,1,  amc(1,3),1)
         call daxpy (3,  1.d0,  afpan,1,  afkl(1,k,l),1)
         call daxpy (3,  1.d0,  ampan,1,  amkl(1,k,l),1)
!                                 end up loop on upper/lower surfaces
  590 continue
!                                 end of loop on rows in network
  600 continue
      if ( ifmcpr.ne.1 ) goto 601
         write (6,3500) l
         write (6,3001) tra, (afc(kk,1),kk=1,3)                         &
     &                     , (amc(kk,1),kk=1,3)                         &
     &                 ,tra, (afc(kk,2),kk=1,3)                         &
     &                     , (amc(kk,2),kk=1,3)                         &
     &                 ,tra, (afc(kk,3),kk=1,3)                         &
     &                     , (amc(kk,3),kk=1,3)
  601 continue
      call daxpy (9,  1.d0,  afc,1,  afnw,1)
      call daxpy (9,  1.d0,  amc,1,  amnw,1)
!                                 end of loop on columns in network
  605 continue
!                                 standard printout
      call daxpy (9,  1.d0,  afnw,1,  aft,1)
      call daxpy (9,  1.d0,  amnw,1,  amt,1)
      if ( ifmcpr.eq.0 ) go to 950
      write (6,4000)
      write (6,4001) ta, (afnw(kk,1),kk=1,3)                            &
     &                 , (amnw(kk,1),kk=1,3)                            &
     &              ,ta, (afnw(kk,2),kk=1,3)                            &
     &                 , (amnw(kk,2),kk=1,3)                            &
     &              ,ta, (afnw(kk,3),kk=1,3)                            &
     &                 , (amnw(kk,3),kk=1,3)
!
      write (6,5000)
      write (6,5001) tca, (aft(kk,1),kk=1,3)                            &
     &                  , (amt(kk,1),kk=1,3)                            &
     &              ,tca, (aft(kk,2),kk=1,3)                            &
     &                  , (amt(kk,2),kk=1,3)                            &
     &              ,tca, (aft(kk,3),kk=1,3)                            &
     &                  , (amt(kk,3),kk=1,3)
  950 continue
!
! ----      call outmvc ('F(k,l)',mpan,mpan,npan,afkl)
! ----      call outmvc ('M(k,l)',mpan,mpan,npan,amkl)
      radfac  =  pi/180.d0
      aarg    =  alpha(isol)*radfac
      barg    =   beta(isol)*radfac
      call rotate (arotfs,  aarg,barg)
      call hsmmp1 (3,3,mpan*npan,  arotfs,1,3,  afkl,1,3,  amkl,1,3)
      if ( prtcdl ) call outmvc ('CD/CY/CLkl',mpan,mpan,npan,amkl)
!                                 apply scale factors to output
      call dscal (3,  1.d0/sref,  af,1)
      call dscal (3,  1.d0/sref,  am,1)
      am(1) = am(1)/bref
      am(2) = am(2)/cref
      am(3) = am(3)/dref
!                                 compare the crude with the exact
!                                 estimates of af, am
      call dscal (3,  1.d0/sref,  afet,1)
      call dscal (3,  1.d0/sref,  amet,1)
      amet(1) = amet(1)/bref
      amet(2) = amet(2)/cref
      amet(3) = amet(3)/dref
      call outvec ('afe-crude',3,afet)
      call outvec ('afe-exact',3,af)
      call outvec ('ame-crude',3,amet)
      call outvec ('ame-exact',3,am)
      call hsmmp1 (3,3,1,  arotfs,1,3,  af,1,3,  afrot,1,3)
      call outvec ('CD/CY/CL K',3,afrot)
      return
!
 1200 continue
      call remarx ('fmkal: fatal error')
      CALL AbortPanair('fmkal')
!                                  standard printout
!
!
!
!                                  formats for standard printout
 3000 format(1h1,/,'0*b*for-mom-net#-',i3,/,46x,                        &
     &       'force / moment data for network ',i5,////)
 3500 format(//,1x,17htotals for column,2x,i5,10x,4harea,5x,            &
     &6x,2hfx,12x,2hfy,12x,2hfz,12x,2hmx,12x,2hmy,12x,2hmz,6x,//)
 3001 format(30x,7f14.5)
 4000 format(//,1x,18htotals for network,16x,4harea,5x,                 &
     &6x,2hfx,12x,2hfy,12x,2hfz,12x,2hmx,12x,2hmy,12x,2hmz,6x,//)
 4001 format(30x,7f14.5)
 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,//)
 5001 format(30x,7f14.5)
!
!
      END subroutine fmkal
! **deck fmkvav
      subroutine fmkvav (isol,s,   zctr,pvactr,  phnw,vnw)
      implicit double precision (a-h,o-z)
! --- dimension s(nsngt)
      dimension s(1:*)
      dimension zctr(3,1:*), pvactr(4,1:*)
! --- dimension phnw(mxntpn), vnw(3,mxntpn)
      dimension phnw(1:*), vnw(3,1:*)
!
!     evaluate the average potential and  velocity at panel centers on
!     all networks for subsequent use by FMKAL, the F&M routine
!     that includes the momentum transfer term.
!
!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 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
!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
!call mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!call rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!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 rtrnbk
      common /rtrnbk/ cpr(3,4), enr(3,5), diamr, itdm, itsr, icsr, isqnr&
     &              , ipr, kpr, pwr(3), pxr, rfminr, qdltr, rqffr(3,4)  &
     &              , c1r, c2r, c3r, aqr(9), encfr(3)                   &
     &              , sv1r1(3), dv1r1(6), dvzr1(9), amuxr1(3)           &
     &              , sv2r1(3,2), dv2r1(10,2)                           &
     &              , sv8r1(3,8), dv8r1(6,8)                            &
     &              , usvr1(6),  uvmvr1(4,6), amsvr1(3,3), amdvr1(3,3)  &
     &              , sv1r2(3), dv1r2(6), dvzr2(9), amuxr2(3)           &
     &              , sv2r2(3,2), dv2r2(10,2)                           &
     &              , sv8r2(3,8), dv8r2(6,8)                            &
     &              , usvr2(6),  uvmvr2(4,6), amsvr2(3,3), amdvr2(3,3)  &
     &              , sv1r3(3), dv1r3(6), dvzr3(9), amuxr3(3)           &
     &              , sv2r3(3,2), dv2r3(10,2)                           &
     &              , sv8r3(3,8), dv8r3(6,8)                            &
     &              , usvr3(6),  uvmvr3(4,6), amsvr3(3,3), amdvr3(3,3)  &
     &              , sv1r4(3), dv1r4(6), dvzr4(9), amuxr4(3)           &
     &              , sv2r4(3,2), dv2r4(10,2)                           &
     &              , sv8r4(3,8), dv8r4(6,8)                            &
     &              , usvr4(6),  uvmvr4(4,6), amsvr4(3,3), amdvr4(3,3)
      integer rtrnbf(435)
      equivalence (rtrnbf,cpr)
!
!end  rtrnbk
!
      dimension pvx(4), vdry(3)
      dimension zcgd(3), rctr(3)
      logical ppvctr, stagbc, wakenw
      logical nwphev(mxnett)
!
      data delta /.01d0/
!
      ppvctr  =  .false.
      call dcopy (3,  fsv(1,isol),1,  vdry,1)
      call cmpscl (1.d0/betams,compd,vdry,vdry)
      call dscal (3,  -1.d0,  vdry,1)
      call dcopy (4*npant,  0.d0,0,  pvactr,1)
!                                  construct array of panel center
!                                  control points
      do 100 knet = 1,nnett
         mpan    =  nm(knet)-1
         npan    =  nn(knet)-1
         npak    =  npa(knet)
         nzak    =  nza(knet)
         ipotk   =  ipot(knet)
         iapotk  =  iabs(ipotk)
         ntdk    =  ntd(knet)
         wakenw  =  (ntdk.eq.6) .or. (ntdk.eq.18) .or. (ntdk.eq.20)
         stagbc  =  .false.
         if ( ipotk.ne.0 .and.  (.not.wakenw) ) stagbc = .true.
!---         write (6,'('' FMKVAV: knet,stagbc = '',i5,l4)') knet,stagbc
!                                  if no proper stagnation b.c.'s are
!                                  observed, ph and v average must
!                                  be evaluated via pivv calls.  Set
!                                  nwphev(knet) to reflect this fact.
!                                  Note, however, that we still need
!                                  to compute evaluation point locations
         nwphev(knet) = (.not.stagbc)
         facpv   =  .5d0
         if ( ipotk.lt.0 ) facpv = -.5d0
         iul     =  1
         if ( ipotk.lt.0 ) iul = 2
         call dcopy (3,  zctrgn(1,iul,knet),1,  rctr,1)
!                                   Generate evaluation points and
!                                   compute  phi, v  for stagnation
         do 90 jpan = 1,npan
         do 80 ipan = 1,mpan
            ip       =  ipan + (jpan-1)*mpan + npak
            call strns (ip,cp)
            call xxadj (cp(1,9),cp(1,5),cp(1,8),delta,zcgd)
            call surpro (zcgd,zctr(1,ip),icc)
!---            write (6,'('' FMKVAV, zc calc:'',4i5,3f12.6)')
!---     x           knet,ipan,jpan,ip,(zctr(kk,ip),kk=1,3)
            if ( .not.stagbc ) goto 80
!                                  evaluate the difference of phi and v
!                                  and transform it into an average
            call dsncdv (ip,cp,s,  pvx)
            call dscal (4,  facpv,  pvx,1)
!                                  adjust for TOTAL massflux stagnation
            if ( iapotk.ge.3 ) then
               phdry  =  (zctr(1,ip)-rctr(1))*vdry(1)                   &
     &                  +(zctr(2,ip)-rctr(2))*vdry(2)                   &
     &                  +(zctr(3,ip)-rctr(3))*vdry(3)
               pvx(1) = pvx(1) + phdry
               pvx(2) = pvx(2) + vdry(1)
               pvx(3) = pvx(3) + vdry(2)
               pvx(4) = pvx(4) + vdry(3)
            endif
!                                  save the result
            call dcopy (4,  pvx,1,  pvactr(1,ip),1)
   80    continue
   90    continue
  100 continue
!                                  loop over the panels requested for
!                                  off body calculations
      rewind ntr
      do 150 ipx = 1,npanr
          read (ntr) (rtrnbf(i),i=1,nrdq)
          call rtunpk
          ip      =   ipr
!
          do 140 knet = 1,nnett
             mpan     =  nm(knet)-1
             npan     =  nn(knet)-1
             npak     =  npa(knet)
             ntdk     =  ntd(knet)
             if ( .not.nwphev(knet) ) goto 140
             do 120 jpan = 1,npan
             do 120 ipan = 1,mpan
                ipc      =  ipan + (jpan-1)*(nm(knet)-1) + npak
                call dcopy (3,  zctr(1,ipc),1,  zcgd,1)
                call zero (pvx,4)
                call pivv (isol,ipc,zctr(1,ipc),pvx)
                call daxpy (4,  1.d0,  pvx,1,  pvactr(1,ipc),1)
  120        continue
  140    continue
!
  150 continue
!                                  print it all out
      do 300 knet = 1,nnett
         npak    =  npa(knet)
         mpan    =  nm(knet) - 1
         npan    =  nn(knet) - 1
         do 200 jpan = 1,npan
         do 200 ipan = 1,mpan
            ip      =  ipan + (jpan-1)*mpan + npak
            if ( ppvctr )                                               &
     &           write (6,6001) ip,knet,ipan,jpan, (zctr(l,ip),l=1,3)   &
     &                         ,(pvactr(l,ip),l=1,4)
  200    continue
  300 continue
 6001 format (1x,i4,1x,3i4,2x,3f11.6,2x,f11.6,2x,3f11.6)
!                                  put it out in matrix format
      do 400 knet = 1,nnett
         npak    =  npa(knet)
         mpan    =  nm(knet) - 1
         npan    =  nn(knet) - 1
         do 350 jpan = 1,npan
         do 350 ipan = 1,mpan
            ip      =  ipan + (jpan-1)*mpan + npak
            ij      =  ipan + (jpan-1)*mpan
            call dcopy (3,  pvactr(2,ip),1,  vnw(1,ij),1)
            phnw(ij) = pvactr(1,ip)
  350    continue
         if ( ppvctr ) then
            write (6,'('' phi and v average for nw:'',i5)') knet
            call outmat ('phi',mpan,mpan,npan,phnw)
            call outmvc ('vel',mpan,mpan,npan,vnw)
         endif
  400 continue
!
      call cstprt ('fmkvav  ')
      return
      END subroutine fmkvav
! **deck fmkvul
      subroutine fmkvul (knet,mk,nk,isol,s,   pvactr,  phul,vul)
      implicit double precision (a-h,o-z)
      dimension s(4000)
      dimension pvactr(4,1:*)
      dimension phul(mk-1,nk-1,2), vul(3,mk-1,nk-1,2)
!
!     evaluate the average potential and  velocity at panel centers on
!     all networks for subsequent use by FMKAL, the F&M routine
!     that includes the momentum transfer term.
!
!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 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
!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
!call mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!call rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!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 rtrnbk
      common /rtrnbk/ cpr(3,4), enr(3,5), diamr, itdm, itsr, icsr, isqnr&
     &              , ipr, kpr, pwr(3), pxr, rfminr, qdltr, rqffr(3,4)  &
     &              , c1r, c2r, c3r, aqr(9), encfr(3)                   &
     &              , sv1r1(3), dv1r1(6), dvzr1(9), amuxr1(3)           &
     &              , sv2r1(3,2), dv2r1(10,2)                           &
     &              , sv8r1(3,8), dv8r1(6,8)                            &
     &              , usvr1(6),  uvmvr1(4,6), amsvr1(3,3), amdvr1(3,3)  &
     &              , sv1r2(3), dv1r2(6), dvzr2(9), amuxr2(3)           &
     &              , sv2r2(3,2), dv2r2(10,2)                           &
     &              , sv8r2(3,8), dv8r2(6,8)                            &
     &              , usvr2(6),  uvmvr2(4,6), amsvr2(3,3), amdvr2(3,3)  &
     &              , sv1r3(3), dv1r3(6), dvzr3(9), amuxr3(3)           &
     &              , sv2r3(3,2), dv2r3(10,2)                           &
     &              , sv8r3(3,8), dv8r3(6,8)                            &
     &              , usvr3(6),  uvmvr3(4,6), amsvr3(3,3), amdvr3(3,3)  &
     &              , sv1r4(3), dv1r4(6), dvzr4(9), amuxr4(3)           &
     &              , sv2r4(3,2), dv2r4(10,2)                           &
     &              , sv8r4(3,8), dv8r4(6,8)                            &
     &              , usvr4(6),  uvmvr4(4,6), amsvr4(3,3), amdvr4(3,3)
      integer rtrnbf(435)
      equivalence (rtrnbf,cpr)
!
!end  rtrnbk
!
      dimension pvx(4), vdry(3), pvul(4,2)
      dimension zcgd(3), rctr(3)
      logical ppvctr, stagbc, wakenw
!
      data delta /.01d0/
!
      ppvctr  =  .false.
      call dcopy (3,  fsv(1,isol),1,  vdry,1)
      call cmpscl (1.d0/betams,compd,vdry,vdry)
      call dscal (3,  -1.d0,  vdry,1)
!                                  construct array of panel center
!                                  control points
      mpan    =  nm(knet)-1
      npan    =  nn(knet)-1
      npak    =  npa(knet)
      nzak    =  nza(knet)
      ipotk   =  ipot(knet)
      iapotk  =  iabs(ipotk)
      ntdk    =  ntd(knet)
      wakenw  =  (ntdk.eq.6) .or. (ntdk.eq.18) .or. (ntdk.eq.20)
      stagbc  =  .false.
      if ( ipotk.ne.0 .and.  (.not.wakenw) ) stagbc = .true.
      facpv   =  .5d0
      if ( ipotk.lt.0 ) facpv = -.5d0
      iul     =  1
      if ( ipotk.lt.0 ) iul = 2
      call dcopy (3,  zctrgn(1,iul,knet),1,  rctr,1)
!
      do 90 jpan = 1,npan
         do 80 ipan = 1,mpan
!
            ip       =  ipan + (jpan-1)*mpan + npak
            call strns (ip,cp)
            call xxadj (cp(1,9),cp(1,5),cp(1,8),delta,zcgd)
            call surpro (zcgd,zcc,icc)
!                                  copy in the average values of phi, v
            call dcopy (4,  pvactr(1,ip),1,  pvul(1,1),1)
            call dcopy (4,  pvactr(1,ip),1,  pvul(1,2),1)
!                                  evaluate the difference of phi and v
!                                  and transform it into an average
            call dsncdv (ip,cp,s,  pvx)
            call daxpy (4,  .5d0,  pvx,1,  pvul(1,1),1)
            call daxpy (4, -.5d0,  pvx,1,  pvul(1,2),1)
            do 60 iul = 1,2
               phul(ipan,jpan,iul) = pvul(1,iul)
               vul(1,ipan,jpan,iul)= pvul(2,iul)
               vul(2,ipan,jpan,iul)= pvul(3,iul)
               vul(3,ipan,jpan,iul)= pvul(4,iul)
   60       continue
!
   80    continue
   90 continue
  100 continue
      if ( ppvctr ) then
         write (6,'('' FMKVUL: phi and v for nw '',i5)') knet
         call outmat ('phi-up',mpan,mpan,npan,phul(1,1,1))
         call outmat ('phi-lo',mpan,mpan,npan,phul(1,1,2))
         call outmvc ('v-up',mpan,mpan,npan,vul(1,1,1,1))
         call outmvc ('v-lo',mpan,mpan,npan,vul(1,1,1,2))
      endif
!
      return
      END subroutine fmkvul
! **deck fndpts
      subroutine fndpts(p1,p2,p3,cp,q1,q2,q3,cq,   insidf)
      implicit double precision (a-h,o-z)
!
!     purpose: find intersection points
!
!     inputs:  p1,p2,p3 points of first triangle
!              q1,q2,q3 points of second triangle
!              cp,cq    coefficients of planes
!
!     outputs: insidf   flag indicating intersection occurs
!
      dimension p1(3), p2(3), p3(3)
      dimension q1(3), q2(3), q3(3)
      dimension cp(4), cq(4)
      dimension pint(3,4,2)
      dimension iflags(3,2)
!
      logical   insidf
!
!     initialize flags
!
      insidf = .false.
!
      do 10 i=1,3
      do 10 j=1,2
      iflags(i,j) = 0
   10 continue
!
!                      iside,itri
      call getpnt(q1,q2,cp,1,2,   pint,iflags)
      call getpnt(q2,q3,cp,2,2,   pint,iflags)
      call getpnt(q3,q1,cp,3,2,   pint,iflags)
      call getpnt(p1,p2,cq,1,1,   pint,iflags)
      call getpnt(p2,p3,cq,2,1,   pint,iflags)
      call getpnt(p3,p1,cq,3,1,   pint,iflags)
!
      call duzint(cp,cq,pint,iflags,   insidf)
!
      return
      END subroutine fndpts
! **deck fngrid
      subroutine fngrid (m,n,z,  ifn,jfn,  zfg)
      implicit double precision (a-h,o-z)
      dimension z(3,m,n), zfg(3)
!
!     given the coordinates of a network, and a fine grid location
!     (ifn,jfn), compute the location of that fine grid point, zfg
!
      i1      =  (ifn+1)/2
      i2      =  (ifn+2)/2
      j1      =  (jfn+1)/2
      j2      =  (jfn+2)/2
      do 100 k = 1,3
         zfg(k) = .25d0*( z(k,i1,j1) + z(k,i1,j2)                       &
     &                   +z(k,i2,j1) + z(k,i2,j2) )
  100 continue
      return
      END subroutine fngrid
! **deck frecor
      subroutine frecor (label)
      character*(*) label
!
!        deallocate the dynamic memory subsidiary to the dynamic memory
!        label, 'label'.
!
!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,7100) label
 7100 format ( 1x, 27( 4h * /  ), ' frecor : ',a )
      if ( iniset .ne. 'goodcore' ) go to 1000
!
      if ( levprt ) write (6,6200) label
      isv     =  1
      if ( levdyn .eq. 1 ) go to 200
      do 100 ibk = 1,levdyn
          i       =  levdyn + 1 - ibk
          isv     =  i
          if ( chrlev(i).eq.label ) go to 110
  100 continue
      call remarx ('frecor: aborting due to unfound label')
      write (7,'('' label provided:'', a)') label
      do 105 i = 1,levdyn
         write (7,'('' label entry'',i3,'': '',a)') i,chrlev(i)
  105 continue
      CALL AbortPanair('frecor-1')
!
  110 continue
      if ( isv.eq.levdyn ) go to 200
!
          write (6,6000)
          write (6,6100) label, isv, (i,chrlev(i),i=1,levdyn)
  200 continue
      levdyn  =  isv - 1
      if ( levdyn .gt. 0 ) return
!                                  returned to the bottom level
!                                  generate statistics, reset and return
      if ( .not. sumprt ) go to 250
      write (6,6300) mxxlev, maxlev, mxxlws, maxlws, mxxdyn, maxdyn
  250 continue
      iniset  =  label
      if ( iniset .eq. 'goodcore' ) iniset = 'badclean'
      return
!
 1000 continue
      write (6,6500) label, iniset
      CALL AbortPanair('frecor-2')
 6500 format (' *****  error  *****   frecor called before inicor.  labe&
     &l  =  ',a,'    status word  =  ',a)
 6000 format ('0 *** warning ***      frecor called incorrectly')
 6100 format (1x,a,i6,/,(1x,i4,1h.,1x,a) )
 6200 format ('  frecor call : ',a)
 6300 format (//,1x,100(1h*),//,                                        &
     &  '  dynamic memory summary    ', '      used',2x,' allocated',/, &
     &  '  maximum number of levels  ',i10,2x,i10 ,/,                   &
     &  '  maximum number of arrays  ',i10,2x,i10 ,/,                   &
     &  '  maximum dynamic memory    ',i10,2x,i10 ,/,                   &
     &  /,1x,100(1h*) )
      END subroutine frecor
! **deck fsgcmp
      subroutine fsgcmp (kmp,nedmpa,nfsga,kfdseg,nnett                  &
     &                  ,kfsg1,kfsg2)
      implicit double precision (a-h,o-z)
      dimension nedmpa(1:*), nfsga(1:*), kfdseg(1:*), ivseg(4)
!         find the index of the incoming fundamental edge segment (kfsg1
!         and the outgoing fundamental edge segment (kfsg2) for edge
!         mesh point  kmp
      nind    =  4*nnett + 1
      call ibsrch (nedmpa,nind,kmp,l)
      if ( l.le.0 .or. l.ge.nind ) go to 1100
      knet    =  (l+3)/4
      iedg1   =  4*(knet-1)+1
      ifsg1   =  nfsga(iedg1)+1
      ifsg2   =  nfsga(iedg1+4)
      kmp2x   =  nedmpa( 4*knet + 1 ) + 1
!
      kfsg1   =  ifsg2
      do 100 ifsg = ifsg1,ifsg2
          call icopy (4,  kfdseg(4*ifsg-3),1, ivseg,1)
          call edgmpi (ivseg(2),ivseg(3),nedmpa,  kmp1)
          call edgmpi (ivseg(2),ivseg(4),nedmpa,  kmp2)
          if ( ifsg.eq.ifsg2 .and. mod(ivseg(2),4).eq.0 ) kmp2 = kmp2x
          kfsg2   =  ifsg
          if ( kmp.le.kmp1 ) go to 200
          kfsg1   =  ifsg
          if ( kmp.lt.kmp2 ) go to 200
  100 continue
      kfsg2   =  ifsg1
  200 continue
      return
!
 1100 continue
      write (6,'(1x,a10,1x, 3i12)')                                     &
     & 'nind,l,kmp',nind,l,kmp
      call outvci ('nedmpa',nind,nedmpa)
      call abtend ('fsgcmp error:  index not found')
      END subroutine fsgcmp
! **deck fsolve
      subroutine fsolve (n,x,f,nitmax,ns,s                              &
     &                  ,b,scr,xnew,fnew,dphi,d                         &
     &                  ,dvdl,vica,vicd,aic                             &
     &                  ,alam,fv,dldx,dfdl,aj                           &
     &                  ,nsngt,sols)
      implicit double precision (a-h,o-z)
      dimension s(ns)
      dimension x(n), f(n)
!                                       local scratch
      dimension b(n,n), scr(n), xnew(n), fnew(n), dphi(n), d(n)
!                                       fhybrj scratch
      dimension dvdl(4,*), vica(3,*), vicd(3,*), aic(*)
      parameter (nb=20)
      dimension alam(*), fv(n), dldx(n), dfdl(nb,*), aj(nb,*)
      dimension sols(nsngt,4)
!
!         solve a nonlinear equation of the form  f(x) = 0  for the
!         n-vector x(1:n).  the function 'f' is specified by fhybrj.  th
!         solver takes advantage of the fact that for the a502 applicati
!         for which it was built, the function is either:
!              1) a quadratic function of 'x' (2nd order pressure b.c.'s
!              2) close to a quadratic function of 'x' (isentropic b.c.'
!         this assumption is used when the subroutine  cublns  is used t
!         perform the linear search along the newton search direction.
!         this method was first proposed in about 1978 by some japanese
!         researchers in connection with the power flow problem.
!
!         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
!         nitmax  i   int   maximum number of function evaluations befor
!                           quitting
!         s       i   r*8   scratch array , used by out-of-core solver
!                           -----  scratch storage for fsolve ------
!         b       s   r*8   needed for jacobian matrix if test = .true.
!         scr     s   r*8   scratch array used to read jacobian when
!                           test = .true.
!         xnew    s   r*8   new x, vector of unknowns for the n.l. prob.
!         fnew    s   r*8   new f, vector of residuals for the n.l. prob
!         dphi    s   r*8   scratch vector, used for sw checkout if test
!                           is set .true.
!         d       s   r*8   xnew - x; also used for other scratch
!                           purposes during the iteration.
!                           -----  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:
!         nlimat    readms/writms file containing jacobian, 1 row/record
!         nlitmp    readms/writms scratch file used by bksolv for the bl
!                   of the jacobian matrix
!         nlillu    readms/writms file containing the l*u factorization
!                   the jacobian matrix
!         nlirhs    sequential file containing the right hand side matri
!                   for the out-of-core solution performed by bksolv
!         nlibn     readms/writms scratch file for the blocking of the
!                   right hand side.  used by bksolv.
!         nlians    sequential file where bksolv returns its solution of
!                   the linear system.
!
!         michael epton,  30 november 1988
!
!
!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 nlilun
!         logical units for nonlinear iteration             /nlilun/
      common /nlilun/ nlimat, nlitmp, nlillu, nlirhs, nlibn, nlians     &
     &              , indmat(maxcp2+1)
!                                                           /nlilun/
!end  nlilun
!call cp2flg
!         /cp2flg/:  newton iteration, lambda print and cp2 print flags
      common /cp2flg/ istcp2, iexcp2, nitcp2
!end  cp2flg
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!call cjacnm
      common /cjacnm/ ajacnm
!end  cjacnm
      dimension nhdat(10)
      logical test
      character*65 lmsg
      character*12 lfnm
      character*1  lcase
      character*3 liter
!
!
!
      test    =  .false.
!                                  allocate scratch memory
      nnmat   =  maxcp2+1
      call openms (nlimat,indmat,nnmat,0)
!                                  perform up to  nitmax  iterations
      alfprv  =   1.d0
      do 100 it = 1,nitmax
      itlast  =  it
      if ( istcp2.le.3 ) goto 10
      write (6,'(1x,a10,1x, 2i12)')                                     &
     & 'case, iter',iacase,it
      call outvcx ('x-vector',n,x)
   10 continue
!                                  generate function and jacobian
      call fhybrj (n,x,f,nlimat,n,3                                     &
     &            ,dvdl,vica,vicd,aic                                   &
     &            ,alam,fv,dldx,dfdl,aj                                 &
     &            ,nsngt,sols)
      xscl    =  1.d0/ajacnm
! *** call wmatrx (58,a,n)
      ifmax   =  idamax (n,f,1)
      fmax    =  abs( f(ifmax) )
      if ( istcp2.ge.1 ) write (6,7001) iacase, it, fmax, ifmax
 7001 format (' case:',i3,'  iteration:',i3,'   max residual:'          &
     &       ,1pe12.4,'   at position',i4)
      if ( istcp2.ge.2 ) call outvcx ('residuals',n,f)
!                                  check convergence
      call vip (f,1,  f,1,  n,fsq)
      fnm  =  sqrt(fsq)
      if ( fnm .lt. 1.d-8 ) goto 110
!                                  get newton correction: d
      if ( .not.test ) goto 16
      do 15 i = 1,n
          call readmd (nlimat,scr,n,i)
          dphi(i) = scr(i)
          call dcopy (n,  scr,1,  b(i,1),n)
   15 continue
      call outvcx ('diags',n,dphi)
   16 continue
!                                  factor the jacobian
      nrhsnl      =  1
      call bkfact (s,ns,n,nrhsnl, nlimat,nlitmp,nlillu                  &
     &            , .false.,nhdat,ier)
      if ( ier.eq.0 ) goto 21
!                                  singular matrix
           write (6,7002) iacase, it
           goto 105
 7002 format (' singular jacobian, case',i3,', iteration',i4)
!                                  copy f(x) to the array d for the solv
   21 continue
      call dcopy (n,  f,1,  d,1)
!                                  write the right hand side to nlirhs
      rewind nlirhs
      do 25 i = 1,n
          write (nlirhs) d(i)
   25 continue
!                                  solve the system:  [j] [d] = [f]
      call bksolv (s,ns,n,nrhsnl,  nlillu,nlirhs,nlibn,nlians           &
     &            , .false.,nhdat,ier)
!                                  read the system solution
      rewind nlians
      do 30 i = 1,n
          read (nlians) d(i)
   30 continue
!                                  some debug output
      if ( test ) call hsmmp1 (n,n,1, b,1,n, d,1,n, dphi,1,n)
!---  call outvcx ('x',n,x)
!---  call outvcx ('j*j-1*f',n,dphi)
!---  call outvcx ('j-1 f',n,d)
!                                  put the sol'n of [j] [d] = -[f] into
      call dscal (n, -1.d0,  d,1)
!                                  limit d to .1*xscl,  xscl = 1./!df/dx
      call vip (d,1,  d,1,  n,dsq)
      call vip (x,1,  x,1,  n,xsq)
      dnm  =  sqrt(dsq)
      xnm  =  sqrt(xsq)
      alf  =  1.d0
      xscl    =   max ( xnm, xscl)
      if ( dnm.ne.0.d0 ) alf = min( 1.d0, .1d0*xscl/dnm)
      if ( fnm.le. 1.d-4 ) alf = 1.d0
      alf = min( 1.4d0*alfprv, alf)
      alf  =  max( alf, .001d0 )
      if ( iexcp2.lt.1 ) goto 35
      write (6,'(1x,a10,1x, 1pe12.4)')                                  &
     & '++fsolve',fnm,dsq,xsq,dnm,xnm,ajacnm,xscl,alf                   &
     &                          ,alfprv
   35 continue
! -------------------------------  check jacobian, start
      if ( .not. test ) goto 41
      call dcopy (n,  0.d0,0,  dphi,1)
      do 40 kt = -1,1,2
          t  =  kt*.001d0
          call vadd (x,t,d,xnew,n)
          call fhybrj (n,xnew,fnew,nlimat,n,1                           &
     &                ,dvdl,vica,vicd,aic                               &
     &                ,alam,fv,dldx,dfdl,aj                             &
     &                ,nsngt,sols)
          at  =  kt
          call daxpy (n,  at,  fnew,1,  dphi,1)
   40 continue
      call dscal (n,  1.d0/(.002d0),  dphi,1)
      call outvcx ('dphi',n,dphi)
      call outvcx ('f',n,f)
   41 continue
! -------------------------------  check jacobian, end
!
!                                  update of the x-vector
      t       =  1.d0
      if ( fnm.lt. 1.d-5 ) goto 90
      call vadd (x,alf,d,xnew,n)
      call fhybrj (n,xnew,fnew,nlimat,n,1                               &
     &            ,dvdl,vica,vicd,aic                                   &
     &            ,alam,fv,dldx,dfdl,aj                                 &
     &            ,nsngt,sols)
      call vip (fnew,1,  fnew,1,  n,fsq)
      fnm  =  sqrt(fsq)
!                                  do line search for newton's method,
!                                  finding the global minimum in the cas
!                                  that f(x) is quadratic in x, as is th
!                                  case when a 2nd order pressure formul
!                                  is used.
      call cublns (n,f,fnew,alf,t)
!
   90 continue
      call vadd (x,t,d,xnew,n)
      call dcopy (n,  xnew,1,  x,1)
!                                  set alfprv to current alf for use in
!                                  the step control strategy
      alfprv  =  alf
  100 continue
!                                  looks like a failure.  double check a
!                                  issue messages if necessary
  105 continue
      call fhybrj (n,x,f,nlimat,n,1                                     &
     &            ,dvdl,vica,vicd,aic                                   &
     &            ,alam,fv,dldx,dfdl,aj                                 &
     &            ,nsngt,sols)
      call vip (f,1,f,1,n,fsq)
      fnm     =  sqrt(fsq)
      if ( fnm.lt. 1.d-8 ) goto 110
!
      write (6,6001) iacase, fnm
 6001 format (                                                          &
     & //, '   ************************************************ '       &
     & ,/, '   *                                              * '       &
     & ,/, '   *   nonlinear iteration failed to converge     * '       &
     & ,/, '   *                                              * '       &
     & ,/, '   *   case number ',i1,',  function norm = ',1p,e8.2       &
     &                                                          ,'   * '&
     & ,/, '   *                                              * '       &
     & ,/, '   ************************************************ '       &
     &  )
      call outvcx ('f-vector',n,f)
!                                  generate the logfile message
      write (lcase,'(i1)') iacase
      write (lfnm,'(1p,e8.2)') fnm
      lmsg =                                                            &
     &'  newton iteration failure, case x, function norm = n.nne-nn    '
!      12345678901234567890123456789012345678901234567890123456789012345
!               1         2         3         4         5         6
      lmsg(34:34) = lcase
      lmsg(53:60) = lfnm
      call remarx (lmsg)
      goto 200
!
!
  110 continue
!                                  generate logfile/output file message
      lmsg =                                                            &
     &'  iteration convergence, case x, xxx iterations, f-norm n.nne-nn'
!      12345678901234567890123456789012345678901234567890123456789012345
!                1         2         3         4         5         6
      write (lcase,'(i1)') iacase
      write (liter,'(i3)') itlast
      write (lfnm,'(1p,e8.2)') fnm
      lmsg(31:31) = lcase
      lmsg(34:36) = liter
      lmsg(57:64) = lfnm
      call remarx (lmsg)
      write (6,6002) iacase, itlast, nitmax, fnm
 6002 format (                                                          &
     & ' =====>  iteration summary, case',i2,'.    iteration count:',i4 &
     &,'   iteration limit:',i4,'    function norm:',1pe12.4)
!
!
!
  200 continue
!
!
!
  900 continue
      call closms (nlimat)
      return
      END subroutine fsolve
! **deck fstmln
      subroutine fstmln(poten,y,yp,icomp,icore,neqn,zof,pvof)
      implicit double precision (a-h,o-z)
!
!          this subroutine sets up values so that potential/velocity
!          or mass flux
!          can be computed at points required for streamline
!          computation. values are to be computed at points located
!          in array y. upto icore computations may be carried out.
!          however, no computation is performed for a location y(*,i)
!          if icomp(i). =   10 or if icomp(i) = 1.  icomp(i) = 10
!          indicates that for stack i streamline is not currently
!          loaded. icomp(i) = 1  indicates that values are not needed
!          currently for computation.
!
!call solstr
      common /solstr/ iastr(600), iaxstr(200), ivzof(200)
!end  solstr
!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 slstat
      common /slstat/ tpvcal, tpivv, npicsl(7), npvcal, nphvsl
!end  slstat
      dimension poten(icore), yp(neqn,icore), y(neqn,icore),            &
     &    icomp(icore), zof(3,icore), pvof(4,icore)

  INTRINSIC:: CPU_TIME
!-------------------------------------------------------------------------------
!         for call to pvcal the points have to be loaded in zof
!         consecutively. results are returned in pvof. load array
!         zof
!
      nof = 0
      do 2000 i = 1, icore
        if(icomp(i).eq.10) go to 1900
        if(icomp(i).eq.1) go to 1900
          nof = nof + 1
          zof(1,nof) = y(1,i)
          zof(2,nof) = y(2,i)
          zof(3,nof) = y(3,i)
          ivzof(nof) = iaxstr(i)
 1900   continue
 2000 continue
      if ( nof.le.0 ) go to 4000
!**
!**       call pvcal
!**
      call CPU_TIME (ta)
      nphvsl  =  nphvsl + nof
      npvcal  =  npvcal + 1
      call pvcal (ivzof,zof,pvof,nof,tpsl)
      call CPU_TIME (tb)
      tpvcal  =  tpvcal + tb-ta
!
!          load back potential/velocity or mass flux in appropriate
!          location.
!
      nof = 0
      do 3000 i = 1, icore
        if(icomp(i).eq.1) go to 2900
        if(icomp(i).eq.10) go to 2900
          nof = nof + 1
          poten(i) = pvof(1,nof)
          yp(1,i)  = pvof(2,nof)
          yp(2,i)  = pvof(3,nof)
          yp(3,i)  = pvof(4,nof)
 2900 continue
 3000 continue
!
!         computation complete
!
 4000 continue
      return
      END subroutine fstmln
! **deck fsvcal
      subroutine fsvcal
      implicit double precision (a-h,o-z)
!
!         fsvcal initializes information in /acase/ and /comprs/ given
!         the compressibility angles, angles of attack and yaw and
!         freestream magnitudes
!
!         michael epton, 30 november 1988
!call ncons
      common /ncons/ pi,pi2,pi4i,twopi,pio2
!end  ncons
!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 symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!
!
!
!                                  data related to prandtl-glauert
!                                  transformation
      betams=1.d0-amach*amach
      abetms=abs(betams)
      betam=sqrt(abetms)
      sbetam=sign(1.d0,betams)
      btsqi   =  1.d0/abetms
!                                  kernel scale factor: 4*pi (subsonic)
!                                                       2*pi (supersonic
      akap    =  pi*(3.d0+sbetam)
      akapin  =  1.d0/akap
!                                  compressibility axis
      aarg=alpc*pi2/360.d0
      barg=betc*pi2/360.d0
      compd(1)  =  cos(aarg)*cos(barg)
      compd(2)  = -cos(aarg)*sin(barg)
      compd(3)  =  sin(aarg)
!                                  symmetry plane completion values
!                                  (1, 3, 15)
      ictsym  =  1
      if ( nsymm.eq.1 ) ictsym = 3
      if ( nsymm.eq.2 ) ictsym = 15
!                                  symmetry plane limits
!                                  nsymm=0 ==> (nisym,njsym) = (1,1)
!                                  nsymm=1 ==> (nisym,njsym) = (2,1)
!                                  nsymm=2 ==> (nisym,njsym) = (2,2)
!
! Setting nisym and njsym is now done in inputa.f90                       ! Note by Martin Hegedus, 4/21/09
!!      nisym   =  min (nsymm+1,2)                                          ! Removed by Martin Hegedus, 4/21/09
!!      njsym   =  max (nsymm,1)                                            ! Removed by Martin Hegedus, 4/21/09
!                                  reference axis to compressibility axi
!                                  transformation
      call rotate(arotc,aarg,barg)
      call trans(arotc,arotci,3,3)
!                                  ggcp = reference axis to p-g scaled t
!                                  ggcp = inverse (transpose (ggcp) )
      af      =  1.d0/betams
      do 110 i = 1,3
      gfac    =  betam
      if ( i.eq.1 ) gfac = 1.d0
      do 105 j = 1,3
      ij      =  i + (j-1)*3
      ggcp(i,j)  =arotc(ij)*gfac
      ggcpit(i,j)=arotc(ij)/gfac
      czinv(i,j) = (1.d0-af)*compd(i)*compd(j)
  105 continue
      czinv(i,i) = czinv(i,i) + af
  110 continue
!c
!     *  loop ranges over the number of cases to calculate freestream *
!     *  velocity vector for each angle of attack and yaw             *
!
      do 400 iacase=1,nacase
      aarg=alpha(iacase)*pi2/360.d0
      barg=beta(iacase)*pi2/360.d0
      fsv(1,iacase)  =  fsvm(iacase)*cos(aarg)*cos(barg)
      fsv(2,iacase)  = -fsvm(iacase)*cos(aarg)*sin(barg)
      fsv(3,iacase)  =  fsvm(iacase)*sin(aarg)
      call vmul (fsv(1,iacase), 1.d0/fsvm(iacase), fsvhat(1,iacase), 3)
      call cmpscl (1.d0/betams, compd, fsv(1,iacase), pvdry(1,iacase) )
      call dscal (3,  -1.d0, pvdry(1,iacase),1)
  400 continue
      return
      END subroutine fsvcal
! **deck gadnet
      subroutine gadnet(kn,nrow,ncol,ncen)
      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 network of mesh points for gothic,or arrow,
!              or delta wing
!
!     input    calling sequence
!              kn - network no.
!              nrow - number of rows
!              ncol - number of columns
!              ncen - number of network mesh points along centerline
!              common block
!              /index/ - nza
!
!     output   common block
!              /mspnts/ - zm
!
!     discussion  the routine first sets up the nrow*ncen network mesh
!              points.  if ncol is equal to ncen, it returns to the call
!              -ing program input.  otherwise, the routine continues to
!              calculate mesh points for the lower part of the network
!              with swept trailing edge.
!******
!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 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
!
!                             set up nrow*ncen mesh points for the net-
!                             work
      k = nza(kn) + 1
      do 20 j=1,ncen
      xj = sc(1,j)
      yj=sc(2,j)-sc(2,1)
      zj = sc(3,j)
      do 10 i=1,nrow
      zm(1,k) = xj
      zm(2,k)=sc(2,1)+ypc(i)*yj
      zm(3,k) = zj
   10 k = k + 1
   20 continue
!
!                             check if the given network is of a straigh
!                             -t trailing edge
      if(ncen.eq.ncol)  go to 50
!
!                             calculate mesh points for the lower part
!                             of the network with swept trailing edge
      rm=(sc(2,ncol)-sc(2,1))/(sc(1,ncol)-sc(1,ncen))
      ncen1 = ncen+1
      do 40 j=ncen1,ncol
      xj = sc(1,j)
      yj = sc(2,j)
      yt=sc(2,1)+(xj-sc(1,ncen))*rm
      yd = yj - yt
      zj = sc(3,j)
      do 30 i=1,nrow
      zm(1,k) = xj
      zm(2,k) = yt + ypc(i)*yd
      zm(3,k) = zj
   30 k = k + 1
   40 continue
   50 return
      END subroutine gadnet
! **deck gcpcal
      subroutine gcpcal(nm,nn,zm,nma,nna,za)
      implicit double precision (a-h,o-z)
!***created  on 76.009    w.o. no.   0   version        ftj.00
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to compute derived mesh point grids from original corner     *
!     *  point grid                                                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the grid point is approximated by the average of the adjacent*
!     *  corner points.  all points are assumed to be defined 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                   *
!     *                                                               *
!     *   nma       argument  input     number of grid points per     *
!     *                                 row (normally nm+1)           *
!     *                                                               *
!     *   nm        argument  input     number of corner points per   *
!     *                                 row                           *
!     *                                                               *
!     *   nna       argument  input     number of grid points per     *
!     *                                 column (nn+1)                 *
!     *                                                               *
!     *   nn        argument  input     number of corner points per   *
!     *                                 column                        *
!     *                                                               *
!     *   za        argument  output    coordinates of the grid       *
!     *                                 points in three-space         *
!     *                                                               *
!     *   zm        argument  input     coordinates of the corner     *
!     *                                 points in three-space         *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension zm(3,nm,nn),za(3,nma,nna)
!c
!     *  loop ranges over the number of grid points per column        *
!
      do 99 n=1,nna
!c
!     *  obtain the adjacent corner point column indices (n1 and n2)  *
!
      n1=max (n,1)
      if(nna.gt.nn) n1=max (n-1,1)
      n2=min (n,nn)
      if(nna.lt.nn) n2=min (n+1,nn)
!c
!     *  loop ranges over the number of grid points per row           *
!
      do 98 m=1,nma
!c
!     *  obtain the adjacent corner point row indices (m1 and m2)     *
!
      m1=max (m,1)
      if(nma.gt.nm) m1=max (m-1,1)
      m2=min (m,nm)
      if(nma.lt.nm) m2=min (m+1,nm)
!c
!     *  loop ranges over the three members of the point position     *
!     *  vector                                                       *
!
      do 90 l=1,3
      za(l,m,n)=.25d0*(zm(l,m1,n1)+zm(l,m2,n1)+zm(l,m1,n2)+zm(l,m2,n2))
   90 continue
   98 continue
   99 continue
      return
      END subroutine gcpcal
! **deck genfg
      subroutine genfg (m,n,zm, zfg)
      implicit double precision (a-h,o-z)
      dimension zm(3,m,n), zfg(3,2*m-1,2*n-1)
!
!     given the panelling of a network, generate the fine grid array
!
      mfn     =  2*m-1
      nfn     =  2*n-1
      do 200 jfn = 1,nfn
      do 100 ifn = 1,mfn
         j1      =  (1+jfn)/2
         j2      =  (2+jfn)/2
         i1      =  (1+ifn)/2
         i2      =  (2+ifn)/2
         do 50 l = 1,3
            zfg(l,ifn,jfn)  =  .25d0*( zm(l,i1,j1)                      &
     &                                +zm(l,i2,j1)                      &
     &                                +zm(l,i1,j2)                      &
     &                                +zm(l,i2,j2) )
   50    continue
  100 continue
  200 continue
!
      return
      END subroutine genfg
! **deck genpan
      subroutine genpan(zk,mk,nk,i,j,   avgp,r)
      implicit double precision (a-h,o-z)
!
!     purpose: generate information about panel of a network
!
!     inputs:  zk     coordinates of grid points of networks in the
!                     global coordinate system starting with the kth one
!              mk     number of rows in kth network
!              nk     number of columns in kth network
!              i      row number
!              j      column number
!
!     outputs: avgp   average point of the panel
!              r      radius of sphere enclosing all points of panel
!
!     panel numbering scheme:
!
!               1         4    ......... row index, mk
!            .   x.......x
!     column .   .       .
!     index, .   .   a   .      a=avgp
!     nk     .   .       .
!            .   x.......x
!            .  2    6    3
!
      dimension zk(3,mk,nk)
      dimension avgp(3)
      dimension temp1(3), temp2(3), temp3(3), temp4(3)
      dimension temp5(3), temp6(3), temp7(3), temp8(3), temp9(3)
!
!     generate the panel corner points, 1 to 4
!
      do 10 ip=1,3
      temp1(ip) = zk(ip,i-1,j-1)
      temp2(ip) = zk(ip,i-1,j  )
      temp3(ip) = zk(ip,i  ,j  )
      temp4(ip) = zk(ip,i  ,j-1)
   10 continue
!
!     generate the average point, avgp
!
      do 20 ip=1,3
      avgp(ip) = .25d0*( temp1(ip) + temp2(ip) + temp3(ip) + temp4(ip) )
   20 continue
!
!     find the radius of a sphere enclosing the entire panel
!
      p1d = sqrt( (temp1(1) - avgp(1))**2 +                             &
     &            (temp1(2) - avgp(2))**2 +                             &
     &            (temp1(3) - avgp(3))**2   )
!
      p2d = sqrt( (temp2(1) - avgp(1))**2 +                             &
     &            (temp2(2) - avgp(2))**2 +                             &
     &            (temp2(3) - avgp(3))**2   )
!
      p3d = sqrt( (temp3(1) - avgp(1))**2 +                             &
     &            (temp3(2) - avgp(2))**2 +                             &
     &            (temp3(3) - avgp(3))**2   )
!
      p4d = sqrt( (temp4(1) - avgp(1))**2 +                             &
     &            (temp4(2) - avgp(2))**2 +                             &
     &            (temp4(3) - avgp(3))**2   )
!
      r =  max ( p1d, p2d, p3d, p4d )
!
      return
      END subroutine genpan
! **deck gensub
      subroutine gensub(zk,mk,nk,i,j,   ptar)
      implicit double precision (a-h,o-z)
!
!     purpose: generate subpanels of a network
!
!     inputs:  zk     coordinates of grid points of networks in the
!                     global coordinate system starting with the kth one
!              mk     number of rows in kth network
!              nk     number of columns in kth network
!              i      row number
!              j      column number
!
!     outputs: ptar   array of points of subpanel triangles.  range of
!                     values is x,y,z; pt1,pt2,pt3; triangles 1 to 8
!
!     panel numbering scheme:
!
!               1    8    4    ......... row index, mk
!            .   x...o...x
!     column .   .   .9  .
!     index, . 5 o...0...o 7
!     nk     .   .   .   .
!            .   x...o...x
!            .  2    6    3
!
      dimension zk(3,mk,nk)
      dimension ptar(3,3,8)
      dimension temp1(3), temp2(3), temp3(3), temp4(3)
      dimension temp5(3), temp6(3), temp7(3), temp8(3), temp9(3)
!
!     generate the panel corner points, 1 to 4
!
      do 10 ip=1,3
      temp1(ip) = zk(ip,i-1,j-1)
      temp2(ip) = zk(ip,i-1,j  )
      temp3(ip) = zk(ip,i  ,j  )
      temp4(ip) = zk(ip,i  ,j-1)
   10 continue
!
!     generate the remaining points of the near plane, points 5 to 9
!
      do 20 ip=1,3
      temp5(ip) = .5d0 * ( temp2(ip) + temp1(ip) )
      temp6(ip) = .5d0 * ( temp3(ip) + temp2(ip) )
      temp7(ip) = .5d0 * ( temp4(ip) + temp3(ip) )
      temp8(ip) = .5d0 * ( temp1(ip) + temp4(ip) )
      temp9(ip) = .5d0 * ( temp5(ip) + temp7(ip) )
   20 continue
!
!     generate the point array, ptar, for the triangles
!
      do 30 ip=1,3
!     triangle  1
      ptar(ip,1,1) = temp1(ip)
      ptar(ip,2,1) = temp5(ip)
      ptar(ip,3,1) = temp8(ip)
!     triangle  2
      ptar(ip,1,2) = temp2(ip)
      ptar(ip,2,2) = temp6(ip)
      ptar(ip,3,2) = temp5(ip)
!     triangle  3
      ptar(ip,1,3) = temp3(ip)
      ptar(ip,2,3) = temp7(ip)
      ptar(ip,3,3) = temp6(ip)
!     triangle  4
      ptar(ip,1,4) = temp4(ip)
      ptar(ip,2,4) = temp8(ip)
      ptar(ip,3,4) = temp7(ip)
!     triangle  5
      ptar(ip,1,5) = temp5(ip)
      ptar(ip,2,5) = temp9(ip)
      ptar(ip,3,5) = temp8(ip)
!     triangle  6
      ptar(ip,1,6) = temp6(ip)
      ptar(ip,2,6) = temp9(ip)
      ptar(ip,3,6) = temp5(ip)
!     triangle  7
      ptar(ip,1,7) = temp7(ip)
      ptar(ip,2,7) = temp9(ip)
      ptar(ip,3,7) = temp6(ip)
!     triangle  8
      ptar(ip,1,8) = temp8(ip)
      ptar(ip,2,8) = temp9(ip)
      ptar(ip,3,8) = temp7(ip)
!
   30 continue
!
  999 return
      END subroutine gensub
! **deck geodtc
      subroutine geodtc (nnett,nm,nn,zm)
      implicit double precision (a-h,o-z)
      dimension nm(nnett), nn(nnett), zm(3,6000)
!
!     perform the basic sorts of geometry checking usually performed
!     in geomc.  this has been broken out into a separate subroutine
!     so that very large cases can have datachecks performed on w/s
!     class machines.
!
!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
!call freqdt
!                                                  /freqdt/
      common /freqdt/ omgbar, omegb, omg, omgabs
!---- complex*16 omgbar, omegb, omg
!end  freqdt
      common /freqer/ ndpher
!
      dimension z(3), pf(3,4), qcvxhl(2,4), genref(3)
!
      ncvxer  =  0
      nasrat  =  0
      npa     =  0
      nza     =  0
!                                  loop over networks looking for
!                                  aspect ratio, critical inclination
!                                  and phase variation type problems
      do 850 kn = 1,nnett
      mk      =  nm(kn)
      nk      =  nn(kn)
!                                  loop over panels in each network
      do 800 n = 2,nk
      jpan = n-1
      do 700 m = 2,mk
      ipan = m-1
      ipn = ipan+(mk-1)*(jpan-1)
      ip  = ipn+npa
      lzn = ipan+mk*(jpan-1)
      lz  = lzn+nza
!                                  define canonical panel points
      do 100 l = 1,3
         cp(l,1) = zm(l,lz)
         cp(l,2) = zm(l,lz+mk)
         cp(l,3) = zm(l,lz+mk+1)
         cp(l,4) = zm(l,lz+1)
         cp(l,5) = .5d0*(cp(l,1)+cp(l,2))
         cp(l,6) = .5d0*(cp(l,2)+cp(l,3))
         cp(l,7) = .5d0*(cp(l,3)+cp(l,4))
         cp(l,8) = .5d0*(cp(l,4)+cp(l,1))
         cp(l,9) = .25d0*(cp(l,1)+cp(l,2)+cp(l,3)+cp(l,4))
  100 continue
      nsff    =  4
!                                  get index of collapsed sides
      call iscal (cp,ics)
!                                  get info on 4 interior subpanels
      call surfit (cp,aq,aqi)
      is = 5
      call dcopy (3,aqi(7),1,en(1,is),1)
      call uvect (en(1,is))
      call cmpscl (betams,compd,en(1,is),z)
      call mxm (z,1,en(1,is),3,wz,1)
!                                  check for mach inclination
      if (wz.lt.0.d0) write(6,6100) is,ip,kn
      if (abs(wz).lt.(.1d0)) write(6,6200) is,ip,kn,wz
!                                  get transformation for interior reg'n
      call vadd (cp(1,7), -1.d0, cp(1,5), genref, 3)
      call refloc (en(1,is),sbetam,genref,ar(1,is),ajc,arc,ari)
!                                  get info on 4 exterior subpanels
      enmin =  1.d0
      diam  =  0.d0
      do 200 is = 1,4
         call unipan(ar(1,5),cp(1,9),cp(1,is),pf(1,is))
         call vadd (cp(1,is), -1.d0, cp(1,9), z, 3)
         call compip (z,z,compd,abetms,zz)
         diam    =  max(diam,sqrt(zz))
!
         isp3 = mod(is+2,4)+1
         if((is.eq.ics).or.(isp3.eq.ics)) go to 200
         isp1 = mod(is,4)+1
         call norcal (cp(1,is),cp(1,isp1),cp(1,isp3),en(1,is))
         call cmpscl (betams,compd,en(1,is),z)
         call mxm (z,1,en(1,is),3,wz,1)
!                                  check for mach inclination
         if (wz.lt.0.d0) write(6,6100) is,ip,kn
         if (abs(wz).lt.(.1d0)) write(6,6200) is,ip,kn,wz
         call mxm (en(1,5),1,en(1,is),3,enis,1)
         enmin =  min (enmin,enis)
  200 continue
      diam    =  2.d0*diam
!                                  check for excessive twisting
      if ( enmin .lt. .5d0 ) write (6,6300) ipan, jpan, kn
!                                  check for aspect ratio errors
      call distnc (cp(1,5),cp(1,7),d57)
      call distnc (cp(1,6),cp(1,8),d68)
      pasrat =  min (d57,d68)/ max (d57,d68)
      if ( pasrat .ge. .0001d0 ) go to 300
         if ( nasrat .eq. 0 ) call bmark ('asprmsg ')
         nasrat  =  nasrat + 1
         write (6,6400) ipan,jpan,kn,pasrat
  300 continue
!                                  check for phase variation errors
      dph     =  omg*diam
      if ( dph.lt. 1.1d0 ) goto 350
         ndpher  =  ndpher + 1
         write (6,6500) dph, omg, diam, kn, ipn, ipan, jpan
  350 continue
!                                  check for non-convexity
      call cnvxhl (pf,nsff,ics,qcvxhl,kcvxhl)
      if ( kcvxhl .ne. 0 ) go to 400
         ncvxer  =  ncvxer + 1
         write (6,6600) ncvxer, kn,ipan,jpan
  400 continue
!
  700 continue
  800 continue
!                                  increment cum panel and meshpt counts
      npa     =  npa + (mk-1)*(nk-1)
      nza     =  nza + mk*nk
  850 continue
!                                  abort on nonconvex panel error
      if ( ncvxer .le. 0 ) goto 900
         write (6,6700) ncvxer
         stop
  900 continue
      return
!
 6100 format(/4x,10hsub-panel ,i5,3x,9hof panel ,i5,3x,11hof network ,  &
     &i5,3x,16his superinclined)
 6200 format(/4x,10hsub-panel ,i5,3x,9hof panel ,i5,3x,11hof network ,  &
     &i5,3x,36his near mach-inclined with (n,nc) = ,e15.6)
 6300 format (/,4x,'panel at row',i5,'  column',i5,'  of network',i5    &
     &  ,'  is excessively twisted.')
 6400 format (/,4x,'panel in row',i5,',  column',i5,',  of network',i5  &
     & ,'  has an aspect ratio of ',f15.8)
 6500 format (' ** total phase variation exceeds limit value (1.1) **'  &
     & ,/, '  phase variation:',f12.6,'   omg:',f12.6,'  diam:',f12.6   &
     & ,/, '  network & panel:',2i6  ,'   row:',i12  ,'   col:',i12 )
 6600 format (' nonconvex panel error.  error no.',i4,'   nw',i4        &
     &  ,'   panel row',i5,'   panel column',i5 )
 6700 format (  33(2h *) ,/,'   execution terminated due to ',i5        &
     & ,'nonconvexity errors.  (see messages above) ')
!
      END subroutine geodtc
! **deck geomc
      subroutine geomc(kn,nm,nn,npa,nza,zm)
      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 and store geometric defining quantities for     *
!     *  each panel in an individual network.                         *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  panel geometry defining quantities for the specified network *
!     *  kn are computed a panel at a time within the loop 198. at    *
!     *  the end of the loop all defining quantities for the current  *
!     *  panel are stored as a record on i/o unit 2 via istrns.       *
!     *  canonical panel points (cp) are computed in the loop 110.    *
!     *  iscal identifies collapsed edges and surfit constructs a     *
!     *  near-plane coordinate system. sub-panel geometric defining   *
!     *  quantities for the outer four corner sub-panels are          *
!     *  constructed in the loop 130. the inner four sub-panels all   *
!     *  have the same geometric defining quantities and these are    *
!     *  constructed immediately following the loop 130. various panel*
!     *  wide quantities are then computed. psddqg is called to       *
!     *  construct sub-panel spline matrices qq and rr along with     *
!     *  sub-panel vertices in local coordinates (pp) and the local   *
!     *  to global potential/velocity transormation matrices arp.     *
!     *  ffdqg is called to construct far field moment matrices e1,e2,*
!     *  e4,f1,f2,f4,w1,w2 and w4. finally ccal is called to construct*
!     *  the basic far field moment matrix c for use in computing     *
!     *  forces and moments in fmcal.                                 *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   abetms    /comprs/  input     absolute value of betams      *
!     *                                                               *
!     *   aq        /pandq/   output    transformation matrix from    *
!     *                                 global to near plane          *
!     *                                 coordinate system             *
!     *                                                               *
!     *   aqi       /pandq/   output    transformation matrix from    *
!     *                                 near plane to global          *
!     *                                 coordinate system             *
!     *                                                               *
!     *   ari       /pandq/   output    transformation from local sub-*
!     *                                 panel to global coordinates   *
!     *                                                               *
!     *   arp       /pandq/   output    matrix transforming the       *
!     *                                 combined potential/velocity   *
!     *                                 vector from local sub-panel to*
!     *                                 global coordinates            *
!     *                                                               *
!     *   betam     /comprs/  input     square root of abetms         *
!     *                                                               *
!     *   betams    /comprs/  input     1.-(freestream mach number)**2*
!     *   compd     /comprs/  input     compressibility direction     *
!     *                                 vector                        *
!     *                                                               *
!     *   cp        /pandq/   input     nine canonical panel points   *
!     *                                 (includes corner points,edge  *
!     *                                 midpoints and center)         *
!     *                                                               *
!     *   c         /pandq/   output    array of panel moments        *
!     *                                                               *
!     *   diam      /pandq/   output    compressible panel diameter   *
!     *                                                               *
!     *   d13       -local-   - - - -   first diagonal length of panel*
!     *                                                               *
!     *   d24       -local-   - - - -   second diagonal length of     *
!     *                                 panel                         *
!     *                                                               *
!     *   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        *
!     *                                                               *
!     *   e1        /pandq/   output    source monopole potential and *
!     *                                 veolcity far field moments    *
!     *                                                               *
!     *   e2        /pandq/   output    source dipole potential and   *
!     *                                 veolcity far field moments    *
!     *                                                               *
!     *   e4        /pandq/   output    source quadrupole potential   *
!     *                                 and velocity far field        *
!     *                                 moments                       *
!     *                                                               *
!     *                                 far field moments             *
!     *                                                               *
!     *   f2        /pandq/   output    doublet dipole veolcity       *
!     *                                 far field moments             *
!     *                                                               *
!     *   f3        /pandq/   output    doublet quadrupole velocity   *
!     *                                 far field moments             *
!     *                                                               *
!     *   ics       /pandq/   output    =0 - panel is quadrilateral   *
!     *                                 =1 thru 4 - panel is triangle *
!     *                                     because edge ics is       *
!     *                                    collapsed                  *
!     *                                                               *
!     *   igeomp    /prnt/    input     geometry print flag =1 if     *
!     *                                 print desired                 *
!     *                                                               *
!     *   iin       /pandq/   output    sub-panel inclination         *
!     *                                 flag                          *
!     *                                      =+1  subinclined         *
!     *                                      =-1  superinclined       *
!     *                                                               *
!     *   kn        argument  input     network number                *
!     *                                                               *
!     *   nm        argument  input     number of rows of network     *
!     *                                 corner point grid             *
!     *                                                               *
!     *   nn        argument  input     number of columns of network  *
!     *                                 corner point grid             *
!     *                                                               *
!     *   npa       argument  in/out    number of panels in all       *
!     *                                 previous networks             *
!     *                                                               *
!     *   npo       argument  input     order of panel surface fit    *
!     *                                                               *
!     *   nt        argument  input     network type                  *
!     *                                                               *
!     *   nza       argument  input     number of grid points in all  *
!     *                                 previous networks             *
!     *                                                               *
!     *   p         /pandq/   output    panel corner points (in the   *
!     *                                 local system)                 *
!     *   p         /pandq/   output    coordinates of four panel     *
!     *                                 corner points in local central*
!     *                                 sub-panel coordinate system   *
!     *                                                               *
!     *   pp        /pandq/   output    coordinates of sub-panel      *
!     *                                 vertices in repective sub-    *
!     *                                 panel coordinate systems      *
!     *                                                               *
!     *                                                               *
!     *   qq        /pandq/   input     transformation from doublet   *
!     *                                 values at nine canonical panel*
!     *                                 points to quadratic taylor    *
!     *                                 coefficients in local         *
!     *                                 sub-panel coordinate systems  *
!     *                                                               *
!     *   rr        /pandq/   output    matrix describing the         *
!     *                                 dependence of each sub-panel  *
!     *                                 linear source coefficients    *
!     *                                 on the overall panel linear   *
!     *                                 linear source coefficients    *
!     *                                                               *
!     *   w1        /pandq/   output    doublet monopole potential    *
!     *                                 far field moments             *
!     *                                                               *
!     *   w2        /pandq/   output    doublet dipole potential      *
!     *                                 far field moments             *
!     *                                                               *
!     *   w4        /pandq/   output    doublet quadrapole potential  *
!     *                                 far field moments             *
!     *                                                               *
!     *   zm        argument  input     coordinates of network corner *
!     *                                 point grid                    *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!call narmsg
!                                                            /narmsg/
      common /narmsg/ nasrat
!end  narmsg
      common /freqer/ ndpher
!ca freqdt
!                                                  /freqdt/
      common /freqdt/ omgbar, omegb, omg, omgabs
!---- complex*16 omgbar, omegb, omg
!end  freqdt
      dimension stalrc(2,7)
      dimension alamx(9,4)
      dimension zm(3,nm,nn)
      dimension w(3),z(3),fc(4),fs(4),zp(3),ds(4,9),adum(9)
      dimension phis(9), phit(9)
      dimension genref(3,3), kgen(5)
      dimension cc(6,6)
!
      data kgen / 1,3,3,1,2/
      data npo /1/
      data nerr/0/
!c
!     *  loop cycles through all panels in the network                *
!
!c
!     *  outer loop ranges over columns                               *
!
      do 199 n=2,nn
      nm1=n-1
!c
!     *  loop ranges over rows                                        *
!
      do 198 m=2,nm
      mm1=m-1
      ipn=mm1+(nm-1)*(nm1-1)
      ip=ipn+npa
!                                   initialize spline data to avoid
!                                   trouble later
      call dcopy (189,  0.d0,0,  astd,1)
      call dcopy ( 15,  0.d0,0,  asts,1)
      call icopy (  9,     0,0,   iis,1)
      call icopy ( 21,     0,0,   iid,1)
      call icopy (  5,     0,0, iimux,1)
      call icopy (  9,     0,0,   iisgp,1)
      call icopy ( 21,     0,0,   iidgp,1)
      call icopy (  5,     0,0,  iimuxg,1)
      ins     =  0
      ind     =  0
      inmux   =  0
      its     =  0
!c
!     *  if requested, print geometry data                            *
!
      if(igeomp.eq.1) write(6,4000) ip,kn,mm1,nm1,ipn,npo
 4000 format(////1x,11hpanel no. =,i5,4x,13hnetwork no. =,i5,           &
     &4x,5hrow =,i5,4x,8hcolumn =,i5,4x,19hnetwork panel no. =,i5,      &
     &5x,22horder of surface fit =,i5,//,6x,                            &
     &9x,2hxg,18x,2hyg,18x,2hzg,18x,2hxl,18x,2hyl,18x,2hzl,/)
!c
!     *  compute nine canonical panel points                          *
!
      do 110 l=1,3
      cp(l,1)=zm(l,m-1,n-1)
      cp(l,2)=zm(l,m-1,n)
      cp(l,3)=zm(l,m,n)
      cp(l,4)=zm(l,m,n-1)
      cp(l,5)=.5d0*(cp(l,1)+cp(l,2))
      cp(l,6)=.5d0*(cp(l,2)+cp(l,3))
      cp(l,7)=.5d0*(cp(l,3)+cp(l,4))
      cp(l,8)=.5d0*(cp(l,4)+cp(l,1))
      cp(l,9)=.25d0*(cp(l,1)+cp(l,2)+cp(l,3)+cp(l,4))
  110 continue
      call vadd (cp(1,4), -1.d0, cp(1,1), genref(1,1), 3)
      call vadd (cp(1,7), -1.d0, cp(1,5), genref(1,2), 3)
      call vadd (cp(1,3), -1.d0, cp(1,2), genref(1,3), 3)
!c
!     *  identify triangular panel and associated collapsed edge      *
!
      call iscal(cp,ics)
!c
!     *  compute transformation matrix (and inverse) from global to   *
!     *  near-plane coordinates                                       *
!
      call surfit(cp,aq,aqi)
      is=5
!c
!     *  calculate sub-panel unit normal                              *
!
      call dcopy (3,aqi(7),1,en(1,is),1)
      call uvect(en(1,is))
!c
!     *  compute co-normal and its inner product with normal          *
!
      call cmpscl(betams,compd,en(1,is),z)
      call mxm (z,1,en(1,is),3,wz,1)
!c
!     *  identify superinclined sub-panel                             *
!
      if(wz.lt.0.d0) write(6,8000) is,ip,kn
!c
!     *  write diagnostic information for near mach-inclined sub-     *
!     *  panel                                                        *
!
      if(abs(wz).lt.(.1d0)) write(6,9000) is,ip,kn,wz
!c
!     *  calculate transformation matrix (and inverse) from global to *
!     *  local sub-panel coordinates                                  *
!
      kg      =  kgen(is)
      call refloc (en(1,is),sbetam,genref(1,kg)                         &
     &            ,ar(1,is),aj(is),arpn,ari)
      iin(is)=arpn
      call mxm (compd,1,en(1,is),3,sgx(is),1)
      sgx(is) =  sign(1.d0,sgx(is))
      enmin=1.d0
!c
!     *  compute geometric quantities for outer four sub-panels       *
!
      do 130 is=1,4
      isp3=mod(is+2,4)+1
!c
!     *  ignore collapsed sub-panel                                   *
!
      if((is.eq.ics).or.(isp3.eq.ics)) go to 130
      isp1=mod(is,4)+1
!c
!     *  calculate sub-panel unit normal                              *
!
      call norcal(cp(1,is),cp(1,isp1),cp(1,isp3),en(1,is))
!c
!     *  compute co-normal and its inner product with normal          *
!
      call cmpscl(betams,compd,en(1,is),z)
      call mxm (z,1,en(1,is),3,wz,1)
!c
!     *  identify superinclined sub-panel                             *
!
      if(wz.lt.0.d0) write(6,8000) is,ip,kn
 8000 format(/4x,10hsub-panel ,i5,3x,9hof panel ,i5,3x,11hof network ,  &
     &i5,3x,16his superinclined)
!c
!     *  write diagnostic information for near mach-inclined sub-     *
!     *  panel                                                        *
!
      if(abs(wz).lt.(.1d0)) write(6,9000) is,ip,kn,wz
 9000 format(/4x,10hsub-panel ,i5,3x,9hof panel ,i5,3x,11hof network ,  &
     &i5,3x,36his near mach-inclined with (n,nc) = ,e15.6)
!c
!     *  calculate transformation matrix (and inverse) from global to *
!     *  local sub-panel coordinates                                  *
!
      kg      =  kgen(is)
      call refloc (en(1,is),sbetam,genref(1,kg)                         &
     &            ,ar(1,is),aj(is),arpn,adum)
      iin(is)=arpn
      call mxm (compd,1,en(1,is),3,sgx(is),1)
      sgx(is) =  sign(1.d0,sgx(is))
      call mxm (en(1,5),1,en(1,is),3,enis,1)
      enmin= min (enmin,enis)
  130 continue
!c
!     *  compute geometric quantities for inner parallelogram         *
!     *  sub-panels                                                   *
!
      if ( enmin .lt. .5d0 ) write (6,3000) mm1, nm1, kn
 3000 format (/,4x,'panel at row',i5,'  column',i5,'  of network',i5    &
     &  ,'  is excessively twisted.')
      call distnc(cp(1,5),cp(1,7),d57)
      call distnc(cp(1,6),cp(1,8),d68)
      pasrat= min (d57,d68)/ max (d57,d68)
      if ( pasrat .ge. .0001d0 ) go to 135
      if ( nasrat .eq. 0 ) call bmark ('asprmsg ')
      nasrat  =  nasrat + 1
      write (6,2000) mm1,nm1,kn,pasrat
 2000 format (/,4x,'panel in row',i5,',  column',i5,',  of network',i5  &
     & ,'  has an aspect ratio of ',f15.8)
  135 continue
!c
!     *  compute remaining defining quantities                        *
!
      xmx=0.d0
      ymx=0.d0
!c
!     *  calculate compressible panel diameter                        *
!
      diam=0.d0
!c
!     *  loop ranges over panel corner points                         *
!
      do 140 i=1,4
      call vadd(cp(1,i),-1.d0,cp(1,9),w,3)
      call compip(w,w,compd,abetms,ww)
      diam= max (diam,sqrt(ww))
!c
!     *  calculate coordinates of panel corner points in local sub-   *
!     *  panel coordinate system of inner quadrilateral sub-panels    *
!
      call unipan(ar(1,5),cp(1,9),cp(1,i),p(1,i))
!c
!     *  print panel geometry diagnostic information if desired       *
!
      if(igeomp.eq.1) write(6,5000) i,(cp(j,i),j=1,3),(p(j,i),j=1,3)
 5000 format(1x,2hcp,i1,6f20.10)
      xmx= max (xmx,abs(p(1,i)))
      ymx= max (ymx,abs(p(2,i)))
  140 continue
      diam=2.d0*diam
      call unipan(ar(1,5),cp(1,9),cp(1,9),w)
      if(igeomp.eq.1) write(6,6100) (cp(j,9),j=1,3),(w(j),j=1,3)
 6100 format(1x,2hr0,2x,6f20.10)
      call mxm (ar(1,5),3,en(1,5),3,z,1)
      if(igeomp.eq.1) write(6,6200) (en(i,5),i=1,3), (z(i),i=1,3)
 6200 format(1x,2hn0,2x,6f20.10)
      d13=sqrt((p(1,3)-p(1,1))**2+(p(2,3)-p(2,1))**2)
      d24=sqrt((p(1,4)-p(1,2))**2+(p(2,4)-p(2,2))**2)
!c
!     *  calculate panel moments for later use in the influence       *
!     *  coefficient calculations                                     *
!
      call ccaln (p,ics,cc,4,6)
      do 145 j = 1,3
      do 145 i = 1,3
         c(i,j) = cc(i,j)
  145 continue
      if(igeomp.eq.1) write(6,7000) diam,xmx,ymx,d13,d24,c(1,1)
 7000 format(1x,5hdiam=,f11.5,4x,4hxmx=,f11.5,4x,4hymx=,                &
     &f11.5,4x,4hd13=,f11.5,4x,4hd24=,f11.5,4x,5harea=,f11.5)
      call unipan(aq,cp(1,9),cp(1,1),w)
      c1=w(1)-1.d0
      c2=w(2)-1.d0
      c3=w(3)
      fc(1)=1.d0+c1+c2
      fc(2)=1.d0+c1-c2
      fc(3)=1.d0-c1-c2
      fc(4)=1.d0-c1+c2
      fs(1)=1.d0+c1
      fs(2)=1.d0-c2
      fs(3)=1.d0-c1
      fs(4)=1.d0+c2
      call zero(alam,36)
!c
!     *  cycle through four panel corner points                       *
!
      do 150 ic=1,4
      icp1=mod(ic,4)+1
      icp2=mod(icp1,4)+1
      icp3=mod(icp2,4)+1
      icp4=ic+4
      icp6=icp2+4
!c
!     *  compute weights for combining lamdas calculated at each      *
!     *  endpoint of quarter panel diagonal                           *
!
      wt1=1.d0/(fs(ic)+fs(icp3))
      wt2=1.d0/(fs(ic)+fs(icp1))
      alam(9,ic)=alam(9,ic)+wt1*fc(ic)
      alam(9,icp1)=alam(9,icp1)+wt2*fc(icp1)
      alam(icp4,ic)=alam(icp4,ic)+wt1*(fs(ic)-.75d0*fc(ic))
      alam(icp4,icp1)=alam(icp4,icp1)+wt2*(fs(ic)-.75d0*fc(icp1))
      alam(icp6,ic)=alam(icp6,ic)-.25d0*wt1*fc(ic)
      alam(icp6,icp1)=alam(icp6,icp1)-.25d0*wt2*fc(icp1)
      alam(ic,ic)=alam(ic,ic)+.25d0*wt1
      alam(ic,icp1)=alam(ic,icp1)-.25d0*wt2
      alam(icp1,ic)=alam(icp1,ic)-.25d0*wt1
      alam(icp1,icp1)=alam(icp1,icp1)+.25d0*wt2
  150 continue
!
      do 155 ic = 1,4
          icp4   =  ic + 4
          icp7   =  mod(ic+2,4) + 5
          z(1)   =  .5d0*(cp(1,icp4) + cp(1,icp7))
          z(2)   =  .5d0*(cp(2,icp4) + cp(2,icp7))
          z(3)   =  .5d0*(cp(3,icp4) + cp(3,icp7))
          call nrpthp (ggcp,  cp,ics,  z,  sv,tv)
          call bqbfun (sv,tv,  alam(1,ic),phis,phit)
          call dscal (9,  2.d0,  alam(1,ic),1)
          alam(icp4,ic) = alam(icp4,ic) - .5d0
          alam(icp7,ic) = alam(icp7,ic) - .5d0
  155 continue
!
      isqn=mod(ics+1,4)+1
      if(ics.ne.0) go to 160
      d13=(cp(1,1)-cp(1,3))**2+(cp(2,1)-cp(2,3))**2+(cp(3,1)-cp(3,3))**2
      d24=(cp(1,2)-cp(1,4))**2+(cp(2,2)-cp(2,4))**2+(cp(3,2)-cp(3,4))**2
      if(d13.gt.d24) isqn=1
  160 continue
      kp=kn
      ipn=ip
      isp1=mod(isqn,4)+1
      ism1=mod(isqn+2,4)+1
      do 172 i=1,3
  172 z(i)=.5d0*(cp(i,isp1)+cp(i,ism1))
      call nrpthp (ggcp,  cp,ics,  z,  sv,tv)
      strc(1,3) = sv
      strc(2,3) = tv
      call surpro(z,zp,ic)
      call sincd(zp,ds,ic)
      do 175 i=1,9
  175 rc(i,3)=2.d0*ds(1,i)
      rc(isp1,3)=rc(isp1,3)-.5d0
      rc(ism1,3)=rc(ism1,3)-.5d0
      do 180 k=1,2
      is=isqn
      if(k.eq.2) is=mod(is+1,4)+1
      isp1=mod(is,4)+1
      ism1=mod(is+2,4)+1
      do 177 i=1,3
  177 z(i)=(cp(i,is)+cp(i,isp1)+cp(i,ism1))/3.d0
      call nrpthp (ggcp,  cp,ics,  z,  sv,tv)
      strc(1,k) = sv
      strc(2,k) = tv
      call surpro(z,zp,ic)
      call sincd(zp,ds,ic)
      do 179 i=1,9
  179 rc(i,k)=ds(1,i)
      if(ics.ne.0) go to 190
  180 continue
  190 continue
      dph     =  omg*diam
      if ( dph.lt. 1.1d0 ) goto 195
      ndpher  =  ndpher + 1
      write (6,6001) dph, omg, diam, kp, ipn, mm1, nm1
  195 continue
 6001 format (' ** total phase variation exceeds limit value (1.1) **'  &
     & ,/, '  phase variation:',f12.6,'   omg:',f12.6,'  diam:',f12.6   &
     & ,/, '  network & panel:',2i6  ,'   row:',i12  ,'   col:',i12 )
!c
!     *  store panel defining quantities on i/o unit (tape 2)         *
!
      call istrns(ip,cp)
  198 continue
  199 continue
      return
      END subroutine geomc
! **deck getcor
      subroutine getcor (label,lladdr,nw)
      character*(*) label
!
!        allocate  nw  words of dynamic memory, starting at the current
!        of dynamic memory, and set the pointer variable  lladdr  to the
!        first word address of this array.   the array label, 'label', i
!        saved in the array tables for possible debugging purposes.
!
!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
!
      if ( iniset .ne. 'goodcore' ) go to 1000
!
      maplev(3,levdyn) = maplev(3,levdyn) + 1
      lwsdyn  =  maplev(3,levdyn)
      if ( lwsdyn .gt. maxlws ) write (6,6001) lwsdyn, maxlws           &
     &  ,label, chrlev(levdyn), maplev(1,levdyn), maplev(2,levdyn)
 6001 format (' *****  error  *****  (getcor) too many arrays requested &
     &of getcor.  number requested = ',i8,'  maximum allocated = ',i8   &
     & ,/,    '                      requested for array ',a,'  from su &
     &broutine ',a,'  prev alloc.=',i8,'   subr alloc.=',i8)
      if ( lwsdyn.gt.maxlws ) call abtcor
      nwx     =  max(0,nw)
      lladdr  =  maplev(1,levdyn) + maplev(2,levdyn)
!                                    allocate reals
      maplev(2,levdyn) = maplev(2,levdyn) + nwx
!
      chrlws(lwsdyn) = label
      maplws(1,lwsdyn) = lladdr
      maplws(2,lwsdyn) = locfcn(lladdr)
      maplws(3,lwsdyn) = nwx
!
      nwtot   =  maplev(2,levdyn) + maplev(1,levdyn) - maplev(1,1)
      mxxlws  =  max(mxxlws,lwsdyn)
      mxxdyn  =  max(mxxdyn, nwtot)
!
      if ( nwx.eq.0 ) write (6,6200)
      if ( nwx.ne.0  .and.  .not.lwsprt ) go to 950
      write (6,6000)
      write (6,6100) levdyn, chrlev(levdyn), maplev(1,levdyn)           &
     &  , maplev(1,levdyn), nwtot, maplev(2,levdyn), lwsdyn             &
     &  , chrlws(lwsdyn), maplws(1,lwsdyn), nwx
!
  950 continue
!                               if not enough cm is available, try
!                               increasing it before inicating failure
      if ( nwtot .le. maxdyn ) go to 970
          incrcm  =  nwtot - maxdyn + 512
!                                  suppress increase in fl
! ---     call morcor (incrcm)
          incrcm  =  0
          maxdyn  =  maxdyn + incrcm
  970 continue
      if ( nwtot .gt. maxdyn ) write (6,6002) nwtot, maxdyn             &
     &   ,label, chrlev(levdyn), maplev(1,levdyn), maplev(2,levdyn)
 6002 format (' *****  error  *****  (getcor) too much memory requested &
     &of getcor.  amount requested = ',i8,'  maximum allocated = ',i8   &
     & ,/,    '                      requested for array ',a,'  from su &
     &broutine ',a,'  prev alloc.=',i8,'   subr alloc.=',i8)
      if ( nwtot .gt.maxdyn ) call abtcor
      return
!
 1000 continue
      write (6,6500) label, iniset
      CALL AbortPanair('getcor')
 6000 format (' getcor    levdyn   routine     base addr(z)  base addr  &
     & tot alloc   sub alloc   array    array       address  length '   &
     & )
 6100 format ('           ',i6, 3x,a,     4x,i10,i10,3x,i10,3x,i8,4x,i5 &
     &  ,6x,a,2x,i10,i6 )
 6200 format (' *****  warning  *****   zero words requested in call to &
     &getcor ')
 6500 format (' *****  error  *****   getcor called before inicor.  labe&
     &l  =  ',a,'    status word  =  ',a)
      END subroutine getcor
! **deck getlim
      subroutine getlim ( nnett, nm, nn, nza, zm )
      implicit double precision (a-h,o-z)
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     * determine minimum and maximum x, y, z coordinate              *
!     * limits of networks                                            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * *  m e t h o d  * * *                   *
!     *                          - - - - - -                          *
!     *                                                               *
!     * construct the array xyzlim having max and min array for x,y,z *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!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                   *
!     *                                                               *
!     *   icoor               input     coordinate for which to       *
!     *                                 determine limits: 1=x,2=y,3=z *
!     *                                                               *
!     *   nm                  input     number of rows                *
!     *                                                               *
!     *   nn                  input     number of columns             *
!     *                                                               *
!     *   nnett               input     number of networks            *
!     *                                                               *
!     *   nza                 input     cumulative number of networks *
!     *                                                               *
!     *   zm                  input     network geometry              *
!     *                                                               *
!     *   xyzlim    /secprp/  output    x,y,z minimum and maximum     *
!     *                                 values                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 secscr
      common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin  &
     &             , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2)
!end  secscr
!
      dimension nm(150), nn(150), nza(151), zm(3,4000)
!
!     diagnostic printout ***
      if( isecpr(igrps) .eq. 1)                                         &
     &write(6,1000)
 1000 format(1h1,47hnetwork minimum xyz and maximum xyz coordinates)
!     end diagnostic printout ***
!
      do 200, k=1, nnett
        nzk = nza(k) + 1
        nmk = nm(k)
        nnk = nn(k)
        do 199, icoor=1,3
          call limval(k, zm(1,nzk), nmk, nnk, icoor)
  199   continue
!
!       diagnostic printout ***
        if (isecpr(igrps) .eq. 1)                                       &
     &  write(6,2000) k,nmk,nnk,xyzlim(k,1,1),                          &
     &                          xyzlim(k,2,1),                          &
     &                          xyzlim(k,3,1),                          &
     &                          xyzlim(k,1,2),                          &
     &                          xyzlim(k,2,2),                          &
     &                          xyzlim(k,3,2)
 2000   format(1h ,8hnetwork=,i5,6h rows=,i5,6h cols=,i5,/,             &
     &         1h ,10hminimums: ,3e16.8,5x,10hmaximums: ,3e16.8)
!       end diagnostic printout ***
!
  200 continue
!
      END subroutine getlim
! **deck getpnt
      subroutine getpnt(q1,q2,cp,iside,itri,   pint,iflags)
      implicit double precision (a-h,o-z)
!
!     purpose: get an intersection point
!
!     inputs:  q1,q2  two points
!              cp     coefficients of plane
!              iside  index of side
!              itri   triangle number
!
!     outputs: pint   array of intersection points
!              iflags array indicating where intersection occurs
!
      dimension q1(3), q2(3)
      dimension cp(4)
      dimension pint(3,4,2)
      dimension temp(3)
      dimension iflags(3,2)
      logical   intf
      data tol  / 1.0d-6 /
!
      iflags(iside,itri) = 0
!
      call intpnt(q1,q2,cp,   temp,intf)
!
      if( .not. intf ) go to 999
!
      do 10 j=1,3
      pint(j,iside,itri) = temp(j)
   10 continue
!
      iflags(iside,itri) = 1
!
      if( .not. ( abs( temp(1) + 9999.d0 ) .le. tol )) go to 999
!
      iflags(iside,itri) = 2
!
      do 20 j=1,3
      pint(j,iside,itri) = q1(j)
      pint(j,4    ,itri) = q2(j)
   20 continue
!
  999 return
      END subroutine getpnt
! **deck gphplk
      subroutine gphplk (nb,  nnode,mnod,  p,q,brnm,w,kb                &
     &              ,head,point,count,key,  iabtpr,nfail)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   treplk reorganizes the node/node description of a tree      *
!     *   so that the branches occur in proper plucking order.        *
!     *   in the reorganized description,  p(i)  is the node at       *
!     *   which we pluck off branch  brnm(i)  at stage  i  of the     *
!     *   defoliation process.                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      integer p(nb), q(nb), brnm(nb), head(100), point(200), count(100)
!                                      nnode    2*nb        nnode
      integer    key(nb), kb(nb)
      dimension w(nb)
      integer pq, qp, b, psav, mnod(nnode)
!
      integer prclas(3,3)
      data prclas / 5,3,1,  2,4,7,  6,0,0 /
!
      nfail   =  0
      if ( nb.le.0 ) return
!c
!     *   initialize the head array (head pointers for the linked list*
!     *   of branches attached to node i) and the count array (contain*
!     *   ing the degree of the nodes)                                *
!
      do 10 pq = 1,nnode
      count(pq) = 0
   10 head(pq)=  0
!c
!     *   build the linked list data structure and count the degree   *
!     *   of the nodes                                                *
!
      do 20 b = 1,nb
          ipb     =  p(b)
          iqb     =  q(b)
          point(2*b-1) = head(ipb)
          point(2*b  ) = head(iqb)
          head(ipb)    = 2*b-1
          head(iqb)    = 2*b
          count(ipb)   = count(ipb)+1
          count(iqb)   = count(iqb)+1
   20 continue
!c
!     *   the following loop ranges over the stages of the plucking   *
!     *   process                                                     *
!
      do 100 ib = 1,nb
!c
!     *   find a node of degree 1 that is not node pqgr               *
!
      psav    =  0
      isav    =  0
      wsav    =  0
      do 30 pq = 1,nnode
          if ( count(pq) .eq. 0 ) go to 30
          if ( count(pq) .ne. 1 ) go to 30
          l       =  head(pq)
          b       =  (l+1)/2
          ityp    =  prclas( kb(b)+2,  mnod(pq)+2 )
          if ( ityp - isav ) 30,32,34
   32     continue
          if ( mnod(pq) .eq. -1 ) go to  33
!                                  mnod(pq) = 0 .  select highest
!                                  weighted branch.
               if ( w(b) .lt. wsav ) go to 30
               go to 34
!                                  mnod(pq) = -1 .  select lowest
!                                  weighted branch
   33     continue
               if ( w(b) .gt. wsav ) go to 30
               go to 34
   34     continue
          psav    =  pq
          isav    =  ityp
          wsav    =  w(b)
   30 continue
      pq      =  psav
      ityp    =  isav
      if ( ityp.eq.0 ) go to 6000
   40 continue
!c
!     *   find the branch number  b  to be plucked and set key(b)     *
!
      pq      =  psav
      l       =  head(pq)
      b       =  (l+1)/2
      key(b)  =  ib
!c
!     *   get the node number  qp  and the pointer index lt for       *
!     *   the other end of branch  b.   if necessary, interchange     *
!     *   p(b) and q(b) so that  p(b) = pq.                           *
!
      if ( mod(l,2) .eq. 0 ) go to 60
!              l = odd.  thus pq = p(b)
          qp      =  q(b)
          lt      =  l + 1
          go to 70
!              l = even.  thus pq = q(b)
   60 continue
          qp      =  p(b)
          lt      =  l - 1
          p(b)    =  pq
          q(b)    =  qp
!c
!     *   update the counters and the linked list pointers            *
!
   70 continue
      count(pq) = 0
      count(qp) = count(qp) - 1
!c
!     *   starting at head(qp), chase around looking for lt           *
!
      if ( head(qp) .ne. lt ) go to 80
          head(qp) =  point(lt)
          point(lt)  =  0
          go to 99
   80 continue
      k       =  head(qp)
   90 continue
      kt      =  point(k)
      if ( kt.eq.lt ) go to 95
          k       =  kt
          go to 90
   95 continue
!c
!     *   update the pointer structure                                *
!
      point(k) = point(kt)
      point(lt)   =  0
   99 continue
  100 continue
!c
!     *   rearrange the branches into their proper order as specified *
!     *   by  key                                                     *
!
      call ukysrt (nb,p,key)
      call ukysrt (nb,q,key)
      call ukysrt (nb,brnm,key)
      call ukysrd (nb,w,key)
      call ukysrt (nb,kb,key)
      return
 6000 continue
      nfail   =  -1
      return
      END subroutine gphplk
! **deck gphscn
      subroutine gphscn (nb,nnode,p,q,brnm,pr,kb,netwk,  ntr,nbtra      &
     &              ,key,  iabtpr,nfail)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   trescn identifies a spanning tree for a connected graph,    *
!     *   ( p(i), q(i) ), i=1,nb   where nb is the number of branches.*
!     *   on exit, the tree   ( ( p(i),q(i) ), i=1,nbtr ) will be     *
!     *   a spanning tree for all the nodes in the original graph.    *
!     *   if, on entry,  (brnm(i),i=1,nb)  is a list of names or      *
!     *   labels for the branches of the input graph, then on exit    *
!     *   (brnm(i),i=1,nbtr) will contain the names of the branches   *
!     *   (p(i),q(i)) of the spanning tree.                           *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!                                                  nnode     ntr+1
      integer p(nb), q(nb), brnm(nb), key(nb), netwk(nnode), nbtra(101)
      integer kb(nb)
      dimension    pr(nb)
      logical stree
!
      nfail    =  0
!c
!     *   check that all node numbers are in range                    *
!
      do 100 i = 1,nb
      if ( p(i).lt.1  .or.  p(i).gt.nnode ) go to 6000
      if ( q(i).lt.1  .or.  q(i).gt.nnode ) go to 6000
  100 continue
!c
!     *   sort on priorities, pushing high priority branches to top.  *
!     *   by doing this, high priority branches will be scanned first *
!
      do 110 i = 1,nb
  110 pr(i)   =  -pr(i)
      call dshell (nb,pr,key)
      call keysrt (nb,brnm,key)
      call keysrt (nb,p,key)
      call keysrt (nb,q,key)
      call keysrt (nb,kb,key)
!c
!     *   initialize the network number array netwk, the subgraph     *
!     *   counters net and ket and nbtr, nbtrbk                       *
!
      do 140 i = 1,nnode
  140 netwk(i)=  0
      do 150 i = 1,nb
  150 key(i)  =  0
      ket     =  0
      net     =  0
      nbtr    =  0
      nbtrbk  =  nb+1
!c
!     *   examine each branch for inclusion in the spanning tree      *
!
      do 5000 i = 1,nb
!c
!     *        stree will be set false if this branch is not part of  *
!     *        the spanning tree                                      *
!
          stree   =  .true.
!c
!     *        check four basic cases                                 *
!
          ip      =  p(i)
          iq      =  q(i)
          np      =  netwk(ip)
          nq      =  netwk(iq)
          if ( np.ne.0 ) go to 220
          if ( nq.ne.0 ) go to 2000
          go to 1000
  220     continue
          if ( nq.eq.0 ) go to 3000
          go to 4000
!         -------------------------------------------------------
!
!              case 1. np = nq = 0
 1000     continue
               if ( ip.eq.iq ) go to 4650
               net     =  net + 1
               ket     =  ket + 1
               netwk(ip) = ket
               netwk(iq) = ket
               go to 4600
!
!              case 2. np = 0, nq " 0
 2000     continue
               netwk(ip) = netwk(iq)
               go to 4600
!
!              case 3. np " 0, nq = 0
 3000     continue
               netwk(iq) = netwk(ip)
               go to 4600
!
!              case 4. np " 0, nq " 0
 4000     continue
               if ( np .ne. nq ) go to 4100
                    stree   =  .false.
                    go to 4600
 4100          continue
                    do 4200 j = 1,nnode
                    if ( netwk(j).eq.np ) netwk(j) = nq
 4200               continue
                    net     =  net - 1
!
!         -------------------------------------------------------
!                        set key array
 4600     continue
          if ( .not.stree ) go to 4650
               nbtr    =  nbtr + 1
               ikey    =  nbtr
               go to 4700
 4650     continue
               nbtrbk  =  nbtrbk - 1
               ikey    =  nbtrbk
 4700     continue
          key(i)  =  ikey
 5000 continue
!c
!     *   sort pq array into tree branches and non-tree branches      *
!
      call ukysrt (nb,p,key)
      call ukysrt (nb,q,key)
      call ukysrt (nb,brnm,key)
      call ukysrd (nb,pr,key)
      call ukysrt (nb,kb,key)
!              restore signs on pr array
      do 5100 i = 1,nb
          pr(i)   =  -pr(i)
 5100 continue
!                                  generate a pointer array into the lis
!                                  of tree branches that describes the
!                                  disjoint subtrees.
!
!                                  begin by assigning a subgraph
!                                  identifier to each branch in the
!                                  reordered list.
      do 5500 ib = 1,nb
          nbtra(ib) =  netwk( p(ib) )
 5500 continue
      call ifera (nbtra,netwk,nb)
      call jshell (nbtr,netwk,key)
      call keysrt (nbtr,p   ,key)
      call keysrt (nbtr,q   ,key)
      call keysrt (nbtr,brnm,key)
      call keysrd (nbtr,pr  ,key)
      call keysrt (nbtr,kb  ,key)
      netold  =  0
      ntr     =  0
      if ( nbtr.le.0 ) go to 5610
      do 5600 ib = 1,nbtr
          if ( netwk(ib) .eq. netold ) go to 5600
          netold  =  netwk(ib)
          ntr     =  ntr + 1
          nbtra(ntr) = ib - 1
 5600 continue
 5610 continue
      nbtra(ntr+1) =  nbtr
      if ( ntr .ne. net ) go to 6000
      return
!              fatal error.  print a message and stop
 6000 continue
      nfail   =  1
      return
      END subroutine gphscn
! **deck gpluck
      subroutine gpluck (nb,nnode,mnod,igrd                             &
     &                  ,p,q,brnm,w,kb,  head,point,count,key           &
     &                  ,iabtpr,nfail)
      implicit double precision (a-h,o-z)
      integer p(nb), q(nb), brnm(nb), head(100), point(200), count(100)
!                                      nnode    2*nb        nnode
      integer    key(nb), kb(nb)
      dimension w(nb)
      integer pq, qp, b, psav, mnod(nnode)
!
      integer prclas(3,3)
      data prclas / 5,3,1,  2,4,7,  6,0,0 /
!
      nfail   =  0
      if ( nb.le.0 ) return
!c
!     *   initialize the head array (head pointers for the linked list*
!     *   of branches attached to node i) and the count array (contain*
!     *   ing the degree of the nodes)                                *
!
      do 10 pq = 1,nnode
      count(pq) = 0
   10 head(pq)=  0
!c
!     *   build the linked list data structure and count the degree   *
!     *   of the nodes                                                *
!
      do 20 b = 1,nb
          ipb     =  p(b)
          iqb     =  q(b)
          point(2*b-1) = head(ipb)
          point(2*b  ) = head(iqb)
          head(ipb)    = 2*b-1
          head(iqb)    = 2*b
          count(ipb)   = count(ipb)+1
          count(iqb)   = count(iqb)+1
   20 continue
!c
!     *   the following loop ranges over the stages of the plucking   *
!     *   process                                                     *
!
      do 100 ib = 1,nb
!c
!     *   find a node of degree 1 that is not node pqgr               *
!
      psav    =  0
      isav    =  0
      wsav    =  0
      do 30 pq = 1,nnode
          if ( count(pq) .eq. 0 ) go to 30
          if ( count(pq) .ne. 1 ) go to 30
          if ( pq .eq. igrd ) go to 30
          l       =  head(pq)
          b       =  (l+1)/2
          ityp    =  prclas( kb(b)+2,  mnod(pq)+2 )
          psav    =  pq
          isav    =  ityp
          wsav    =  w(b)
   30 continue
      pq      =  psav
      ityp    =  isav
      if ( ityp.eq.0 ) go to 6000
!c
!     *   find the branch number  b  to be plucked and set key(b)     *
!
      pq      =  psav
      l       =  head(pq)
      b       =  (l+1)/2
      key(b)  =  ib
!c
!     *   get the node number  qp  and the pointer index lt for       *
!     *   the other end of branch  b.   if necessary, interchange     *
!     *   p(b) and q(b) so that  p(b) = pq.                           *
!
      if ( mod(l,2) .eq. 0 ) go to 60
!              l = odd.  thus pq = p(b)
          qp      =  q(b)
          lt      =  l + 1
          go to 70
!              l = even.  thus pq = q(b)
   60 continue
          qp      =  p(b)
          lt      =  l - 1
          p(b)    =  pq
          q(b)    =  qp
!c
!     *   update the counters and the linked list pointers            *
!
   70 continue
      count(pq) = 0
      count(qp) = count(qp) - 1
!c
!     *   starting at head(qp), chase around looking for lt           *
!
      if ( head(qp) .ne. lt ) go to 80
          head(qp) =  point(lt)
          point(lt)  =  0
          go to 99
   80 continue
      k       =  head(qp)
   90 continue
      kt      =  point(k)
      if ( kt.eq.lt ) go to 95
          k       =  kt
          go to 90
   95 continue
!c
!     *   update the pointer structure                                *
!
      point(k) = point(kt)
      point(lt)   =  0
   99 continue
  100 continue
!c
!     *   rearrange the branches into their proper order as specified *
!     *   by  key                                                     *
!
      call ukysrt (nb,p,key)
      call ukysrt (nb,q,key)
      call ukysrt (nb,brnm,key)
      call ukysrd (nb,w,key)
      call ukysrt (nb,kb,key)
!                                  check for bad assignments
      nfail   =  0
      ngrasn  =  0
      do 150 b = 1,nb
          if ( mnod(p(b)) .lt. 0 ) ngrasn = ngrasn + 1
          ityp    =  prclas(  kb(b)+2,  mnod(p(b))+2  )
          if ( ityp .le. 2 ) nfail = nfail + 1
  150 continue
      if ( ngrasn.gt.0  .and.  mnod(igrd).eq.0 ) nfail = nfail + 1
      return
 6000 continue
      nfail   =  -1
      return
      END subroutine gpluck
! **deck grdind
      subroutine grdind(nm,nn,z,i,is)
      implicit double precision (a-h,o-z)
!***created  on 76.009    w.o. no.   0   version        ftj.00
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to order non-identical points of an nm x nn grid of points   *
!     *  via an index array                                           *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  if a point has the same approximate position as a point in   *
!     *  the previous row or column, then it is assigned the same     *
!     *  index as that point, else the index counter is incremented   *
!     *  by one before being assigned to the point.  note that the    *
!     *  outer loop is over columns, and the inner loop is over rows  *
!     *  in the index assignment.                                     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   ident     -local-   - - - -   set to .true. if points are   *
!     *                                 essentially the same          *
!     *                                                               *
!     *   is        argument  output    number of unique points in    *
!     *                                 grid                          *
!     *                                                               *
!     *   i         argument  output    indexed array identifying the *
!     *                                 sequence of unique points     *
!     *                                                               *
!     *   nm        argument  input     number of rows in the grid    *
!     *                                                               *
!     *   nn        argument  input     number of columns in the grid *
!     *                                                               *
!     *   z         argument  input     coordinates of the points in  *
!     *                                 the grid (in three-space)     *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      logical ident
      dimension z(3,nm,nn),i(nm,nn)
      is=0
!c
!     *  loop ranges over columns in the grid                         *
!
      do 99 n=1,nn
!c
!     *  loop ranges over rows in the grid                            *
!
      do 98 m=1,nm
      ident=.false.
!c
!     *  determine if the previous row essentially the same           *
!
      if(m.gt.1) call pident(z(1,m,n),z(1,m-1,n),ident)
      if(ident) i(m,n)=i(m-1,n)
      if(ident) go to 98
!c
!     *  determine if the previous column essentially the same        *
!
      if(n.gt.1) call pident(z(1,m,n),z(1,m,n-1),ident)
      if(ident) i(m,n)=i(m,n-1)
      if(ident) go to 98
!c
!     *  point is unique, bump unique point index and assign it       *
!
      is=is+1
      i(m,n)=is
   98 continue
   99 continue
      return
      END subroutine grdind
! **deck gridgn
      subroutine gridgn (ox,oy,oz,xx,xy,xz,yx,yy,yz,zx,zy,zz,dx,dy,dz   &
     &                 ,ix,iy,iz,a)
      implicit double precision (a-h,o-z)
!******
!     purpose  to compute a grid of points given direction vectors,
!              increments, and number of points in each direction.
!
!     input    calling sequence
!              ox - x coordinate of origin of coordinate system.
!              oy - y coordinate of origin of coordinate system.
!              oz - z coordinate of origin of coordinate system.
!              xx - x coordinate of point determining x axis direction.
!              xy - y coordinate of point determining x axis direction.
!              xz - z coordinate of point determining x axis direction.
!              yx - x coordinate of point determining y axis direction.
!              yy - y coordinate of point determining y axis direction.
!              yz - z coordinate of point determining y axis direction.
!              zx - x coordinate of point determining z axis direction.
!              zy - y coordinate of point determining z axis direction.
!              zz - z coordinate of point determining z axis direction.
!              dx - distance between points in x direction.
!              dy - distance between points in y direction.
!              dz - distance between points in z direction.
!              ix - number of points in x direction.
!              iy - number of points in y direction.
!              iz - number of points in z direction.
!
!     output   calling sequence
!              a - array in which grid points reside on output.  a(1),
!                  a(2), and a(3) are the x,y,and z components of the
!                  first point, etc.
!
!     comment  the array must be dimensioned externally at least
!              3*ix*iy*iz.
!******
      dimension a(1)
!
!                             compute normalized coordinate direction
!                             vectors
      xxrel  = (xx - ox)
      xyrel  = (xy - oy)
      xzrel  = (xz - oz)
      xnorm = sqrt(xxrel**2 + xyrel**2 + xzrel**2)
      xxnorm = xxrel/xnorm
      xynorm = xyrel/xnorm
      xznorm = xzrel/xnorm
      yxrel  = (yx -ox)
      yyrel  = (yy -oy)
      yzrel  = (yz -oz)
      ynorm  = sqrt(yxrel**2 + yyrel**2 + yzrel**2)
      yxnorm = yxrel/ynorm
      yynorm = yyrel/ynorm
      yznorm = yzrel/ynorm
      zxrel  = (zx - ox)
      zyrel  = (zy - oy)
      zzrel  = (zz - oz)
      znorm  = sqrt(zxrel**2 + zyrel**2 + zzrel**2)
      zxnorm = zxrel/znorm
      zynorm = zyrel/znorm
      zznorm = zzrel/znorm
      ic = 1
      do 100 i = 1,ix
        do 200 j = 1,iy
          do 300 k = 1,iz
!
!                             compute x coordinate of point
          aaaim1= i-1
          aaajm1= j-1
          a(ic) = ox + dx*aaaim1*xxnorm+ dy*aaajm1*yxnorm +             &
     &            dz*(k-1)*zxnorm
!
!                             compute y coordinate of point
          aaaim1  =  i-1
          aaajm1  =  j-1
          a(ic+1) = oy + dx*aaaim1*xynorm + dy*aaajm1*yynorm            &
     &              + dz*(k-1)*zynorm
!
!                             compute z coordinate of point
          aaaim1  =  i-1
          aaajm1  =  j-1
          a(ic+2) = oz + dx*aaaim1*xznorm + dy*aaajm1*yznorm +          &
     &              dz*(k-1)*zznorm
          ic = ic + 3
  300     continue
  200   continue
  100 continue
      return
      END subroutine gridgn
! **deck gtalam
      subroutine gtalam (c1,c2,alam)
      implicit double precision (a-h,o-z)
      dimension alam(9,4)
!         compute  alam  array for old style subpanel doublet splines
      dimension f(4)
      f(1)    =  1.d0+c1+c2
      f(2)    =  1.d0+c1-c2
      f(3)    =  1.d0-c1-c2
      f(4)    =  1.d0-c1+c2
!
      do 100 k = 1,4
          kp0     =  k
          kp1     =  mod(k  ,4) + 1
          kp2     =  mod(k+1,4) + 1
          kp3     =  mod(k+2,4) + 1
          kp4     =  kp0 + 4
          kp5     =  kp1 + 4
          kp6     =  kp2 + 4
          kp7     =  kp3 + 4
          fac     =  .25d0/( 1.d0+f(k) )
          alam(kp0,k)  =  2.d0
          alam(kp1,k)  =  -1.d0
          alam(kp2,k)  =  0.d0
          alam(kp3,k)  =  -1.d0
          alam(kp4,k)  =  2.d0*f(kp1) - f(k)
          alam(kp5,k)  =  -f(k)
          alam(kp6,k)  =  -f(k)
          alam(kp7,k)  =  2.d0*f(kp3) - f(k)
          alam(9  ,k)  =  8.d0*f(k)
          do 50 i = 1,9
               alam(i,k) = fac*alam(i,k)
   50     continue
  100 continue
      return
      END subroutine gtalam
! **deck hcmmp1
      subroutine hcmmp1 (m,l,n,  a,ia,ja,  b,ib,jb,  c,ic,jc)
      implicit double precision (a-h,o-z)
      complex*16 a(1), b(1), c(1)
      complex*16 blbkj
!
!         perform   c <--   a * b  with all inputs having generic addres
!                  m,l     m,l l,n
!
!
      lc1j    =  1
      do 60 j = 1,n
         lcij    =  lc1j
         do 50 i = 1,m
            c(lcij) =  0.d0
            lcij    =  lcij + ic
   50    continue
         lc1j    =  lc1j + jc
   60 continue
!
      lc1j    =  1
      lb1j    =  1
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) + a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine hcmmp1
! **deck hcmmp2
      subroutine hcmmp2 (m,l,n,  a,ia,ja,  b,ib,jb,  c,ic,jc)
      implicit double precision (a-h,o-z)
      complex*16 a(1), b(1), c(1)
      complex*16 blbkj
!
!     perform  c <-- c + a * b  with all inputs having generic addresses
!             m,n       m,l l,n
!
!
!
      lc1j    =  1
      lb1j    =  1
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) + a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine hcmmp2
! **deck hcmmp3
      subroutine hcmmp3 (m,l,n,  a,ia,ja,  b,ib,jb,  c,ic,jc)
      implicit double precision (a-h,o-z)
      complex*16 a(1), b(1), c(1)
      complex*16 blbkj
!
!     perform  c <-- c - a * b  with all inputs having generic addresses
!             m,n       m,l l,n
!
!
!
      lc1j    =  1
      lb1j    =  1
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) - a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine hcmmp3
! **deck hcmvp3
      subroutine hcmvp3 (m,l,  a,ia,ja,  b,ib,  c,ic)
      implicit double precision (a-h,o-z)
      complex*16 a(1), b(1), c(1), blbk
      la1k    =  1
      lbk    =   1
      do 200 k = 1,l
          blbk   =   b(lbk)
          lci    =   1
          laik   =  la1k
          do 100 i = 1,m
               c(lci)   =  c(lci) - a(laik)*blbk
               lci      =  lci + ic
               laik     =  laik + ia
  100     continue
          la1k    =  la1k + ja
          lbk     =  lbk + ib
  200 continue
      return
      END subroutine hcmvp3
! **deck hsmmp1
      subroutine hsmmp1 (m,l,n,  a,ia,ja,  b,ib,jb,  c,ic,jc)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
!
!         perform   c <-- c +  a * b  with all inputs having generic add
!                  m,l   m,l  m,l l,n
      lc1j    =  1
      lb1j    =  1
      call mzero (m,n,  c,ic,jc)
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) + a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine hsmmp1
! **deck hsmmp2
      subroutine hsmmp2 (m,l,n,  a,ia,ja,  b,ib,jb,  c,ic,jc)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
      lc1j    =  1
      lb1j    =  1
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) + a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine hsmmp2
! **deck hsmmp3
      subroutine hsmmp3 (m,l,n,  a,ia,ja,  b,ib,jb,  c,ic,jc)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
      lc1j    =  1
      lb1j    =  1
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) - a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine hsmmp3
! **deck hsmvp3
      subroutine hsmvp3 (m,l,  a,ia,ja,  b,ib,  c,ic)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
      la1k    =  1
      lbk    =   1
      do 200 k = 1,l
          blbk   =   b(lbk)
          lci    =   1
          laik   =  la1k
          do 100 i = 1,m
               c(lci)   =  c(lci) - a(laik)*blbk
               lci      =  lci + ic
               laik     =  laik + ia
  100     continue
          la1k    =  la1k + ja
          lbk     =  lbk + ib
  200 continue
      return
      END subroutine hsmvp3
! **deck iandfn
      integer function iandfn (ipos,jpos)
!
!     evaluate  ipos .and. jpos  for  0  <=  ipos,jpos  <=  3
!
      dimension kand(0:3,0:3)
      data kand / 0,0,0,0                                               &
     &         ,  0,1,0,1                                               &
     &         ,  0,0,2,2                                               &
     &         ,  0,1,2,3 /
!
      if ( ipos.lt.0 .or. ipos.gt.3 ) goto 500
      if ( jpos.lt.0 .or. jpos.gt.3 ) goto 500
!
      iandfn  =  kand(ipos,jpos)
      return
!
  500 continue
      write (6,'( '' bad  (ipos,jpos) passed to iandfn:'',2i10)')       &
     &     ipos, jpos
      call remarx (' bad data passed to iandfn ')
      CALL AbortPanair('iandfn')
      return
      END Function iandfn
! **deck ibsrc2
      subroutine ibsrc2 (locsrt,ibase,n,locind,ist)
      implicit double precision (a-h,o-z)
!c
!
!     using binary search, find ist such that ---
!
!         locsrt(:,ist)  .lt.  locind(:)  .le.  locsrt(:,ist+1)
!
!         if   locind(:) .le. locsrt(:,ibase    ),  then  ist = 0
!         if   locind(:) .gt. locsrt(:,ibase+n-1),  then  ist = n
!
!         note that the order relationship is defined by running the
!         set of tests:
!              do 100 i = 1,4
!                   if ( locind(i) .gt. locsrt(i,k) ) goto greater
!                   if ( locind(i) .lt. locsrt(i,k) ) goto lesser
!     100      continue
!     equal:   locind(:) = locsrt(:,k); break;
!     greater: locind(:) > locsrt(:,k); break;
!     lesser:  locind(:) < locsrt(:,k); break;
!
!         locind  i   int   array of length 4 that is the target of the
!         locsrt  i   int   locsrt(1:4,1:n) is an ordered list of 4-tupl
!                           the order relationship between two 4-tuples
!                           defined such that if  i'  is the 1st positio
!                           in which two 4-tuples (say k and l) disagree
!                           entry-k < entry-l if  locsrt(i',k) < locsrt(
!                           entry-k > entry-l if  locsrt(i',k) > locsrt(
!         n       i   int   the number of 4-tuples in  locsrt.
!         ist     o   int   the required position in the locsrt array.
!
!     dennis tynan, 30 june 1988
!
      dimension  locsrt(1:*),locind(4)
!c
!     using binary search, find ist such that ---
!
!       locsrt(ist)  .lt.  locind  .le.  locsrt(ist+1)
!
!         if   locind .le. locsrt(1),  then  ist = 0
!         if   locind .gt. locsrt(n),  then  ist = n+1
!
      ist     =  0
      if ( n.le.0 ) go to 900
!djt
!djt      if ( locind .le. locsrt(1) ) return
!djt
      do 10 i=1,4
      if(locind(i).lt.locsrt(4*ibase-4+i)) go to 900
      if(locind(i).gt.locsrt(4*ibase-4+i)) go to 20
   10 continue
      go to 900
   20 continue
      ist     =  n
!djt
!djt      if ( locind .gt. locsrt(n) ) return
!djt
      do 30 i=1,4
      if(locind(i).gt.locsrt(4*(ibase-1+n)-4+i)) go to 900
      if(locind(i).lt.locsrt(4*(ibase-1+n)-4+i)) go to 40
   30 continue
   40 continue
      iup     =  n-1
      idn     =  1
      ichk    =  4*n
  100 itst    =  (iup+idn)/2
!djt
!djt      if ( locind.gt.locsrt(itst) )  idn = itst
!djt
      do 120 i=1,4
      if(locind(i).gt.locsrt(4*(ibase-1+itst)-4+i)) then
        idn = itst
        go to 140
      elseif(locind(i).lt.locsrt(4*(ibase-1+itst)-4+i)) then
        go to 140
      endif
  120 continue
  140 continue
!djt
!djt      if ( locind.le.locsrt(itst+1)) iup = itst
!djt
      do 160 i=1,4
      if(locind(i).lt.locsrt(4*(ibase-1+itst+1)-4+i)) then
        iup = itst
        go to 180
      elseif(locind(i).gt.locsrt(4*(ibase-1+itst+1)-4+i)) then
        go to 180
      endif
  160 continue
      iup = itst
  180 continue
!djt
!djt      if(mod(iup+idn,2).eq.1.and.locind.gt.locsrt(idn+1)) idn=idn+1
!djt
      if(mod(iup+idn,2).eq.1) then
        do 220 i=1,4
        if(locind(i).gt.locsrt(4*(ibase-1+idn+1)-4+i)) then
          idn = idn + 1
          go to 240
        elseif(locind(i).lt.locsrt(4*(ibase-1+idn+1)-4+i)) then
          go to 240
        endif
  220   continue
  240   continue
      endif
      ichk    =  ichk/2
      if ( ichk.le.0 ) then
        write(6,300) ist,iup,idn,n,ibase,locind,                        &
     &               (locsrt(j),j=1,4*ibase-4+4*n)
  300   format(' fatal error in ibsrc2.  ist,iup,idn,n =',4i10/         &
     &         '                         ibase         =', i10/         &
     &         '                         locind        =',4i10/         &
     &         '                         locsrt        ='/              &
     & (1x,8i10/1x,8i10/1x,8i10/1x,8i10/1x,8i10/))
        call uabend
      endif
      if ( iup.ne.idn ) go to 100
      ist     =  idn
!djt
!djt      if (locind.le.locsrt(ist).or.locind.gt.locsrt(ist+1)) then
!djt        write (6,300) ist,iup,idn,n,locind,(locsrt(i),i=1,4*n)
!djt        call uabend
!djt      endif
!djt
      do 320 i=1,4
      if(locind(i).lt.locsrt(4*(ibase-1+ist)-4+i)) then
        write(6,300) ist,iup,idn,n,ibase,locind,                        &
     &               (locsrt(j),j=1,4*ibase-4+4*n)
        call uabend
      elseif(locind(i).gt.locsrt(4*(ibase-1+ist)-4+i)) then
        go to 340
      endif
  320 continue
      write(6,300) ist,iup,idn,n,ibase,locind,                          &
     &             (locsrt(j),j=1,4*ibase-4+4*n)
      call uabend
  340 continue
!
      do 360 i=1,4
      if(locind(i).gt.locsrt(4*(ibase-1+ist+1)-4+i)) then
        write(6,300) ist,iup,idn,n,ibase,locind,                        &
     &               (locsrt(j),j=1,4*ibase-4+4*n)
        call uabend
      elseif(locind(i).lt.locsrt(4*(ibase-1+ist+1)-4+i)) then
        go to 380
      endif
  360 continue
  380 continue
!djt
!djt  900 write(6,920) ist,iup,idn,n,ibase,locind,
!djt     +             (locsrt(j),j=1,4*ibase-4+4*n)
!djt  920 format(' success in ibsrc2.  ist,iup,idn,n =',4i10/
!djt     +       '                     ibase         =', i10/
!djt     +       '                     locind        =',4i10/
!djt     +       '                     locsrt        ='/
!djt     + (1x,8i10/1x,8i10/1x,8i10/1x,8i10/1x,8i10/))
  900 return
      END subroutine ibsrc2
! **deck ibsrch
      subroutine ibsrch (index,n,ind,ist)
      implicit double precision (a-h,o-z)
      dimension  index(n)
!         using binary search, find ist such that ---
!
!                   index(ist)  .lt.  ind  .le.  index(ist+1)
!
!         if   ind .le. index(1),  then  ist = 0
!         if   ind .gt. index(n),  then  ist = n+1
!
      ist     =  0
      if ( n.le.0 ) return
      if ( ind .le. index(1) ) return
!
      ist     =  n
      if ( ind .gt. index(n) ) return
!
      iup     =  n-1
      idn     =  1
      ichk    =  4*n
  100 continue
          itst    =  (iup+idn)/2
          if ( ind.gt.index(itst) )  idn = itst
          if ( ind.le.index(itst+1)) iup = itst
          if ( mod(iup+idn,2).eq.1 .and. ind.gt.index(idn+1) ) idn=idn+1
          ichk    =  ichk/2
          if ( ichk.le.0 ) go to 1100
          if ( iup.ne.idn ) go to 100
!                                  iup = idn
      ist     =  idn
      if ( .not. ( ind.gt.index(ist) .and. ind.le.index(ist+1) ))       &
     &                                                 go to 1100
      return
!                                  error
 1100 write (6,1200) ist,iup,idn,ind,n,index
 1200 format ( ' fatal error in ibsrch.  ist,iup,idn,ind,n =', 5i10     &
     &   ,/, (1x,10i10) )
      call uabend
      END subroutine ibsrch
! **deck ibtrns
      subroutine ibtrns(jc,bcd)
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to store boundary condition defining quantities              *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the information is stored via subroutine itrns               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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  input     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
      double precision  ctdb1a,b1a,ctdb2a,b2a
      common /bcona/                                                    &
     &               ctdb1a(14), n1a(6), b1a(4)                         &
     &             , ctdb2a(14), n2a(6), b2a(4)
      dimension bcd(1)
!c
!     *  store the information via itrns                              *
!
      call icopy (nbdq,  bcd,1,  ctdb1a,1)
!---      write (6, '(  '' ibtrns, jc, n1a, n2a:'',i5,2x,5i3,2x,5i3)' )
!---     x     jc,n1a,n2a
!---      call outvci (' ibtrns',nbdq,ctdb1a)
      call itrns(bcd,bcdq,nbdq,nsb,nrb,ntb,nib,jc)
      return
      END subroutine ibtrns
! **deck icmpr
      subroutine icmpr(msg,a,b,n,l)
      implicit double precision (a-h,o-z)
      integer a(n), b(n)
      character*(*) msg
!call prcmpr
!                                                            /prcmpr/
      common /prcmpr/ llcmpr
      logical llcmpr
!end  prcmpr
      dimension iloc(10)
      k = 0
      do 100 i = 1,n
      if ( a(i).eq.b(i) ) go to 100
      k = k + 1
      if ( k.le.10 ) iloc(k) = i
  100 continue
      l = l + k
      kk = min (k,10)
      if ( k.ne.0 .and.llcmpr ) call outvci (msg,kk,iloc)
      if ( k.ne.0 .and. llcmpr ) then
         call outvci ('a',n,a)
         call outvci ('b',n,b)
      endif
      return
      END subroutine icmpr
! **deck icopy
      subroutine icopy (n,  x,ix,  y,iy)
      implicit double precision (a-h,o-z)
      integer 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 icopy
! **deck ictrns
      subroutine ictrns(jc,cdq)
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to store control point defining quantities                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the information is stored via subroutine itrns               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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  input     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
!     *  store the information via itrns                              *
!
      call itrns(cdq,cntq,ncdq,nsc,nrc,ntc,nic,jc)
      return
      END subroutine ictrns
! **deck idamax
      integer function idamax (n,  y,iy)
      implicit double precision (a-h,o-z)
      dimension y(n)
!
!        standard blas isamax
!
      idamax = 0
      if ( n.le.0 ) return
      ly      =  1
      if ( iy.le.0 ) ly = ly + iabs(iy)*(n-1)
      imax    =  1
      ymax    =  abs(y(ly))
      do 100 k = 1,n
          if ( ymax.lt. abs(y(ly)) ) then
               imax = k
               ymax = abs(y(ly))
          endif
          ly      =  ly + iy
  100 continue
      idamax  =  imax
      return
      END Function idamax
! **deck idngeo
      subroutine idngeo (z1,z2,epsgeo,  epsequ)
      implicit double precision (a-h,o-z)
      dimension  z1(3), z2(3)
      logical  epsequ
!         determine if two points  z1  and  z2  lie within the distance
!         epsgeo of one another
      epsequ  =  .false.
      dzsq    =  ( z1(1) - z2(1) )**2                                   &
     &          +( z1(2) - z2(2) )**2                                   &
     &          +( z1(3) - z2(3) )**2
      if ( dzsq .le. epsgeo**2 ) epsequ = .true.
      return
      END subroutine idngeo
! **deck ifera
      subroutine ifera (ia,ib,n)
      dimension ia(n), ib(n)
!
!         copy from integer array ia to integer array ib
!
      if ( n.le.0 ) return
      do 100 k = 1,n
          ib(k) = ia(k)
  100 continue
      return
      END subroutine ifera
! **deck igtcor
      subroutine igtcor (label,lladdr,nw)
      character*(*) label
!
!        allocate  nw  words of dynamic memory, starting at the current
!        of dynamic memory, and set the pointer variable  lladdr  to the
!        first word address of this array.   the array label, 'label', i
!        saved in the array tables for possible debugging purposes.
!
!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
!
      if ( iniset .ne. 'goodcore' ) go to 1000
!
      maplev(3,levdyn) = maplev(3,levdyn) + 1
      lwsdyn  =  maplev(3,levdyn)
      if ( lwsdyn .gt. maxlws ) write (6,6001) lwsdyn, maxlws           &
     &  ,label, chrlev(levdyn), maplev(1,levdyn), maplev(2,levdyn)
 6001 format (' *****  error  *****  (igtcor) too many arrays requested &
     &of igtcor.  number requested = ',i8,'  maximum allocated = ',i8   &
     & ,/,    '                      requested for array ',a ,'  from su&
     &broutine ',a,'  prev alloc.=',i8,'   subr alloc.=',i8)
      if ( lwsdyn.gt.maxlws ) call abtcor
      nwx     =  max(0,nw)
      nwx     =  (nwx+nrl2in-1)/nrl2in
      lladdr  =  maplev(1,levdyn) + maplev(2,levdyn)
!                                    allocate integers
      maplev(2,levdyn) = maplev(2,levdyn) + nwx
!
      chrlws(lwsdyn) = label
      maplws(1,lwsdyn) = lladdr
      maplws(2,lwsdyn) = locfcn(lladdr)
      maplws(3,lwsdyn) = nwx
!
      nwtot   =  maplev(2,levdyn) + maplev(1,levdyn) - maplev(1,1)
      mxxlws  =  max(mxxlws,lwsdyn)
      mxxdyn  =  max(mxxdyn, nwtot)
!
      if ( nwx.eq.0 ) write (6,6200)
      if ( nwx.ne.0  .and.  .not.lwsprt ) go to 950
      write (6,6000)
      write (6,6100) levdyn, chrlev(levdyn), maplev(1,levdyn)           &
     &  , maplev(1,levdyn), nwtot, maplev(2,levdyn), lwsdyn             &
     &  , chrlws(lwsdyn), maplws(1,lwsdyn), nwx
!
  950 continue
!                                  if not enough cm is available, try
!                                  increasing it before inicating failur
      if ( nwtot .le. maxdyn ) go to 970
          incrcm  =  nwtot - maxdyn + 512
!                                  suppress increase in fl
! ---     call morcor (incrcm)
          incrcm  =  0
          maxdyn  =  maxdyn + incrcm
  970 continue
      if ( nwtot .gt. maxdyn ) write (6,6002) nwtot, maxdyn             &
     &   ,label, chrlev(levdyn), maplev(1,levdyn), maplev(2,levdyn)
 6002 format (' *****  error  *****  (igtcor) too much memory requested &
     &of igtcor.  amount requested = ',i8,'  maximum allocated = ',i8   &
     & ,/,    '                      requested for array ',a,'  from su &
     &broutine ',a,'  prev alloc.=',i8,'   subr alloc.=',i8)
      if ( nwtot .gt.maxdyn ) call abtcor
      return
!
 1000 continue
      write (6,6500) label, iniset
      CALL AbortPanair('igtcor')
 6000 format (' igtcor    levdyn   routine     base addr(z)  base addr  &
     & tot alloc   sub alloc   array    array       address  length '   &
     & )
 6100 format ('           ',i6, 3x,a,     4x,i10,i10,3x,i10,3x,i8,4x,i5 &
     &  ,6x,a,2x,i10,i6 )
 6200 format (' *****  warning  *****   zero words requested in call to &
     &igtcor ')
 6500 format (' *****  error  *****   igtcor called before inicor.  labe&
     &l  =  ',a,'    status word  =  ',a)
      END subroutine igtcor
! **deck inbc
      subroutine inbc(k,ica)
      implicit double precision (a-h,o-z)
!
!
!
!call inp1
!                                                            /inp1/
      character*80 icard
      common /inp1/ icard
!end  inp1
!call inp2
      common /inp2/ cpnrml,ntsk,ntdk,ipotk,nlpt1,nrpt1,nlpt2,nrpt2,ktk
!end  inp2
!call inp5
      common /inp5/ kn,ipter,amnsw,dnsmsh                               &
     &         , nedflk
!end  inp5
!call inp3
      common /inp3/ ntsin,ntsout
!end  inp3
!call inp4
      common /inp4/ dum(6),adm(20)
!end  inp4
!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 curpan
      common/curpan/cpnorm(150)
!end  curpan
!call kutflg
!                                                            /kutflg/
      common /kutflg/ kutta(150), kttype(150)
!end  kutflg
!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 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 nwprnt
      common /nwprnt/ imnwpr
      logical imnwpr
!end  nwprnt
!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 vicovr
!         override vic specifications                       /vicovr/
      common /vicovr/ nedflt(mxnett)
!                                                           /vicovr/
!end  vicovr
      logical lbc1, lbc2
      character*90 qline
!
!
!
      nwbtrn  =  2*( locfcn(cu2) - locfcn(cu1) )
      call dlocfx (nwbtrn)
      if(nnett.eq.0)go to 6020
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dum
      kn=dum(1)
      nedflk  =  dum(4)
      if ( nedflk.gt.1 ) nedflk = 4
      nedflk  =  max( 0, min( 4, nedflk) )
!                                  now disable it until we figure it out
      nedflk  =  0
      imnwpr  =  dum(5).ne.0.d0
!
!     set the curved panel normal option as follows
!
!         input value   pgm value
!             -1.           0       (old default, adjusted geometry)
!              0.           2       (new default, input geometry)
!              1.           1       (curved panel normals, as before)
!              2.           2       (input geometry)
      idum6   =  dum(6)
      cpnrml  = 2
      if ( dum(6).lt.0.d0 ) cpnrml = 0
      if ( idum6.eq.1 ) cpnrml = 1
!
      if(kn.gt.nnett)  go to 6060
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      kt = dum(1)
      ktk   =  kt
      amnsw = dum(5)
      nedflk  =  0
      write (6,'(1x,a10,1x, 2i12)')                                     &
     & 'kn,kt',kn,kt
      dnsmsh=dum(6)
      go to (610,620,630,640,650,660,670,680,690,6000                   &
     &      ,710 ,720 ,730 ,740 ,750 ,6000,770 ,780 ,790 , 800          &
     &      ,810 ,6000,6000,6000,6000,6000,6000,6000,6000,900           &
     &      ),kt
  610 continue
!
!      indirect mass flux b. c.
!
      ntsk=1
      ntdk=12
      ipotk=2
      nlpt1=5
      nrpt1=3
      nlpt2=7
      nrpt2=2
      go to 1001
  620 continue
!
!     thin wake
!
      tkw=dum(2)
      ntsk=0
      ntdk=12
      ipotk=0
      nlpt1=0
      nrpt1=0
      nlpt2=4
      nrpt2=3
      if(tkw.eq.1.d0)go to 625
      go to 1001
  625 continue
!
!     thin wake with simulated thickness
!
      ntsk=1
      ipotk=0
      nlpt1=5
      nrpt1=1
      go to 1002
  630 continue
!
!     superinclined panels
!
      ntsk=1
      ntdk=12
      ipotk=0
      nlpt1=3
      nrpt1=2
      nlpt2=7
      nrpt2=2
      go to 1001
  640 continue
!
!      inlets
!
      ntsk=1
      ntdk=12
      ipotk=0
      nlpt1=2
      nrpt1=1
      nlpt2=7
      nrpt2=2
      go to 1002
  650 continue
!
!     bases
!
      nedflk  =  4
      nedflk  =  4
      ntsk=1
      ntdk=12
      ipotk=2
      if(amach.gt.1.d0)go to 655
      nlpt1=6
      nrpt1 = 9
      nlpt2=7
      nrpt2=2
      go to 1001
  655 continue
      nlpt1=2
      nrpt1=2
      nlpt2=6
      nrpt2=2
      go to 1001
  660 continue
!
!      off body sources
!
      ntsk=1
      ntdk=0
      ipotk=0
      nlpt1=5
      nrpt1=2
      nlpt2=0
      nrpt2=2
      go to 1001
  670 continue
!
!     source alone mass flux b.c.
!
      ntsk=1
      ntdk=0
      ipotk=0
      nlpt1=2
      nrpt1=3
      nlpt2=0
      nrpt2=2
      go to 1001
  680 continue
!
!     direct mass flux b.c. composite networks
!
      ntsk=1
      ntdk=12
      ipotk=2
      nlpt1=2
      nrpt1=3
      nlpt2=7
      nrpt2=2
      go to 1001
  690 continue
!
!     inlet bc. with total mass flux
      ntsk = 1
      ntdk = 12
      ipotk = 2
      nlpt1 = 2
      nrpt1 = 7
      nlpt2 = 7
      nrpt2 = 2
      go to 1002
  710 continue
!
!     indirect velocity b.c., composite networks
!
      ntsk=1
      ntdk=12
      ipotk=2
      nlpt1=14
      nrpt1=3
      nlpt2=7
      nrpt2=2
      go to 1001
  720 continue
!
!     thin wings, velocity b.c., doublets alone.
!
      tkw=dum(2)
      ntsk=0
      ntdk=12
      ipotk=0
      nlpt1=0
      nrpt1=3
      nlpt2=13
      nrpt2=3
      if(tkw.eq.1.d0)go to 725
      go to 1001
  725 continue
!
!     thin wing, simulated thickness, velocity b.c. comp.
!
      ntsk=1
      nlpt1=14
      nrpt1=1
      go to 1002
  730 continue
!
!     superinclined
!
      if(amach.le.1.d0)go to 6030
      ntsk=1
      ntdk=12
      ipotk=0
      nlpt1=12
      nrpt1=2
      nlpt2=7
      nrpt2=2
      go to 1001
  740 continue
!
!     inlets, velocity b.c.
!
      ntsk=1
      ntdk=12
      ipotk=0
      nlpt1=11
      nrpt1=1
      nlpt2=7
      nrpt2=2
      go to 1002
  750 continue
!
!     direct velocuity b.c.
!
      ntsk=1
      ntdk=12
      ipotk=2
      nlpt1=11
      nrpt1=3
      nlpt2=7
      nrpt2=2
      go to 1001
  770 continue
!
!     source alone v.b.c.
!
      ntsk=1
      ntdk=0
      ipotk=0
      nlpt1=11
      nrpt1=3
      nlpt2=0
      nrpt2=2
      go to 1001
  780 continue
!
!     type 18 wake
!
      matchw=dum(2)
      iwksrc  =  dum(3)
      do 786 kk=1,kn
      k=k+1
      nts(k)=0
      ntd(k)=18
      ipot(k)=2
      kttype(k)=ktk
      nlopt1=0
      if ( iwksrc.ne.0 ) then
         nts(k)  =  1
         ipot(k) =  0
         nlopt1  =  5
         nropt1  =  2
      endif
      nropt2=2
      nlopt2  =  15
      if ( matchw .eq. 1 ) nlopt2 = 6
      if ( matchw .eq. 2 ) nlopt2 = 16
      if ( matchw.eq.3 ) nlopt2 = 17
      call meshp(k,ipter,amnsw,dnsmsh)
      nmp1=nm(k)+1
      nnp1=nn(k)+1
      if ( iwksrc.ne.0 ) goto 787
      do 786 n=1,nnp1
      do 786 m=1,nmp1
      if(m.gt.1)go to 786
      ica=ica+1
      call ibtrns(ica,cu1)
      nbca(k+1) = ica
  786 continue
      go to 1010
  787 continue
!                                  set b.c.'s for composite wake nw's
      inlop1  =  nlopt1
      inrop1  =  nropt1
      inlop2  =  nlopt2
      inrop2  =  nropt2
      do 788 n = 1,nnp1
      do 788 m = 1,nmp1
         nlopt1   =  inlop1
         nropt1   =  inrop1
         nlopt2   =  inlop2
         nropt2   =  inrop2
         if (m.gt.1) nlopt2 = 0
         if (m.eq.1 .or. m.eq.nmp1 .or. n.eq.1 .or. n.eq.nnp1) nlopt1=0
         ica     =  ica + 1
         call ibtrns (ica,cu1)
         nbca(k+1) = ica
  788 continue
      goto 1010
!
!               type 6 design wake, (no source)
  790 continue
      ipotk   =  0
      inlop1  =  0
      inrop1  =  0
      inlop2  =  18
      inrop2  =  2
      if ( dum(3).ne.0.d0 ) inlop2 = dum(3)
      if ( dum(4).ne.0.d0 ) inrop2 = dum(4)
!                                  set leading edge (kutta or not) condi
      matchw   =  dum(2)
      inlop3  =  15
      inrop3  =  2
      if ( matchw.eq.1 ) inlop3 = 6
      if ( matchw.eq.2 ) inlop3 = 16
      if ( matchw.eq.3 ) inlop3 = 17
!
      do 796 kk = 1,kn
      k       =  k + 1
      nts(k)  =  0
      ntd(k)  =  6
      call meshp (k,ipter,amnsw,dnsmsh)
      nmp1    =  nm(k) + 1
      nnp1    =  nn(k) + 1
      call cmngrd (k,mcp,ncp)
      do 795 n = 1,ncp
          do 793 m = 1,mcp
               call jzero (cu1,nwbtrn)
               nlopt1  =  inlop1
               nropt1  =  inrop1
               nlopt2  =  inlop2
               nropt2  =  inrop2
               if ( m.eq.1 .and. n.ne.1 .and. n.ne.nnp1 ) then
                    nlopt2 = inlop3
                    nropt2 = inrop3
               endif
               lbc1    =  .true.
               if ( m.eq.1 .or. m.eq.nmp1 .or. n.eq.1 .or. n.eq.nnp1 )  &
     &              lbc1  =  .false.
               if ( .not.lbc1 ) nlopt1 = 0
               lbc2    =  .true.
               if ( m.eq.nmp1 ) lbc2 = .false.
               if ( .not. lbc2 ) nlopt2 = 0
               if ( lbc2 ) then
                    nr2a = iabs(nropt2)
                    if ( nr2a.eq.1 .or. nr2a.eq.7 .or. nr2a.eq.8 ) then
                       read (ntsin,'( a )') qline
                       read (qline,5070,err=9950) bet2
               endif
               endif
               ica     =  ica + 1
               call ibtrns (ica,cu1)
               nbca(k+1) = ica
  793     continue
  795 continue
  796 continue
      go to 1010
!
  800 continue
!
!     type 20 wake
!
      do 806 kk=1,kn
      k=k+1
      nts(k)=0
      ntd(k)=20
      ipot(k)=2
      kttype(k)=ktk
      nlopt1=0
      nlopt2=6
      nropt2=2
      call meshp(k,ipter,amnsw,dnsmsh)
      nmp1=nm(k)+1
      nnp1=nn(k)+1
      do 806 n=1,nnp1
      do 806 m=1,nmp1
      if(m.gt.1.or.n.gt.1)go to 806
      ica=ica+1
      call ibtrns(ica,cu1)
      nbca(k+1) = ica
  806 continue
      go to 1010
  810 continue
!
!      doublets alone
!
      ntsk=0
      ntdk=12
      ipotk=4
      nlpt1=0
      nrpt1=3
      nlpt2=7
      nrpt2=4
      go to 1001
  900 continue
!
!     arbitrary b.c.
!
      ntsk=dum(2)
      ntdk = dum(3)
      ipotk= dum(4)
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      inlop1 = dum(1)
      inrop1 = dum(2)
      inlop2 = dum(3)
      inrop2 = dum(4)
      inlop3 = dum(5)
      inrop3 = dum(6)
      if ( inlop3.eq.0 ) then
          inlop3 = inlop2 - 3
          inrop3 = inrop2
      endif
      do 980 kk = 1,kn
          k       =  k + 1
          cpnorm(k) = cpnrml
          nedflt(k) = nedflk
          nts(k)  =  ntsk
          ntd(k)  =  ntdk
          ipot(k) =  ipotk
          kttype(k) = ktk
          call meshp (k,ipter,amnsw,dnsmsh)
          nmp1    =  nm(k) + 1
          nnp1    =  nn(k) + 1
          call cmngrd (k,mcp,ncp)
          write (6,8100) k,nts(k),ntd(k),nm(k),nn(k),mcp,ncp
!                                  put basic b.c. info in
          icsv    =  ica
          do 920 n = 1,ncp
          do 915 m = 1,mcp
               call jzero (cu1,nwbtrn)
               nlopt1  =  inlop1
               nropt1  =  inrop1
               nlopt2  =  inlop2
               nropt2  =  inrop2
               if (    ntdk.eq.6  .and.  m.eq.1   .and.                 &
     &                 ( n.ne.1 .and. n.ne.nnp1 ) ) then
                    nlopt2   =  inlop3
                    nropt2   =  inrop3
               endif
!                                  determine if there is a first b.c.
               lbc1    =  .true.
               if ( m.eq.1 .or. m.eq.nmp1 .or. n.eq.1 .or. n.eq.nnp1 )  &
     &              lbc1    = .false.
               if ( .not. lbc1 ) nlopt1 = 0
!                                  determine if there is a second b.c.
               lbc2    =  .true.
               if (  (ntdk.eq.8 .or. ntdk.eq.18) .and. m.gt.1 )         &
     &              lbc2    =  .false.
               if (  (ntdk.eq.10 .or. ntdk.eq.20 ) .and.                &
     &                                       ( m.gt.1 .or. n.gt.1 ) )   &
     &              lbc2    =  .false.
               if ( ntdk.eq.6  .and.  m.eq.nmp1 ) lbc2 = .false.
               if ( .not.lbc2 ) nlopt2 = 0
!
               ica     =  ica + 1
               call ibtrns (ica,cu1)
  915     continue
  920     continue
          nbca(k+1) = ica
!                                  read in nlopt1 = 1 data, if needed
          if ( inlop1.ne.1 ) goto 931
          icx     =  icsv
          do 930 n = 1,ncp
          do 925 m = 1,mcp
               icx     =  icx + 1
               call btrns (icx,cu1)
               if ( nlopt1.eq.0 ) goto 925
               if ( nlopt1.eq.1 ) then
                  read (ntsin,'( a )') qline
                  read (qline,5070,err=9950)dummy,cu1,cl1,(tu1(i),i=1,3)
                  read (ntsin,'( a )') qline
                  read (qline,5070,err=9950)(tl1(i),i=1,3),du1,dl1
               endif
               nct1     =  dummy
               call ibtrns (icx,cu1)
  925     continue
  930     continue
!                                  read in nropt1 = 1,7,8 data, if neede
  931     continue
          nr1a = iabs(inrop1)
          if ( nr1a.ne.1 .and. nr1a.ne.7 .and. nr1a.ne.8 )              &
     &         goto 941
          icx     =  icsv
          do 940 n = 1,ncp
          do 935 m = 1,mcp
               icx     =  icx + 1
               call btrns (icx,cu1)
               if ( nlopt1.eq.0 ) goto 935
               nr1a = iabs(nropt1)
               if ( nr1a.eq.1 .or. nr1a.eq.7 .or. nr1a.eq.8 ) then
                  read (ntsin,'( a )') qline
                  read (qline,5070,err=9950) bet1
               endif
               call ibtrns (icx,cu1)
  935     continue
  940     continue
!                                  read in nlopt2 = 1 data, if needed
  941     continue
          if ( inlop2.ne.1 .and. inlop3.ne.1 ) goto 951
          icx     =  icsv
          do 950 n = 1,ncp
          do 945 m = 1,mcp
               icx     =  icx + 1
               call btrns (icx,cu1)
               if ( nlopt2.eq.0 ) goto 945
               if ( nlopt2.eq.1 ) then
                  read (ntsin,'( a )') qline
                  read (qline,5070,err=9950)dummy,cu2,cl2,(tu2(i),i=1,3)
                  read (ntsin,'( a )') qline
                  read (qline,5070,err=9950)(tl2(i),i=1,3),du2,dl2
               endif
               nct2     =  dummy
               call ibtrns (icx,cu1)
  945     continue
  950     continue
!                                  read in nropt2 = 1,7,8 data, if neede
  951     continue
          nr2a  =  iabs( inrop2 )
          nr3a  =  iabs( inrop3 )
          if ( nr2a.ne.1 .and. nr2a.ne.7 .and. nr2a.ne.8 .and.          &
     &         nr3a.ne.1 .and. nr3a.ne.7 .and. nr3a.ne.8 )              &
     &         goto 961
          icx     =  icsv
          do 960 n = 1,ncp
          do 955 m = 1,mcp
               icx     =  icx + 1
               call btrns (icx,cu1)
               if ( nlopt2.eq.0 ) goto 955
               nr2a = iabs(nropt2)
               if ( nr2a.eq.1 .or. nr2a.eq.7 .or. nr2a.eq.8 ) then
                  read (ntsin,'( a )') qline
                  read (qline,5070,err=9950) bet2
               endif
               call ibtrns (icx,cu1)
  955     continue
  960     continue
!
  961 continue
  980 continue
      go to 1010
!
!     call inbcn
!
 1001 continue
      call inbc1(ica,k)
      go to 1010
 1002 continue
      call inbc2(ica,k)
 1010 continue
      return
!
!     formats
!
 5070 format(6f10.5)
!
!                             error exit
!
!
!             program exits if invalid value for kt is input
!
 6000 continue
      write(ntsout,7000)kt
 7000 format(//,5x,15hkt cannot equal,i10)
      go to 9000
 7015 format(//5x,'--- error exit from processing data under ',a        &
     &    ,' ---' )
 6020 write(ntsout,7020)  icard(1:4)
 7020 format(//5x,55h--- number of networks ($net) must be specified bef&
     &ore ,a,4h ---)
      go to 9000
 6030 write (ntsout,7030)
 7030 format (//5x,'--- mach number less than or equal to 1 ',          &
     &             'for superinclined networks ---')
      go to 9000
 6060 write(ntsout,7060)  kn
 7060 format(//5x,23h--- input network no. (,i3,67h) is greater than the&
     & total number of networks given under $net ---)
      write(ntsout,7015)  icard(1:4)
      go to 9000
 9000 continue
      write(ntsout,9020)
 9020 format(//,5x,30hthis stop occurred in inbc   ,//)
      stop
 8100 format ('   network index',i4,'  source type',i3,'  doublet type' &
     &       ,i3,'  rows',i3,'  cols',i3,'  c.p. row count',i4          &
     &       ,'  c.p. col count',i4)
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'inbc', 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 ('inbc',' program failure due to ill-formatted data')
      return
!
      END subroutine inbc
! **deck inbc1
      subroutine inbc1(ica,k)
      implicit double precision (a-h,o-z)
!
!
!
!call inp2
      common /inp2/ cpnrml,ntsk,ntdk,ipotk,nlpt1,nrpt1,nlpt2,nrpt2,ktk
!end  inp2
!call inp5
      common /inp5/ kn,ipter,amnsw,dnsmsh                               &
     &         , nedflk
!end  inp5
!call curpan
      common/curpan/cpnorm(150)
!end  curpan
!call kutflg
!                                                            /kutflg/
      common /kutflg/ kutta(150), kttype(150)
!end  kutflg
!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 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 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 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 vicovr
!         override vic specifications                       /vicovr/
      common /vicovr/ nedflt(mxnett)
!                                                           /vicovr/
!end  vicovr
!
!
      do 300 kk=1,kn
      k=k+1
      if( ( ntsk .eq. 1) .and.                                          &
     &    ( ntdk .eq.12) .and.                                          &
     &    (ipotk .eq. 2) .and.                                          &
     &     (nlpt1 .eq. 5) .and.                                         &
     &    (iabs(nrpt1).eq.3)  .and.                                     &
     &    (nlpt2 .eq. 7) .and.                                          &
     &    ( iabs(nrpt2).eq.2 )        ) icomtd(k) = 1
      cpnorm(k)=cpnrml
      nts(k)=ntsk
      ntd(k)=ntdk
      ipot(k)=ipotk
      kttype(k)=ktk
      nedflt(k) = nedflk
      call meshp(k,ipter,amnsw,dnsmsh)
      nmp1=nm(k)+1
      nnp1=nn(k)+1
      do 200 n=1,nnp1
      do 100 m=1,nmp1
      ica=ica+1
      nlopt1=nlpt1
      nropt1=nrpt1
      nlopt2=nlpt2
      nropt2=nrpt2
      if(n.eq.1.or.n.eq.nnp1.or.m.eq.1.or.m.eq.nmp1)nlopt1=0
      call ibtrns(ica,cu1)
      nbca(k+1) = ica
  100 continue
  200 continue
  300 continue
      return
      END subroutine inbc1
! **deck inbc2
      subroutine inbc2(ica,k)
      implicit double precision (a-h,o-z)
!
!
!
      character*90 qline
!call inp2
      common /inp2/ cpnrml,ntsk,ntdk,ipotk,nlpt1,nrpt1,nlpt2,nrpt2,ktk
!end  inp2
!call inp5
      common /inp5/ kn,ipter,amnsw,dnsmsh                               &
     &         , nedflk
!end  inp5
!call curpan
      common/curpan/cpnorm(150)
!end  curpan
!call kutflg
!                                                            /kutflg/
      common /kutflg/ kutta(150), kttype(150)
!end  kutflg
!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 inp3
      common /inp3/ ntsin,ntsout
!end  inp3
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!call inp4
      common /inp4/ dum(6),adm(20)
!end  inp4
!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
!
!
!
      do 300 kk=1,kn
      k=k+1
      cpnorm(k)=cpnrml
      nts(k)=ntsk
      ntd(k)=ntdk
      ipot(k)=ipotk
      kttype(k)=ktk
      call meshp(k,ipter,amnsw,dnsmsh)
      nmp1=nm(k)+1
      nnp1=nn(k)+1
      nmm1=nm(k)-1
      nnm1=nn(k)-1
      do 200 n=1,nnp1
      do 100 m=1,nmp1
      ica=ica+1
      nlopt1=nlpt1
      nropt1=nrpt1
      nlopt2=nlpt2
      nropt2=nrpt2
      if(n.eq.1.or.n.eq.nnp1.or.m.eq.1.or.m.eq.nmp1)go to 96
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) bet1
      go to 97
   96 continue
      nlopt1=0
   97 continue
      call ibtrns(ica,cu1)
      nbca(k+1) = ica
  100 continue
  200 continue
  300 continue
      return
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'inbc2', 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 ('inbc2',' program failure due to ill-formatted data')
      return
!
!
!     formats
!
 5070 format(6f10.5)
      END subroutine inbc2
! **deck incmpr
      subroutine incmpr(i1,i2,i3,n1,n2)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  redefine range of second index map to include range of first *
!     *  index map. construct third index map from domain of first map*
!     *  to domain of second map identifying elements mapped to the   *
!     *  same point in the common range.                              *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  identify every element in domain of i1 which is mapped by i1 *
!     *  into a point also in the range of i2, i.e. find each index   *
!     *  k in the domain of i1 such that there exists an index l in   *
!     *  the domain of i2 for which i1(k)=i2(l). tag the point in     *
!     *  the range of i2 by changing the sign of i2 and construct a   *
!     *  map i3 such that i3(k)=0 if no such l exists and i3(k)=l     *
!     *  otherwise.                                                   *
!     *  for indices k in the domain of i1 such that i1(k) is not in  *
!     *  the range of i2 find an index l in the domain of i2 so that  *
!     *  i2(l) can be redefined to be equal to i1(k). tag the fact    *
!     *  that i2(l) has been changed by setting i3(k)=-l.             *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   i1        argument  input     first index map               *
!     *                                                               *
!     *   i2        argument  in/output second index map              *
!     *                                                               *
!     *   i3        argument  output    third index map               *
!     *                                 i3(k)= + if i1(k) was already *
!     *                                          in range of i2       *
!     *                                 i3(k)= - if i1(k) was not     *
!     *                                          originally in range  *
!     *                                          of i2 and hence      *
!     *                                          i2(iabs(i3(k))) has  *
!     *                                          been changed to i1(k)*
!     *                                                               *
!     *   n1        argument  input     size of domain of first map   *
!     *                                                               *
!     *   n2        argument  input     size of domain of second map  *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension i1(n1),i2(n2),i3(n1)
!c
!     *  identify every element in domain of i1 which is mapped by i1 *
!     *  into a point also in the range of i2, i.e. find each index   *
!     *  k in the domain of i1 such that there exists an index l in   *
!     *  the domain of i2 for which i1(k)=i2(l). tag the point in     *
!     *  the range of i2 by changing the sign of i2 and construct a   *
!     *  map i3 such that i3(k)=0 if no such l exists and i3(k)=l     *
!     *  otherwise.                                                   *
!
      do 200 k=1,n1
      i3(k)=0
      do 100 l=1,n2
      if(i1(k).ne.i2(l)) go to 100
      i3(k)=l
      i2(l)=-i2(l)
      go to 200
  100 continue
  200 continue
!c
!     *  for indices k in the domain of i1 such that i1(k) is not in  *
!     *  the range of i2 find an index l in the domain of i2 so that  *
!     *  i2(l) can be redefined to be equal to i1(k). tag the fact    *
!     *  that i2(l) has been changed by setting i3(k)=-l.             *
!
      k=0
      do 500 l=1,n2
      if(i2(l).lt.0) go to 500
  300 k=k+1
      if(k.gt.n1) go to 500
      if(i3(k).gt.0) go to 300
      i3(k)=-l
  500 i2(l)=iabs(i2(l))
      return
      END subroutine incmpr
! **deck indadd
      subroutine indadd (ne,nind,ind,dv  ,nncp,phic  ,nnvcp,vic)
      implicit double precision (a-h,o-z)
!
!     accumulate the potential (and possibly velocity) influences
!     into the phic (and possibly vic) buffer.  note that ne = 1 or 4.
!
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!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
      dimension ind(nind), dv(ne,nind)
      dimension phic(nncp,*), vic(3,nnvcp,*)
!                                    accumulate potential influences
      if ( ne.lt.1 ) return
      do 100 j = 1,nind
         phic(1,ind(j)) = phic(1,ind(j)) + dv(1,j)
  100 continue
      if ( jcn.eq.ipraic ) then
         call outvci ('ind',nind,ind)
         call outmtx ('dv',ityprc*ne,ityprc*ne,nind,dv)
         call outmtx ('phic',ityprc*nncp,ityprc,nsngt,phic)
      endif
      if ( ne.le.1 ) goto 950
!                                    accumulate velocity influences
                 do 200 j=1,nind
         vic(1,1,ind(j)) = vic(1,1,ind(j)) + dv(2,j)
         vic(2,1,ind(j)) = vic(2,1,ind(j)) + dv(3,j)
         vic(3,1,ind(j)) = vic(3,1,ind(j)) + dv(4,j)
  200            continue
      if ( jcn.eq.ipraic ) call outmtx ('vic',6*nnvcp,6,nsngt,vic)
!
  950 continue
      return
      END subroutine indadd
! **deck indrag
      subroutine indrag (nw,title,fsymm,sref,ar,npn,  cl,cdi,eff        &
     &                  ,ylef,yrit, zlef,zrit, dylef,dyrit, dzlef,dzrit &
     &                  ,psi,dcd,    xil,xir                            &
     &                  )
      implicit double precision (a-h,o-z)
      character*(*) title
      dimension npn(nw)
      dimension ylef(nw,200),zlef(nw,200),dylef(nw,200),dzlef(nw,200)
      dimension yrit(nw,200),zrit(nw,200),dyrit(nw,200),dzrit(nw,200)
      dimension  psi(nw,201), dcd(nw,200),  xil(nw,200),  xir(nw,200)
!
!     induced drag from a502 output, specifications per gunter brune
!     and paul bogataj, 18 Dec 1990.
!
!     title    i   ch   title string for printout
!     fsymm    i   r*8  symmetry indicator
!     sref     i   r*8  surface area reference
!     ar       i   r*8  aspect ratio
!     nw       i   i*4  wake network count
!     npn      i   i*4  number of panels on T.E. of each wake nw
!     ylef     i   r*8  y start for each panel
!     yrit     i   r*8  y final for each panel
!     zlef     i   r*8  z start for each panel
!     zrit     i   r*8  z final for each panel
!     dylef    i   r*8  mu/y start for each panel
!     dyrit    i   r*8  mu/y final for each panel
!     dzlef    i   r*8  mu/z start for each panel
!     dzrit    i   r*8  mu/z final for each panel
!     psi      s   r*8  stream function array
!     dcd      s   r*8  induced drag values
!     xil      s   r*8
!     xir      s   r*8
!
      common /pan1/ yl,yr,zl,zr,ycp,zcp
      common /pan2/ xiil,xiir,psip
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!
!
      pi = 4.d0*atan(1.d0)
!
      xnw     =  nw
!
!     vorticity at corner points
!
      do 120 j = 1,nw
         np  = npn(j)
         do 130 k = 1,np
            dely = yrit(j,k) - ylef(j,k)
            delz = zrit(j,k) - zlef(j,k)
            c    = sqrt (dely**2 + delz**2)
            xny  = -delz/c
            xnz  =  dely/c
            xil(j,k) =  dylef(j,k)*xnz - dzlef(j,k)*xny
            xir(j,k) =  dyrit(j,k)*xnz - dzrit(j,k)*xny
  130     continue
  120 continue
!
!     streamfunction at panel corner points
!
      do 140 j = 1,nw
         np  = npn(j)
         npt = np + 1
         do 150 k = 1,npt
            psi(j,k) = 0.d0
            if (k.ne.npt) then
               ycp  = ylef(j,k)
               zcp  = zlef(j,k)
            else
               ycp  = yrit(j,k-1)
               zcp  = zrit(j,k-1)
            endif
!
            do 160 l = 1,nw
               np = npn(l)
               do 170 m = 1,np
                  yl   = ylef(l,m)
                  yr   = yrit(l,m)
                  zl   = zlef(l,m)
                  zr   = zrit(l,m)
                  xiil = xil(l,m)
                  xiir = xir(l,m)
                  call strmfn
                  psi(j,k) = psi(j,k) + psip
!
!                 streamfunction due to image of symmetric configuration
!
                  if (fsymm.eq.1.d0) then
                     ycp = -ycp
                     call strmfn
                     ycp = -ycp
                     psi(j,k) = psi(j,k) - psip
                  end if
!
  170          continue
  160       continue
  150    continue
  140 continue
!
!     lift and induced drag
!
      cl  = 0.d0
      cdi = 0.d0
      facsym = 1.d0
      if ( fsymm.eq.1.d0 ) facsym = 2.d0
      do 180 j = 1,nw
         np = npn(j)
         do 190 k = 1,np
            dely     = yrit(j,k) - ylef(j,k)
            delz     = zrit(j,k) - zlef(j,k)
            a        = xil(j,k)
            c        = sqrt (dely**2 + delz**2)
            b        = (xir(j,k)-a)/c
            e        = psi(j,k)
            d        = (psi(j,k+1)-e)/c
            dcd(j,k) = a*e*c + 0.5d0*(a*d+b*e)*c**2 + (b*d*c**3)/3.d0
            dcd(j,k) = facsym*dcd(j,k)/sref
            cdi      = cdi + dcd(j,k)
            ac       = ylef(j,k)
            bc       = dely/c
            cl       = cl +a*ac*c +(a*bc+ac*b)*c*c/2.d0 +b*bc*c*c*c/3.d0
  190    continue
  180 continue
      cl    = 2.d0*facsym*cl/sref
!                                  give drag figures for principle image
!                                  if anti-symmetry flags are set
      fclcd   =  1.d0
      if ( misym.lt.0 ) fclcd = .5d0
      if ( mjsym.lt.0 ) fclcd = .5d0*fclcd
      cl      =  cl *fclcd
      cdi     =  cdi*fclcd
      eff   = 1000.
      if ( cdi.ne. 0.d0 ) eff   = cl*cl/(pi*ar*cdi)
!
      write (6,10) title
      write (6,19)
      write (6,20) fsymm,sref,ar,xnw
      do 400 j = 1,nw
         write (6,29)
         xnpn    =  npn(j)
         write (6,30) xnpn
         np = npn(j)
         write (6,39)
         do 410 k = 1,np
            write (6,40) ylef(j,k),zlef(j,k),dylef(j,k),dzlef(j,k)
            write (6,40) yrit(j,k),zrit(j,k),dyrit(j,k),dzrit(j,k)
  410    continue
  400 continue
!
      write (6,49)
      write (6,50) cl,cdi,eff
!
      do 420 j = 1,nw
         np = npn(j)
         write (6,59)
         do 430 k = 1,np
            write(6,40) ylef(j,k),zlef(j,k),xil(j,k),psi(j,k)
            write(6,60) yrit(j,k),zrit(j,k),xir(j,k),psi(j,k+1),dcd(j,k)
  430    continue
  420 continue
!
   10 format (1x, a )
   19 format (/,4x,'fsymm',7x,'sref',6x,'ar',8x,'nw')
   20 format (1x,4f10.5)
   21 format (20x,2f10.5,30x,2f10.5)
   29 format (/,5x,'np')
   30 format (1x,f10.5)
   39 format (/,6x,'y',16x,'z',14x,'dmdy',11x,'dmdz')
   40 format (1x, e13.6,3x,e13.6,3x,e13.6,3x,e13.6 )
   49 format (/,6x,'cl',14x,'cdi',13x,'eff')
   50 format (1x,e13.6,3x,e13.6,3x,e13.6,/)
   59 format (6x,'yl',14x,'zl',13x,'xil',14x,'psil',/                   &
     &        6x,'yr',14x,'zr',13x,'xir',14x,'psir',12x,'delcdi')
   60 format (1x, e13.6,3x,e13.6,3x,e13.6,3x,e13.6,3x,e13.6)
      END subroutine indrag
! **deck inecho
      subroutine inecho
      implicit double precision (a-h,o-z)
      character*90 qline
!call inp1
!                                                            /inp1/
      character*80 icard
      common /inp1/ icard
!end  inp1
!call inp3
      common /inp3/ ntsin,ntsout
!end  inp3
      character*80  title1,title2
      character*10 aline, lineno
      parameter (mxlrep=200)
      character*80 linrep(mxlrep)
      character*80 buf
      character*8 idate
      character*4 endch, endup, endlo
      character*4 titch, titup, titlo
      character*4 icard4
!call vercom
!                                                           /vercom/
      common /vercom/ versn
      character*45 versn
!end  vercom
!
      title1 = 'a502'
      title2 = 'program'
!               123456789012345678901234567890123456789012345
!
      endch  =  '$end'
      call cnv2lu (4,endch,  endlo,endup)
      titch  =  '$tit'
      call cnv2lu (4,titch,  titlo,titup)
!
    7 continue
      read (ntsin,'( a )',end=9) qline
      read(qline,5030,err=9950) icard
      icard4  =  icard(1:4)
      if (        icard4.eq.endlo .or. icard4.eq.endup  ) goto 9
      if ( .not. (icard4.eq.titlo .or. icard4.eq.titup) ) goto 7
      read (ntsin,'( a )',end=9) qline
      read(qline,'(a80)',err=9950) title1
      read (ntsin,'( a )',end=9) qline
      read(qline,'(a80)',err=9950) title2
    9 continue
!
      write(6,1)
    1 format(1h1)
!
      call date (idate)
      write (6,3) versn, idate, title1, title2
    3 format (                                                          &
     & //,1x,77(1h*)                                                    &
     & ,/,1x,1h*,75x,1h*                                                &
     & ,/,1x,1h*,21x,'a502 - pan-air technology program ',20x,1h*       &
     & ,/,1x,1h*,75x,1h*                                                &
     & ,/,1x,1h*,15x,'potential flow about arbitrary configurations'    &
     & ,15x,1h*                                                         &
     & ,/,1x,1h*,15x, a45                                               &
     & ,15x,1h*                                                         &
     & ,/,1x,1h*,75x,1h*                                                &
     & ,/,1x,1h*,35x,a8,32x,1h*                                         &
     & ,/,1x,1h*,10x                                                    & ! Added by Martin Hegedus, 4/21/09
     & ,'modified by Martin C. Hegedus for ground plane, 4/21/09'       & ! Added by Martin Hegedus, 4/21/09
     & ,10x,1h*                                                         & ! Added by Martin Hegedus, 4/21/09
     & ,/,1x,1h*,75x,1h*  ,/,1x,1h*,75x,1h*                             &
     & ,/,1x,1h*,1x,a80                                                 &
     & ,/,1x,1h*,1x,a80                                                 &
     & ,/,1x,1h*,75x,1h*  ,/,1x,1h*,75x,1h*  ,/,1x,1h*,75x,1h*          &
     & ,/,1x,77(1h*)  )
      rewind ntsin
      call pcnews
!
!
!     set integer constants
!
      ncard=0
!             print title and data cards
!
      write(ntsout,5005)
 5005 format(1h1)
      call bmark('input-da')
      write (ntsout,5010)
!
!
!
   10 continue
      read (ntsin,'( a )',end=6001) qline
      read (qline,5030,err=9950) icard
      ncard=ncard+1
      write(ntsout,5040)ncard,icard
      icard4  =  icard(1:4)
      if ( icard4.eq.endlo .or. icard4.eq.endup ) goto 40
      go to 10
!
!                                  Now read data, stripping out comment
!                                  lines, removing comment information
!                                  and rewriting to unit 22 with line
!                                  numbers included
!
   40 continue
      ncard  =  0
      rewind ntsin
      ntsinx  =  22
      rewind ntsinx
! ***           write (6,5061)
 5061 format ('1   ***** input with comments squeezed out *****')
  100 continue
      read (ntsin,'( a )',end=200) qline
      ncard  =  ncard + 1
      read (qline,5060,err=9950) buf
      jmax   =  0
      do 120 j = 1,80
          if ( buf(j:j).eq.'!'  .or.  buf(j:j).eq.'=' ) goto 121
          jmax  =  j
  120 continue
  121 continue
      if ( jmax.le.0 ) go to 100
      if ( buf(1:1) .ne. '#' )goto 180
!                                  repeat card encountered. process it
      do 130 j = 2,jmax
          j1  =  j
          if ( buf(j:j) .ne. ' ' ) goto 131
  130 continue
      call a502er ('inecho','error in repeat count command')
      goto 100
!
  131 continue
!                                  look for separator after data start
      j2  =  j1
      do 135 j = j1,jmax
          if ( buf(j:j).eq. ' '  .or. buf(j:j).eq. ',' ) goto 136
          j2   =  j
  135 continue
  136 continue
!                                  look for data after separator
      do 140 j = j2+2,jmax
          j3   =  j
          if ( buf(j:j).ne. ' ' ) goto 141
  140 continue
      j3  = jmax
      j4  = jmax-1
      goto 151
!                                  look for separator after data start
  141 continue
      j4  =  j3
      do 145 j = j3,jmax
          if ( buf(j:j) .eq. ' ' ) goto 146
          j4  =  j
  145 continue
  146 continue
!                                  m = (j1 .. j2), n = (j3 .. j4)
  151 continue
      aline  =  '          '
      do 155 j = j1,j2
          k  =  10 + j - j2
          aline(k:k) = buf(j:j)
  155 continue
      read (aline,6101,err=9950) xrep
      mrep    =  xrep
!
      nrep   =  1
      if ( j3.gt.j4 ) goto 161
!
      aline  =  '          '
      do 160 j = j3,j4
          k  =  10 + j - j4
          aline(k:k) = buf(j:j)
  160 continue
      read (aline,6101,err=9950) xrep
      nrep    =  xrep
  161 continue
!
      if ( nrep.gt.mxlrep ) call a502er ('inecho'                       &
     & ,'no. of repeat lines exceeds limit of 200')
      ncardb = ncard
      do 165 ii = 1,nrep
          read (ntsin,'( a )',end=200) qline
          ncard  =  ncard + 1
          read (qline,6102,err=9950) linrep(ii)
          call comfix (linrep(ii))
  165 continue
      do 175 kk = 1,mrep
          do 170 ii = 1,nrep
               ncardx  =  ncardb + ii
               write (ntsinx,5070) linrep(ii),ncardx
  170     continue
  175 continue
!
!
      goto 100
 6101 format (f10.0)
 6102 format (a80)
 6103 format (10x,'12345678901234567890', '  repeat processing, m=('    &
     & ,i2,',',i2,'),  n=(',i2,',',i2,')  '                             &
     & ,/,    10x,80a1)
 6104 format (' the following',i3,' lines will be repeated',i4,' times')
 6105 format (10x,a80)
!
!                                  ordinary input line
  180 continue
      write (ntsinx,5070) buf, ncard
! ***           write (6,5062) (buf(j),j=1,jmax)
      go to 100
!
!
  200 continue
      rewind ntsinx
      ntsin   =  ntsinx
!
!
!      formats
!
 5010 format(//////24x,'- list of a502 input data cards -')
 5020 format(//5x,3hno.,4x,'card images'//)
 5030 format (a)
 5040 format (1x,i5,1x,a)
 5050 format (1h1)
 5060 format(a)
 5070 format (a80,i10)
!
!
!
      return
!                  program exit due end of file.
!
 6001 continue
      write(ntsout,7001)
 7001 format(//,5x,19h---no more input---,//)
      stop
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'inecho', qline(1:80),ncard                        &
     &               , ((lll,lll=1,10),kkk=1,8)
 9960 format (' read error occurred in subroutine ',a                   &
     &  ,/,' INPUT LINE:',a80,i10                                       &
     &  ,/,'    columns:',80i1,4x,'line # (see list of a502 input)' )
      call a502er('inecho',' program failure due to ill-formatted data')
      return
!
!
!                             error exit
!
      END subroutine inecho
! **deck influ
      subroutine influ (z,iflu)
      implicit double precision (a-h,o-z)
      dimension z(3)
!
!     *  to calculate the degree to which a panel influences a field  *
!     *  point                                                        *
!
!     *                                                               *
!     *   iflu      argument  output    influence indicator           *
!     *                                 =0   no influence             *
!     *                                 =1   monopole far field       *
!     *                                 =2   dipole  far field        *
!     *                                 =3   quadrupole far field     *
!     *                                 =4   one sub-panel inter-     *
!     *                                      mediate field            *
!     *                                 =5   two sub-panel inter-     *
!     *                                      mediate field            *
!     *                                 =6   eight sub-panel near     *
!     *                                      field                    *
!
!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 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 pc(3), pct(3), zp(3,4), dcp(3)
!call freqdt
!                                                  /freqdt/
      common /freqdt/ omgbar, omegb, omg, omgabs
!---- complex*16 omgbar, omegb, omg
!end  freqdt
      data delt1,delt2,delt3,delt4,delt5 /.042D0,.125D0,.2D0,.4D0,.75D0/
      data dph1,dph2,dph4 /.174D0,.572D0,1.1D0/
!c
!     *  calculate strength of influence of panel at field point      *
!
      iflu=6
      call vadd(z,-1.D0,cp(1,9),pc,3)
      call compip(pc,pc,compd,betams,pcm)
      if(pcm.le.0.D0) go to 900
      pcm=1.D0/sqrt(pcm)
      call mxm (pc,3,betams,1,pct,1)
      call cmpscl (1.D0/betams,compd,pct,pct)
      call compip(pc,pc,compd,abetms,pcn)
      eps=.5D0*diam*pcm*pcm*sqrt(pcn)
      if(eps.lt.delt5) iflu=5
      if(eps.lt.delt4) iflu=4
      if(eps.lt.delt3) iflu=3
      if(eps.lt.delt2) iflu=2
      if(eps.lt.delt1) iflu=1
!
  900 continue
      if ( iflu.eq.0 ) go to 1000
      dphase  =  abs(omg)*diam
      if ( dphase.lt.dph1 ) go to 1000
      iflu    =  max (2,iflu)
      if ( dphase.lt.dph2 ) go to 1000
      iflu    =  max (3,iflu)
      if ( dphase.lt.dph4 ) go to 1000
      iflu    =  max (4,iflu)
 1000 return
      END subroutine influ
! **deck inicor
      subroutine inicor (nwdyn,wdyn, prtlev,prtlws,prtsum)
      double precision wdyn(nwdyn)
      logical prtlev, prtlws, prtsum
!         initialize the dynamic memory management routines to allocate
!         memory from the array  wdyn(1:nwdyn) .   other parameters are
!
!              prtlev    a print flag indicating that summaries should
!                        be generated for each pair of calls to setcor
!                        and frecor
!
!              prtlws    a print flag indicating that the allocation of
!                        each array should be described
!
!              nlev      the user specified maximum number of levels of
!                        calls to  setcor/frecor .
!
!              nlws      the maximum number of dynamic arrays needed
!
!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
!                                         get the ratio of real/int
      nrl     =  locfcn(intlth) - locfcn(realth)
      nin     =  locfcn(nrl2in) - locfcn(intlth)
      nrl2in  =  nrl/nin
      write (7,'( ''  real length, integer length, ratio: '',3i4)')     &
     &    nrl,nin,nrl2in
      if ( nrl2in.ne.1 .and. nrl2in.ne.2 ) then
         call remarx('inicor: real to integer ratio is bad')
         call abtcor
      endif
!
      levdyn  =  1
      lwsdyn  =  0
!
      levprt  =  prtlev
      lwsprt  =  prtlws
      sumprt  =  prtsum
!
      maxdyn  =  nwdyn
      maxlev  =  nlev
      maxlws  =  nlws
!
      mxxdyn  =  0
      mxxlws  =  0
      mxxlev  =  1
      incrdf  =  100000
      npadio  =   50000
!
! ----      llmplv  =  locfcn(wdyn)
! ----      llmlws  =  llmplv + 4*nlev
! ----      llwstg  =  llmlws + 4*nlws
      llmplv  =  0
      llmlws  =  0
!                                   allocate from the beginning
      llwstg  =  1
!
      chrlev(levdyn)  =  ' '
      maplev(1,levdyn)  =  llwstg
      maplev(2,levdyn)  =  0
      maplev(3,levdyn)  =  0
!
      iniset  =  'goodcore'
      if ( .not. sumprt ) go to 950
      write (6,6000) maxlev, maxlws, maxdyn, nwdyn                      &
     &             , llmplv, llmlws, llwstg
 6000 format (//,1x,100(1h*),//                                         &
     &  ,'   dynamic memory management initialization  '                &
     &,//,'   max no. levels ',i10,'   max no. arrays ',i10,'   maximum &
     &scratch storage ',i10,'   total storage provided',i8              &
     &,/ ,'     addr(maplev) ',i10,'     addr(maplws) ',i10,'     addr(s&
     &cratch storage) ',i10                                             &
     &,//,1x,100(1h*)   )
!
  950 continue
      return
      END subroutine inicor
! **deck inputa
      subroutine inputa
!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
!*** created on 79.xxx
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     * to input required data for panair pilot code
!     *       . set up network mesh points and boundary conditions
!     *         by using various preprocessors
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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/  output    compressibility direction     *
!     *                                 angle of attack               *
!     *                                                               *
!     *   alpha     /acase/   output    angles of attack              *
!     *                                                               *
!     *   amach     /acase/   output    freestream mach number        *
!     *                                                               *
!     *   beta      /acase/   output    angles of sideslip            *
!     *                                                               *
!     *   betc      /comprs/  output    compressibility direction     *
!     *                                 angle of sideslip             *
!     *                                                               *
!     *   bet1      /bcon/    output    first boundary condition      *
!     *                                 (multiple) right hand side    *
!     *                                 values                        *
!     *                                                               *
!     *   bet2      /bcon/    output    second boundary condition     *
!     *                                 (multiple) right hand side    *
!     *                                 values                        *
!     *   bref      /fmcof/   output    reference length for          *
!     *                                 moment about x axis           *
!     *                                                               *
!     *   cl1       /bcon/    output    first boundary conidition     *
!     *                                 coefficient of lower surface  *
!     *                                 perturbation normal mass flux *
!     *                                                               *
!     *   cl2       /bcon/    output    second boundary condition     *
!     *                                 coefficient of lower surface  *
!     *                                 perturbation normal mass flux *
!     *                                                               *
!     *   cref      /fmcof/   output    reference length for          *
!     *                                 moment about y axis           *
!     *                                                               *
!     *   cutdat    /secprp/  output    data about the cut within     *
!     *                                 a group                       *
!     *                                                               *
!     *   cu1       /bcon/    output    first boundary condition      *
!     *                                 coefficient of upper surface  *
!     *                                 perturbation normal mass flux *
!     *                                                               *
!     *   cu2       /bcon/    output    second boundary condition     *
!     *                                 coefficient of upper surface  *
!     *                                 perturbation normal mass flux *
!     *                                                               *
!     *   dl1       /bcon/    output    first boundary condition      *
!     *                                 coefficient of lower surface  *
!     *                                 perturbation potential        *
!     *                                                               *
!     *   dl2       /bcon/    output    second boundary condition     *
!     *                                 coefficient of lower surface  *
!     *                                 perturbation potential        *
!     *                                                               *
!     *   dref      /fmcof/   output    reference length for          *
!     *                                 moment about z axis           *
!     *                                                               *
!     *   dummy     /skrch1/  -local-   available scratch space for   *
!     *                                 preprocessing                 *
!     *                                                               *
!     *   du1       /bcon/    output    first boundary condition      *
!     *                                 coefficient of upper surface  *
!     *                                 perturbation potential        *
!     *                                                               *
!     *   du2       /bcon/    output    second boundary condition     *
!     *                                 coefficient of upper surface  *
!     *                                 perturbation potential        *
!     *                                                               *
!     *   fsvm      /acase/   output    magnitude of freestream       *
!     *                                 velocity                      *
!     *                                                               *
!     *   ibconp    /prnt/    output    boundary condition print flag *
!     *                                 =1 if print desired
!     *                                                               *
!     *   icontp    /prnt/    output    control point diagnostic      *
!     *                                 print flag                    *
!     *                                                               *
!     *   iedgep    /prnt/    output         =1 if edge matching      *
!     *                                      diagnostic printout is   *
!     *                                      desired                  *
!     *                                                               *
!     *   ifact     /factrd/  output    flag for restarting program   *
!     *                                 using factored aic matrix     *
!     *                                                               *
!     *   igeomp    /prnt/    output    geometry print flag =1 if     *
!     *                                 print desired                 *
!     *                                                               *
!     *   igrps     /secprp/  output    group number (often used as an*
!     *                                 index)                        *
!     *                                                               *
!     *   ipot      /index/   output    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              *
!     *                                                               *
!     *   ipraic    /prnt/    output    =0   if no pic diagnostic     *
!     *                                      printout is desired      *
!     *                                 =k   if pic diagnostic print- *
!     *                                      out is desired for kth   *
!     *                                      control point            *
!     *                                                               *
!     *   isingp    /prnt/    output    singularity spline diagnostic *
!     *                                 print flag                    *
!     *                                                               *
!     *   isings    /prnt/    output    singularity print flag        *
!     *                                 =1 if singularity strength    *
!     *                                 on each panel is to be printed*
!     *                                                               *
!     *   nacase    /acase/   output    number of freestream cases    *
!     *                                 for simultaneous solution     *
!     *                                                               *
!     *   nct1      /bcon/    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/    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          *
!     *                                                               *
!     *                                                               *
!     *   ndtchk    /datchk/  output    data check flag               *
!     *                                 =1  data check only desired   *
!     *                                 full solution otherwise       *
!     *                                                               *
!     *   netdat    /secprp/  output    data about the network's part *
!     *                                 in the group                  *
!     *                                                               *
!     *   netwrk    /secprp/  output    network number (an index)     *
!     *                                                               *
      implicit double precision (a-h,o-z)
!     *   nexdgen   /exdign/  output    =1 for extra diagnostic print *
!     *                                                               *
!     *   nlopt1    /bcon/    output    first boundary condition      *
!     *                                 left hand side coefficient    *
!     *                                 option indicator              *
!     *                                                               *
!     *   nlopt2    /bcon/    output    second boundary condition     *
!     *                                 left hand side coefficient    *
!     *                                 option indicator              *
!     *                                                               *
!     *   nm        /index/   output    array containing number of    *
!     *                                 rows in each network corner   *
!     *                                 point grid                    *
!     *                                                               *
!     *   nn        /index/   output    array containing number of    *
!     *                                 columns in each network       *
!     *                                 corner point grid             *
!     *                                                               *
!     *   nnett     /index/   output    number of networks            *
!     *                                                               *
!     *   nprcof    /fmcof/   output    pressure coefficient used for *
!                                       force calculations            *
!     *                                                               *
!     *   nropt1    /bcon/    output    first boundary condition      *
!     *                                 right hand side value         *
!     *                                 option indicator              *
!     *                                                               *
!     *   nropt2    /bcon/    output    second boundary condition     *
!     *                                 right hand side value         *
!     *                                 option indicator              *
!     *                                                               *
!     *   nsymm     /symm/    output         symmetry flag            *
!     *                                      =0  no planes of symmetry*
!     *                                      =1  x-z plane of symmetry*
!     *                                      =2  x-z and x-y plane    *
!     *                                          of symmetry          *
!     *                                                               *
!     *   ntd       /index/   output    array containing network      *
!     *                                 doublet types                 *
!     *                                                               *
!     *   nts       /index/   output    array containing network      *
!     *                                 source types                  *
!     *                                                               *
!     *   numcut    /secprp/  output    number of cuts in the group   *
!     *                                                               *
!     *   numgrp    /secprp/  output    number of groups of data      *
!     *                                                               *
!     *   numnet    /secprp/  output    number of networks in a group *
!     *                                                               *
!     *   numscd              output    number of pressure surface    *
!     *                                 conditions                    *
!     *                                                               *
!     *   pi        /ncons/   input     3.14159 etc.                  *
!     *                                                               *
!     *   pi2       /ncons/   input     2.*pi                         *
!     *                                                               *
!     *   pi4i      /ncons/   input     1./(4.*pi)                    *
!     *                                                               *
!     *   sref      /fmcof/   output    reference area for force      *
!     *                                 and moment calculations       *
!     *                                                               *
!     *   tl1       /bcon/    output    first  boundary condition     *
!     *                                 coefficient vector of lower   *
!     *                                 surface perturbation          *
!     *                                 tangential velocity           *
!     *                                                               *
!     *   tl2       /bcon/    output    second boundary condition     *
!     *                                 coefficient vector of lower   *
!     *                                 surface perturbation          *
!     *                                 tangential velocity           *
!     *                                                               *
!     *   tu1       /bcon/    output    first boundary condition      *
!     *                                 coefficient vector of upper   *
!     *                                 surface perturbation          *
!     *                                 tangential velocity           *
!     *                                                               *
!     *   tu2       /bcon/    output    second boundary condition     *
!     *                                 coefficient vector of upper   *
!     *                                 surface perturbation          *
!     *                                 tangential velocity           *
!     *                                                               *
!     *   xref      /fmcof/   output    global x coordinate of        *
!     *                                 origin for moment calculations*
!     *                                                               *
!     *   yref      /fmcof/   output    global y coordinate of        *
!     *                                 origin for moment calculations*
!     *                                                               *
!     *   zm        /mspnts/  output    coordinates of grid points    *
!     *                                 of all networks in the        *
!     *                                 global coordinate system      *
!     *                                                               *
!     *   zref      /fmcof/   output    global z coordinate of        *
!     *                                 origin for moment calculations*
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!c
!     *  the common blocks which follow must always be part of this   *
!     *  subroutine                                                   *
!
!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 boundl
!                                                           /boundl/
      common /boundl/ itapbl, ivcorr
!end  boundl
!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 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
      integer irhssl(4)
!call fmcof
      common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof
!end  fmcof
!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 epsff
      common /epsff/ eps1, eps2, eps3, eps4, eps5                       &
     &             , phc1, phc2, phc3
!end  epsff
!call ncons
      common /ncons/ pi,pi2,pi4i,twopi,pio2
!end  ncons
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call curpan
      common/curpan/cpnorm(150)
!end  curpan
!call pincl
      common/pincl/enx1,enx2,al1,al2
!end  pincl
!c
!     *  common block /skrch1/ provides space for whatever            *
!     *  preprocessing of grid point or boundary condition data that  *
!     *  may be required                                              *
      common/case/icase,ncase
!call datchk
!                                                            /datchk/
      common/datchk/ndtchk
!end  datchk
!call exdign
!                                                            /exdign/
      common/exdign/nexdgn
!end  exdign
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!call chkpnt
      common /chkpnt/  nckaic, nckusp
!end  chkpnt
!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 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 irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!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 nwprnt
      common /nwprnt/ imnwpr
      logical imnwpr
!end  nwprnt
!call slofbd
!         information about off-body input and streamline input is
!         stored in  /slofbd/.  the array  zof(1:5000)  contains up
!         the coordinates of up to  1666  off-body points.   the
!         array  stmln(7,1:500)  contains the following information
!         about the streamline start points (up to 500 in all):
!              stmln(1,i) = starting x value
!              stmln(2,i) = starting y value
!              stmln(3,i) = starting z value
!              stmln(4,i) = max value of del(x) along the streamline
!              stmln(5,i) = max value of del(y) along the streamline
!              stmln(6,i) = max value of del(z) along the streamline
!              stmln(7,i) = forward/backward indicator. (0 ==> forward,
!                                nonzero ==> backward integration )
      common /slofbd/ zof(5000), stmln(7,500)
!end  slofbd
      character*4 idict(50)
      character*4 updict(100), lodict(100)
!call inp1
!                                                            /inp1/
      character*80 icard
      common /inp1/ icard
!end  inp1
!call inp2
      common /inp2/ cpnrml,ntsk,ntdk,ipotk,nlpt1,nrpt1,nlpt2,nrpt2,ktk
!end  inp2
!call inp5
      common /inp5/ kn,ipter,amnsw,dnsmsh                               &
     &         , nedflk
!end  inp5
!call inp3
      common /inp3/ ntsin,ntsout
!end  inp3
!call inp4
      common /inp4/ dum(6),adm(20)
!end  inp4
      integer abnet1(200),abnet2(200),absid1(200),absid2(200)
!call factrd
!                                                            /factrd/
      common /factrd/ ifact
!end  factrd
!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 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
      character*80 line
!call nwlst
      common /cnwlst/ nwname(mxnett)
      character*10 nwname
      common /anwlst/ nnwlst
!end  nwlst
!call lndblx
!                                                           /lndblx/
      common /lndblx/ genwak(3,mxnett), slndbl(mxnett)                  &
     &              , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett)
!end  lndblx
!call prtnor
!                                                            /prtnor/
      common /prtnor/ nprten
!end  prtnor
!
      parameter (mxpeab=100)
      dimension netpea(4,mxeiab,mxpeab), peatol(mxpeab)                 &
     &        , mthfrc(mxpeab), nedges(mxpeab)
!
!call iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
!call cp2flg
!         /cp2flg/:  newton iteration, lambda print and cp2 print flags
      common /cp2flg/ istcp2, iexcp2, nitcp2
!end  cp2flg
!
!call trfanl
!                                                         /trfanl/
!         ptrffz    logical flag, set by inputa, used in output, indic-
!                   ating whether or not to perform trefftz analysis.
      common /trfanl/ ptrffz
      logical ptrffz
!end  trfanl
      character*4 icard4
      character*90 qline
      character*4 sprech, sprelo, spreup
      character*4 dprech, dprelo, dpreup
      character*4 snetch, snetlo, snetup
      character*4 dnetch, dnetlo, dnetup
      character*4 scutch, scutlo, scutup
      character*4 dcutch, dcutlo, dcutup
      character*10 lowrch, lowrlc, lowruc
      character*10 upprch, upprlc, uppruc
!
      data ndict / 50 /
      data idict /'$tit','$cas','$ang','$sid','$mac'                    &
     &           ,'$dat','$sol','$res'                                  &
     &           ,'$ref','$sym','$net'                                  &
     &           ,'$poi','$qua','$got','$tra','$cam','$cir','$ell'      &
     &           ,'$abu','$rea','$bou','$pri','$swi'                    &
     &           ,'$flo','$xyz','$gri','$str'                           &
     &           ,'$nwl','$vel'                                         &
     &           ,'$eat','$sec','$pea','$for','$ite'                    &
     &           ,'$mat','$nof','$yaw','$tre','$zzz'                    &
     &           ,'$end'                                                &
     &           ,'$zzz','$zzz','$zzz','$zzz','$zzz'                    &
     &           ,'$zzz','$zzz','$zzz','$zzz','$zzz'                    &
     &           /
!
      data sprech /'*pre'/
      data dprech /'$pre'/
      data snetch /'*net'/
      data dnetch /'$net'/
      data scutch /'*cut'/
      data dcutch /'$cut'/
      data lowrch /'lower     '/
      data upprch /'upper     '/
!
!
!
      nch    =  4
      call cnv2lu  (nch,sprech,  sprelo,spreup)
      call cnv2lu  (nch,dprech,  dprelo,dpreup)
      call cnv2lu  (nch,snetch,  snetlo,snetup)
      call cnv2lu  (nch,dnetch,  dnetlo,dnetup)
      call cnv2lu  (nch,scutch,  scutlo,scutup)
      call cnv2lu  (nch,dcutch,  dcutlo,dcutup)
      do 10 ikw = 1,ndict
         call cnv2lu (nch,idict(ikw),  lodict(ikw),updict(ikw))
   10 continue
      nch     =  10
      call cnv2lu (nch,lowrch,  lowrlc,lowruc)
      call cnv2lu (nch,upprch,  upprlc,uppruc)
!
!
!
      ntsin=5
      ntsout=6
      k=0
      nza(1) = 0
      nbca(1) =  0
      ica=0
      iabut = 0
      npeabt= 0
      nnett   =  mxnett
      nnetsv  =  0
      nnwlst  =  0
      kodew = 0
      ifchk = 0
      gmair   =  1.4d0
!
      do 30 i=1,150
!       initialize:
!
!       set all networks to '1' meaning they are included
        iform(i,1) = 1
!
!       set all network types to zero
        icomtd(i) = 0
!
!       set pressure surface to '1' meaning 'upper'
        iform(i,2) = 1
!
   30 continue
      isignl = 0
      icomop = 0
!
!c
!     initialize iduser array
      do 40 ii=1,150
      iduser(ii) = ' '
   40 continue
!
      nprcof=3
      ptrffz  =  .false.
      nsrfls  =  0
!
!     echo input cards
!
      open (22,file='ft22',form='formatted',status='unknown')
      call inecho
!
      write(ntsout,5020)
!
!             read cards
!
   60 continue
      read (ntsin,'( a )') qline
      read(qline,5030,err=9950)   icard
      write(ntsout,5045)icard
   61 continue
      imnwpr  =  .false.
!
!                             compare data to keyword dictionary
!
      do 80 ikw=1,ndict
      igo     =  ikw
      icard4  =  icard(1:4)
      if ( icard4.eq.lodict(igo) .or. icard4.eq.updict(igo) ) goto 90
   80 continue
      go to 6003
!
!     branch out
!
   90 continue
!           tit cas ang sid mac
      go to(104,105,110,120,140                                         &
     &     ,160,170,180                                                 &
     &     ,190,195,200                                                 &
     &     ,210,220,230,250,260,263,266                                 &
     &     ,268,270,280,290,295                                         &
     &     ,410,450,490,500                                             &
     &     ,530,540                                                     &
     &     ,550,600,650,651,660                                         &
     &     ,670,680,120,698,699                                         &
     &     ,700                                                         &
     &     ,699,699,699,699,699                                         &
     &     ,699,699,699,699,699                                         &
     &     ),  igo
!           dat sol res
!           ref sym net
!           poi qua got tra cam cir ell
!           abu rea bou pri swi
!           flo xyz gri str
!           nwl vel
!          eat sec pea for ite
!           mat nof yaw tre zzz
!           end
!           zzz zzz zzz zzz zzz
!           zzz zzz zzz zzz zzz
!
! $tit    read title
!
  104 continue
      read (ntsin,'( a )') qline
      read(qline,5030,err=9950)title1
      read (ntsin,'( a )') qline
      read(qline,5030,err=9950)title2
      go to 60
!
! $cas    read number of cases
!
  105 continue
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dummy
      nacase = dummy
      go to 60
!
! $ang    read angle of attack in degrees
!
  110 continue
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) alpc
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)  (alpha(i),i=1,nacase)
      go to 60
!
! $sid    read in sideslip angles in degrees
! $yaw -  deprecated option (same as sideslip)
!
  120 continue
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) betc
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)  (beta(i),i=1,nacase)
      go to 60
!
! $mac    read mach number
!
  140 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)  amach
      go to 60
  160 continue
!
! $dat   request for data check of network mesh points
!
!
!                          the user may opt to perform datacheck by
!                          selecting this option.
!
!                          ndtchk=1  the program will check abutments,
!                                    boundary conditions, normals etc.
!
!                          ndtchk=2  the program will check only the
!                                    abutments.
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum1, dum2
      ndtchk  =  dum1
      nprten  =  dum2
      if( ndtchk .eq. 1 ) ifchk = 1
!
      go to 60
!
! $sol
!
  170 ndtchk = 0
      go to 60
!
! $restart
!
!
!                       this option allows the user to restart the progr
!                       there are three types of restart
!
!                          1) aic to be read. the singularity parameters
!                             are to be calculated within the program. s
!                             nckaic = 1 and nckusp = 0.
!
!                          2) both aic and the singularty parameters
!                             are to be read in, set
!                             nckaic = 1 and nckusp = 1.
!
!                          3) only the singularity parameters are to be
!                             aic are not to be calculated nor read in,
!                             nckaic = 2 and nckusp = 1.
!
  180 continue
      dum(3)=0.d0
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dum
      nckusp=dum(1)
      nckaic=dum(2)
      ifact=dum(3)
      go to 60
  190 continue
!
!         read data group: ref
!
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950)dum
      xref=dum(1)
      yref=dum(2)
      zref=dum(3)
      nref=dum(4)
      if  ( dum(5).ne.0.d0 ) nprcof = dum(5)
      nprcof  =  max ( 1, min ( 4, nprcof))
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950)dum
      do 191 i=1,4
  191 if(dum(i).le.0.d0)dum(i)=1.d0
      sref=dum(1)
      bref=dum(2)
      cref=dum(3)
      dref=dum(4)
  192 continue
      go to 60
  195 continue
!
! $sym   read symmetry flag
!
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dum
      misym=dum(1)
      mjsym=dum(2)
      nsymm=iabs(mjsym)+iabs(misym)
      nisym   =  min (iabs(misym)+1,2)                                    ! Added by Martin Hegedus, 4/21/09
      njsym   =  min (iabs(mjsym)+1,2)                                    ! Added by Martin Hegedus, 4/21/09
      go to 60
!
! $net    read number of networks
!
  200 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)  dummy
      nnetsv  =  dummy
      if ( nnetsv.le.0 .or.  nnetsv.gt.mxnett ) goto 6010
      goto 60
!
! $poi    input x,y,z coordinates of corner points by row
!
  210 ipter = 1
      kodew = 1
      go to 267
!
! $qua   use quadrilateral preprocessor to generate mesh points
!
  220 ipter = 2
      kodew = 1
      go to 267
!
! $got    gothic, or arrow, or delta wings
!
  230 ipter = 3
      kodew = 1
      go to 267
!
! $tra    trailing wakes
!
  250 if (kodew.eq.0) go to 6100
      ipter = 5
      go to 267
!
! $cam      cambered wings
!
  260 if (kodew.eq.0) go to 6100
      kodew = 0
      ipter = 6
      call meshp(k,ipter,amnsw,dnsmsh)
!                                  if  k.gt.mxnett  or network input has
!                                  signalled as completed by the appeara
!                                  $abu or $pea, abort.
      if ( k.gt.nnett ) goto 6010
      kodew=1
      go to 60
!
! $cir     circular section
!
  263 continue
      kodew=1
      ipter=7
      go to 267
!
! $elliptic sections
!
  266 continue
      kodew=1
      ipter=8
  267 continue
!
!     call b.c. input
!
      call inbc(k,ica)
!                                  if  k.gt.mxnett  or network input has
!                                  signalled as completed by the appeara
!                                  $abu or $pea, abort.
      if ( k.gt.nnett ) goto 6010
      go to 60
!
! $abu - force abutments
!
  268 continue
!
!                    abutment data should be input only after all the
!                    geometry data has been input successfully.
!
!                                  it is assumed that all networks have
!                                  input.  reset  nnett  and process $ab
      nnett   =  k
      do 2681 kk = 1,nnett
          write (nwname(kk),5073) iduser(kk)
          call ljbf10( nwname(kk) )
 5073     format (a)
 2681 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dummy
      nabut=dummy
      iabut=1
      do 269 i=1,nabut
      read (ntsin,'( a )') qline
      read (qline,5072,err=9950) line
 5072 format ( a )
      call dfnabu (nwname,nnett                                         &
     &            ,line,abnet1(i),absid1(i),abnet2(i),absid2(i))
  269 continue
      go to 60
!
! $rea - rearrange a group of networks (rotate and/or translate)
!
  270 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dummy
      nrearr=dummy
      do 279 i=1,nrearr
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dummy
      ntr=dummy
      if(ntr.lt.1.or.ntr.gt.4)go to 6210
      go to (271,272,273,274), ntr
!
!  rot1  rotate about a given line through given angle
!
  271 call rot1
      go to 279
!
!  rot2  rotate about the axes parallel to the coordinate axes
!        with given origin and three angles of rotation
!
  272 call rot2
      go to 279
!
! scale the networks.
!
  273 call oscale
      go to 279
!
! translate the networks
!
  274 call tran
  279 continue
      go to 60
!
! $bou  boundary layer program input file generation.
!
  280 continue
      itapbl=1
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dummy
      ivcorr=dummy
      go to 60
  290 continue
!
! $pri   read print control
!
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dum
      isings = dum(1)
      igeomp = dum(2)
      isingp = dum(3)
      icontp  =  dum(4)
      ibconp = dum(5)
      iedgep = dum(6)
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      ipraic = dum(1)
      nexdgn = dum(2)
      ioutpr  =  dum(3) + 1.d0
      ioutpr  =  max ( 0, min ( 2, ioutpr))
      ifmcpr  =  dum(4) + 1.d0
      ifmcpr  =  max ( 0, min ( 2, ifmcpr))
      icostp  =  dum(5)
      indmap   =  dum(6)
      if ( indmap.ge.1 ) ispmap = 1
      if ( indmap.ge.2 ) icpmap = 1
      if ( indmap.ge.3 ) ibcmap = 1
      if ( indmap.ge.4 ) iextrp = indmap - 3
!
      if ( icontp.ge.1 .or. ibconp.ge.1 ) icpmap = 1
      if ( ibconp.ge.1 ) ibcmap = 1
      if ( icontp.ge.2 .or. ibconp.ge.2 ) ispmap = 1
      if ( isings.ge.3 ) ispmap = 1
!
      go to 60
  295 continue
!
!                        boundary condition switching option
!
!                        initial boundary condition is to be velocity ty
!                         the program will then switch it to mass flux t
!                        if the panel inclination requires so.
!
!
      if(amach.le.1.d0)go to 6030
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dum
      enx1=dum(1)
      enx2=dum(2)
      al1=dum(3)
      al2=dum(4)
      go to 60
!
!      $flo   set nflowv for offbody points.
!
  410 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dum
      nflowv=dum(1)
      tpoff=dum(2)
      go to 60
!
!      $xyz. input user supplied offbody points
!
  450 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950) dummy
      isk1 = dummy
      isk2 = nof*3 + 1
      nof = nof + isk1
      isk3 = isk1 * 3 + isk2 - 1
      do 455 j1 = isk2,isk3,6
         j2      =  min(isk3,j1+5)
         read (ntsin,'( a )') qline
         read(qline,5070,err=9950) (zof(j), j = j1,j2)
  455 continue
      go to 60
!
!      $gri  use subroutine gridgen to generate grids of offbody
!      points
!
  490 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950) dummy
      ngt = dummy
      do 495 j1 = 1, ngt
        read (ntsin,'( a )') qline
        read(qline,5070,err=9950) (adm(i),i=1,6)
        read (ntsin,'( a )') qline
        read(qline,5070,err=9950) (adm(i),i=7,12)
        read (ntsin,'( a )') qline
        read(qline,5070,err=9950) (adm(i),i=13,18)
        if(( adm(16).eq.0.d0 ) .and.                                    &
     &     ( adm(17).eq.0.d0 ) .and.                                    &
     &     ( adm(18).eq.0.d0 )      ) go to 495
        ix = adm(16)
      if(ix.eq.0) ix=1
        iy = adm(17)
      if(iy.eq.0) iy=1
        iz = adm(18)
      if(iz.eq.0) iz=1
        isk2 = nof + ix*iy*iz
      if(isk2 .gt. 1666) go to 6220
      nof3 = 3*nof + 1
        call gridgn (adm(1), adm(2), adm(3), adm(4), adm(5), adm(6),    &
     &    adm(7), adm(8), adm(9), adm(10), adm(11), adm(12), adm(13),   &
     &    adm(14), adm(15), ix, iy, iz, zof(nof3))
        nof = isk2
  495 continue
      go to 60
!
!      $str. streamline input data.
!      set nstmln for streamlines
!
  500 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950) dummy
      nstmln = dummy
!
!        if nstmln = 0 then no streamline computed.
!
      if(nstmln.eq.0) go to 60
!
!         read in global info for streamlines.
!
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) (adm(i),i=1,6)
      iadm = adm(1)
      if(iadm.ne.0) numpts = iadm
      if(numpts.gt.500) numpts = 500
      if(adm(2).ne.0.d0) hmin = adm(2)
      if(adm(3).ne.0.d0) hmax = adm(3)
      iadm = adm(5)
      if(iadm.ne.0) mxordr = iadm
      if(mxordr.gt.6) mxordr = 6
      if(adm(6).ne.0.d0) abserr = adm(6)
      iadm = adm(4)
      if(iadm.ne.0) maxstm = iadm
      if(maxstm.gt.1000) maxstm = 1000
!
      read (ntsin,'( a )') qline
      read (qline,5071,err=9950) (adm(i),i=1,7)
      iadm    =  adm(1)
      if ( iadm.ne.0 ) mxarr1 = iadm
      isprnt  =  adm(2)
      tpsl    =  adm(3)
      irhssl(1) =  adm(4)
      irhssl(2) =  adm(5)
      irhssl(3) =  adm(6)
      irhssl(4) =  adm(7)
      nrhssl    =  0
      call jzero (indvsl,4)
      do 504 i = 1,4
          if ( irhssl(i).le.0  .or.  irhssl(i).gt.nacase ) go to 504
          nrhssl  =  nrhssl + 1
          indvsl(irhssl(i)) = 1
  504 continue
      if ( nrhssl.eq.0 ) indvsl(1) = 1
!
      ncassl   =  0
      call jzero (irhssl,4)
      do 506 i = 1,nacase
          if ( indvsl(i).ne.0 ) ncassl = ncassl + 1
          if ( indvsl(i).ne.0 ) irhssl(ncassl) = i
  506 continue
      call ifera (irhssl,indvsl,4)
      call outvci ('==indvsl',4,indvsl)
      write (6,'(1x,a10,1x,  i12)')                                     &
     & '==ncassl',ncassl
!
!         read in value for each stream line
!
      do 520 i = 1, numpts
        read (ntsin,'( a )') qline
        read(qline,5070,err=9950)(stmln(l,i),l=1,6)
        read (ntsin,'( a )') qline
        read(qline,5070,err=9950) stmln(7,i)
  520 continue
      go to 60
!    $nwl      network list for off-body point calculations
  530 continue
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dummy
      nnwofb  =  dummy
      if ( nnwofb .lt. 1 ) go to 60
      nnwofb  =  min (nnwofb,150)
      do 535 ibeg = 1,nnwofb,6
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      ifin    =  min ( ibeg+5, nnwofb)
      do 532 i = ibeg,ifin
      nwofb(i) =  dum(i-ibeg+1)
  532 continue
  535 continue
      go to 60
!
!    $vel      velocity correction (cf. $bou also)
!
  540 continue
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      ivcorr  =  dum(1)
      go to 60
!    $eat       edge abutment tolerance
!
  550 continue
      newabt  =  .true.
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      epsgeo  =  dum(1)
      if ( dum(2) .lt. 0.d0 ) igeoin = 0
      if ( dum(3) .gt. 0.d0 ) igeout = 1
      if ( dum(4) .gt. 0.d0 ) nwxref = 1
      if ( dum(5) .gt. 0.d0 ) xtrint = .true.
!                                  field 6     description
!                                    <0      no abutment print at all
!                                    =0      abutment print only (defaul
!                                    =1      abutment + a.i. print
!                                    =2      (1) + [ nwprop = 1 ]
!                                    =3      (2) + [ iabutd = 1 ]
      iabsum  =  1
      if ( dum(6).lt.0.d0 ) iabsum = 0
      if ( dum(6).gt.0.d0 ) iabsum = 2
      if ( dum(6) .gt. 1.d0 ) nwprop = 1
      if ( dum(6) .gt. 2.d0 ) iabutd = 1
      go to 60
  600 continue
!
!     $sectional properties data
!
!     read number of groups of networks
!      numgrp - number of groups of sectional cuts ( 1.0 to 5.0 )
!
      read (ntsin,'( a )') qline
      read( qline, 5070,err=9950) dum
      numgrp = dum(1)
!
      do 649 igrps = 1,numgrp
!
      do 605 i=1,150
!       initialize:
!
!       set all networks to '1' meaning they are included
        netdat (igrps,i,1) = 1
!
!       set pressure surface to '1' meaning 'upper'
        netdat (igrps,i,2) = 1
!
  605 continue
!
  606 continue
!
      read (ntsin,'( a )') qline
      read(qline, 5030,err=9950)   icard
      write(ntsout, 5045) icard
!
      icard4    =  icard(1:4)
      if ( icard4.eq.dnetlo .or. icard4.eq.dnetup  .or.                 &
     &     icard4.eq.snetlo .or. icard4.eq.snetup       ) goto 607
      if ( icard4.eq.dprelo .or. icard4.eq.dpreup  .or.                 &
     &     icard4.eq.sprelo .or. icard4.eq.spreup       ) goto 627
      if ( icard4.eq.dcutlo .or. icard4.eq.dcutup  .or.                 &
     &     icard4.eq.scutlo .or. icard4.eq.scutup       ) goto 638
      go to 61
!
! $net    network selection
  607 continue
!
!     read number of networks (can be negative)
!     when numnet negative, remove networks rather than adding to list
!     when no $net occurs, all networks will be included
!     numnet - number of networks to be added (+ve) or subtracted (-ve)
!      default ( 0.0 ) cuts all networks except types '18' and '20'
!
      read (ntsin,'( a )') qline
      read( qline, 5070,err=9950) dummy
      numnet(igrps) = abs( dummy )
      if ( dummy .gt. 0.d0 ) go to 610
!
!     if numnet is zero, the default is 'all' networks and no network
!     numbers will be input
      if( numnet(igrps) .eq. 0 ) go to 606
!
      do 608 i=1,numnet(igrps)
!       read network numbers to remove
!        netdat - network number to be subtracted
        read (ntsin,'( a )') qline
        read ( qline, 5070,err=9950) dummy
        j = abs( dummy )
        netdat(igrps,j,1) = 0
  608 continue
      go to 606
!
  610 do 615 i=1,150
!       initialize:
!
!       set all networks to '0' meaning they are not included
        netdat (igrps,i,1) = 0
!
!       set pressure surface to '1' meaning 'upper'
        netdat (igrps,i,2) = 1
!
  615 continue
!
      do 620 i=1,numnet(igrps)
!       read network numbers to add
!        netdat - network number to be added
        read (ntsin,'( a )') qline
        read( qline, 5070,err=9950) dummy
        j = abs( dummy )
        netdat(igrps,j,1) = 1
  620 continue
!
      go to 606
!
! $pre    pressure surface
  627 continue
!
!     read number of pressure surface codes to follow
!     numscd - number of networks to have pressure surface specified
!      default ( 0.0 ) assigns 'upper' surface pressure to all networks
!
      read (ntsin,'( a )') qline
      read (qline, 5070,err=9950) dummy
      numscd = dummy
!
!     if numscd is zero, the default is 'upper' for all networks
!     no surface pressure codes will be input
      if( numscd .eq. 0 ) go to 606
!
      do 631 i=1,numscd
!       read network number and its pressure surface code
!       surfcd - surface code
!        ( 1.0 = 'upper', 2.0 = 'lower', 3.0 = 'difference')
!
        read (ntsin,'( a )') qline
        read(qline,5070,err=9950) dum
        j = abs( dum(1) )
        netdat(igrps,j,2) = dum(2)
        if(netdat(igrps,j,2).eq.0) netdat(igrps,j,2)=1
  631 continue
!
      go to 606
!
! $cut    cut and reference and print option
  638 continue
!
!      read chord option (optcrd) and moment reference option (optmrp)
!      and print option (isecpr)
!      optcrd - option for chord value
!       = 0.0 - compute chord between min and max x of cut
!       = 1.0 - compute chord between min and max point of cut-3d
!       = 2.0 - input chord for each cut on card 10
!      optmrp - option for moment reference point
!       = 0.0 - use 3-d moment reference point: xref,yref,zref
!       = 1.0 - use card 11 as fraction of computed chord
!       = 2.0 - use xc,yc,zc from each cut
!      isecpr - turns on diagnostic printout if '1.0'
!       (it is recommended that '0.0' be used for normal cases)
!      ixyzop - option for use of x or y or z for chord calculation
!       = 0.0 - x-chord (default)
!       = 1.0 - x-chord
!       = 2.0 - y-chord
!       = 3.0 - z-chord
!
        read (ntsin,'( a )') qline
        read(qline,5071,err=9950)dum,dumcut
       optcrd(igrps) = dum(1)
       optmrp(igrps) = dum(2)
       iprtnf(igrps) = dum(3)
       iprtpp(igrps) = dum(4)
       isecpr(igrps) = dum(5)
       ixyzop(igrps) = dum(6)
       if( dum(6) .eq. 0.d0 ) ixyzop(igrps) = 1
!
      refeta(igrps) = dumcut
!     read number of cuts
!     numcut - number of cuts ( 1.0 to 25.0 )
!
      read (ntsin,'( a )') qline
      read(qline, 5070,err=9950) dummy
      numcut(igrps) = dummy
!
      do 647 i=1,numcut(igrps)
!       read definition of cutting plane:
!       xc, yc, zc, xcn, ycn, zcn
!       as 3-d point and unit vector through point
!        xc     - x-coordinate of point through which plane passes
!        yc     - y-coordinate of point through which plane passes
!        zc     - z-coordinate of point through which plane passes
!        xcn    - x-component of normal to cut plane
!        ycn    - y-component of normal to cut plane
!        zcn    - z-component of normal to cut plane
!
        read (ntsin,'( a )') qline
        read(qline,5071,err=9950)dum,dumcut
!
        cutdat(1,igrps,i) = dum(1)
        cutdat(2,igrps,i) = dum(2)
        cutdat(3,igrps,i) = dum(3)
!
        if( ( dum(4) .eq. 0.d0 ) .and.                                  &
     &      ( dum(5) .eq. 0.d0 ) .and.                                  &
     &      ( dum(6) .eq. 0.d0 )       ) dum(5) = 1.d0
!
        cutdat(4,igrps,i) = dum(4)/sqrt(dum(4)**2+dum(5)**2+dum(6)**2)
        cutdat(5,igrps,i) = dum(5)/sqrt(dum(4)**2+dum(5)**2+dum(6)**2)
        cutdat(6,igrps,i) = dum(6)/sqrt(dum(4)**2+dum(5)**2+dum(6)**2)
        cutdat(9,igrps,i) = dumcut
!
        if( .not. ( ( optcrd(igrps) .eq. 2.d0 ).or.                     &
     &              ( optmrp(igrps) .eq. 1.d0 )     ) )  go to 640
!         read chord (chrd)
!          chrd   - reference chord for the cut plane
!          refrac - fraction of chord to be used for moment reference
!
          read (ntsin,'( a )') qline
          read(qline, 5070,err=9950) dum
          if( dum(1) .eq. 0.d0 ) dum(1) = 1.d0
          if( dum(2) .eq. 0.d0 ) dum(2) =  .25d0
          if( optcrd(igrps) .eq. 2.d0 ) cutdat(7,igrps,i) = dum(1)
          if( optmrp(igrps) .eq. 1.d0 ) cutdat(8,igrps,i) = dum(2)
  640   continue
!
  647 continue
!
  649 continue
!
      go to 60
!
! $pea    partial edge abutment
!
  650 continue
!
      nnett   =  k
      do 6501 kk = 1,nnett
          write (nwname(kk),5073) iduser(kk)
          call ljbf10 ( nwname(kk) )
 6501 continue
      call peainp (npeabt,nwname,  movusr                               &
     &            ,mthfrc,peatol,nedges,netpea)
      go to 60
!
! $for  force and moment summary
!
  651 continue
!
      read (ntsin,'( a )') qline
      read(qline, 5030,err=9950)   icard
      write(ntsout, 5045) icard
!
      icard4   =  icard(1:4)
      if ( icard4.eq.snetup .or. icard4.eq.snetlo ) goto 654
      if ( icard4.eq.spreup .or. icard4.eq.sprelo ) goto 657
      go to 61
!
! *net    network selection
  654 continue
!
!     read number of networks (can be negative)
!     when nosnet negative, remove networks rather than adding to list
!     when no *net occurs, all networks will be included
!     nosnet - number of networks to be added (+ve) or subtracted (-ve)
!      default ( 0.0 ) cuts all networks except types '18' and '20'
!
      isignl = 1
      read (ntsin,'( a )') qline
      read( qline, 5070,err=9950) dum
      nosnet = abs( dum(1) )
      icomop = abs( dum(2) )
      if(  icomop .gt. 1 ) icomop = 1
      if( dum(1) .lt. 0.d0) isignl =-1
      if( (nosnet .eq. 0) .and. (icomop .eq. 0) ) isignl = 0
      if( dum(1) .gt. 0.d0) go to 656
!
!     if nosnet is zero, the default is 'all' networks and no network
!     numbers will be input
      if( nosnet .eq. 0 ) go to 651
!
      do 655 i=1,nosnet
!       read network numbers to remove
!        iform - network number to be subtracted
        read (ntsin,'( a )') qline
        read ( qline, 5070,err=9950) dummy
        j = abs( dummy )
        iform(j,1) = 0
  655 continue
      go to 651
!
  656 do 658 i=1,150
!       initialize:
!
!       set all networks to '0' meaning they are not included
        iform(i,1) = 0
!
!       set pressure surface to '1' meaning 'upper'
        iform(i,2) = 1
!
  658 continue
!
      do 659 i=1,nosnet
!       read network numbers to add
!        iform - network number to be added
      read (ntsin,'( a )') qline
      read( qline, 5070,err=9950) dummy
        j = abs( dummy )
        iform(j,1) = 1
  659 continue
!
      go to 651
!
! *pre    pressure surface
  657 continue
!
!     read number of pressure surface codes to follow
!     numscd - number of networks to have pressure surface specified
!      default ( 0.0 ) assigns 'upper' surface pressure to all networks
!
      read (ntsin,'( a )') qline
      read (qline, 5070,err=9950) dummy
      numscd = dummy
!
!     if numscd is zero, the default is 'upper' for all networks
!     no surface pressure codes will be input
      if( numscd .eq. 0 ) go to 653
!
      do 652 i=1,numscd
!       read network number and its pressure surface code
!       surfcd - surface code
!        ( 1.0 = 'upper', 2.0 = 'lower', 3.0 = 'difference')
!
        read (ntsin,'( a )') qline
        read(qline,5070,err=9950) dum
        j = abs( dum(1) )
        iform(j,2) = dum(2)
        if( iform(j,2) .eq. 0 ) iform(j,2) = 1
  652 continue
!
  653 go to 60
!
!
! $iteration-limit                                            $ite
! $cp2 .. was the original key-word                           $cp2
!
  660 continue
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      nitcp2  =  dum(1)
      iexcp2  =  dum(2)
      if ( dum(3).lt.0.d0 ) istcp2 = 0
      if ( dum(3).gt.0.d0 ) istcp2 = dum(3)
      if ( dum(3).gt.0.d0 ) istcp2 = dum(3) + 1.d0
      go to 60
!
!         $mat                                              $mat
!
  670 continue
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      nprop   =  dum(1)
      nprop   =  min(10,max(0,nprop))
      pexp    =  gmair/(gmair-1.d0)
      rexp    =    1.d0 /(gmair-1.d0)
      do 672 i = 1,nprop
          read (ntsin,'( a )') qline
          read (qline,5051,err=9950) tratio(i), pratio(i), qratio(i)
          if ( tratio(i).eq.0.d0 ) tratio(i) = 1.d0
          if ( pratio(i).eq.0.d0 ) pratio(i) = 1.d0
  672 continue
      qratio(0) = 'air       '
      pratio(0) = 1.d0
      tratio(0) = 1.d0
      do 673 i = 0,nprop
          dratio(i) = pratio(i)/tratio(i)
          gcnmat(i) = 1.d0
          pcnmat(i) = 1.d0
          call ljbf10 (qratio(i))
  673 continue
      call outvec ('gcnmat',nprop+1,gcnmat)
      call outvec ('pcnmat',nprop+1,pcnmat)
      call outvec ('rcnmat',nprop+1,rcnmat)
!                                  read the surface material specs
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dum
      nsrfls =  dum(1)
      do 676 i = 1,nsrfls
          read (ntsin,'( a )') qline
          read (qline,5050,err=9950) qnetls(i), qsrfls(i), qmatls(i)
          call ljbf10 (qnetls(i))
          call ljbf10 (qsrfls(i))
          call ljbf10 (qmatls(i))
          do 674 kk = 0,nprop
               ksv  =  kk
               if ( qmatls(i).eq.qratio(kk) ) goto 675
  674     continue
!                                  didn't find the symbol, decode a numb
          read (qmatls(i),5052,err=9950) dum(1)
          ksv   =  dum(1)
  675     continue
          imatls(i) = ksv
  676 continue
      go to 60
!
!     $nof = nofilaments                                    $nof
!
  680 continue
      iwkfil  =  0
      goto 60
!
!     $tre = trefftz plane analysis
!
  698 continue
      ptrffz  =  .true.
      goto 60
!
!
  699 continue
!
!
!       dummy keyword
!
      go to 60
  700 continue
!
      write(ntsout,5025)
 5025 format(/)
!
!      end
!
      call fsvcal
      nnett   =  k
      do 701 kk = 1,nnett
          write (nwname(kk),5073) iduser(kk)
          call ljbf10 (nwname(kk))
  701 continue
!                                  calculate tpcrit for checking pratio(
      tpexp   =  gmair/(1.d0-gmair)
      tpcrit  = ( 1.d0 + .5d0*(gmair-1.d0)*amach*amach )**tpexp + 1.d-12
      tpcrit  =  min( tpcrit, 1.d0)
      write (6,'(1x,a10,1x, 2f12.6)')                                   &
     & 'tpcrit, m',tpcrit,amach
!                                  reset material properties at very low
!                                  mach number to those of air
      if ( amach.lt.(.01d0)  .and.  nprop.gt.0 ) then
          write (6,6240) amach, nprop
          do 702 i = 1,nprop
               tratio(i) = 1.d0
               pratio(i) = 1.d0
               dratio(i) = 1.d0
  702     continue
      endif
 6240 format (                                                          &
     &   ' **********************************************************'  &
     &,/,' *                                                        *'  &
     &,/,' *  warning: material properties being specified while    *'  &
     &,/,' *           mach number is less than (.01).  properties  *'  &
     &,/,' *           will be reset to the properties of air,      *'  &
     &,/,' *           tt/ratio = 1,  tp/ratio = 1.                 *'  &
     &,/,' *                                                        *'  &
     &,/,' *  mach number: ',f12.6,   ', material count: ',i6,'     *'  &
     &,/,' *                                                        *'  &
     &,/,' **********************************************************'  &
     & )
!
!                                  define upper and lower surface materi
!                                  specifications for all networks
      call icopy (2*mxnett,  0,0,   matnet,1)
!-----      write (6,'(''  nsrfls before 705 loop'',i6)') nsrfls
      if ( nsrfls.le.0 ) goto 7051
      do 705 i = 1,nsrfls
      write (6,5662) i, qnetls(i)
 5662 format ('  checking  line ',i5,2x,a10)
          do 703 kk = 1,nnett
               ksv  =  kk
 5663 format ('  network ',i5,2x,a10)
               if ( nwname(kk).eq.qnetls(i) ) goto 704
  703     continue
          read (qnetls(i),5052,err=9950) dum(1)
          ksv = dum(1)
  704     continue
!                            1234512345
          insrf   =  0
          if ( qsrfls(i).eq.lowrlc .or. qsrfls(i).eq.lowruc ) insrf = 2
          if ( qsrfls(i).eq.upprlc .or. qsrfls(i).eq.uppruc ) insrf = 1
          if ( insrf.eq.0 ) call a502ms ('inputa'                       &
     &         ,'surface spec was neither upper nor lower')
          matnet(insrf,ksv) = imatls(i)
  705 continue
 7051 continue
!                            define the free stream vectors for each mat
      do 707 i = 0,nprop
!                                  make sure that  pratio(i) (tp) always
!                                  exceeds tpcrit.
          if ( i.eq.0 ) goto 7050
               if ( pratio(i).lt.tpcrit ) then
                    write (6,6250) qratio(i), i,pratio(i),tpcrit,amach
                    pratio(i) = tpcrit
                    call a502ms ('input/a'                              &
     &                   ,'tp/ratio specified less than critical')
               endif
!                             issue warning for tp#1, tt#1 when amach .l
               if ( amach.lt.(.1d0) .and.                               &
     &               (      ( abs(pratio(i)-1.d0) .gt. 1.d-6 )          &
     &                .or.  ( abs(tratio(i)-1.d0) .gt. 1.d-6 ))  ) then
                    write (6,6260) qratio(i),pratio(i),tratio(i),amach
               endif
!
 7050     continue
          do  706 ia = 1,nacase
               call matvfs (tratio(i),pratio(i),fsv(1,ia)               &
     &                     ,rcnmat(i),vfmat(i),wfmat(i),cpfmat(i)       &
     &                     ,vfsmat(1,ia,i))
  706     continue
  707 continue
 6250 format (                                                          &
     &   ' **********************************************************'  &
     &,/,' *                                                        *'  &
     &,/,' *    fatal: total pressure ratio on material ',a10,   ', *'  &
     &,/,' *           (number ',i6,') was less than the critical   *'  &
     &,/,' *           value for the specified mach number.         *'  &
     &,/,' *           value will be reset to the critical value,   *'  &
     &,/,' *           but job will terminate after a type 2        *'  &
     &,/,' *           datacheck.                                   *'  &
     &,/,' *                                                        *'  &
     &,/,' *           specified pressure ratio: ',f12.6,   '       *'  &
     &,/,' *           critical  pressure ratio: ',f12.6,   '       *'  &
     &,/,' *                        mach number: ',f12.5,   '       *'  &
     &,/,' *                                                        *'  &
     &,/,' **********************************************************'  &
     & )
 6260 format (                                                          &
     &   ' **********************************************************'  &
     &,/,' *                                                        *'  &
     &,/,' *  warning: total pressure ratio or total temperature    *'  &
     &,/,' *           ratio not equal to (1.0) when the mach number*'  &
     &,/,' *           was specified less than (.1).  values will   *'  &
     &,/,' *           be left untouched, but don''t complain if     *' &
     &,/,' *           your results look wierd.                     *'  &
     &,/,' *                                                        *'  &
     &,/,' *                           material: ',a10,   '         *'  &
     &,/,' *                     pressure ratio: ',f12.6,   '       *'  &
     &,/,' *                  temperature ratio: ',f12.6,   '       *'  &
     &,/,' *                        mach number: ',f12.5,   '       *'  &
     &,/,' *                                                        *'  &
     &,/,' **********************************************************'  &
     & )
!                                   update the 'iform' arrays per spec
      if( isignl .eq. 0 ) then
         do 7081 knet = 1,nnett
            if( icomtd(knet) .ne. 1 ) iform(knet,1) = 0
 7081    continue
      else
!
         do 7082 knet = 1,nnett
            if ( ( ntd(knet) .eq. 18 ) .or.                             &
     &           ( ntd(knet) .eq. 20 )      ) iform(knet,1) = 0
            if ( (isignl .lt. 0 ) .and.                                 &
     &           (icomop .eq. 0 ) .and.                                 &
     &           (icomtd(knet) .ne. 1)      ) iform(knet,1) = 0
            if ( (isignl .gt. 0 ) .and.                                 &
     &           (icomop .eq. 0 ) .and.                                 &
     &           (icomtd(knet) .eq. 1 )     ) iform(knet,1) = 1
 7082    continue
      endif
!                                  dump the 'iform' arrays indicating
!                                  which surfaces will be used in force
!                                  and moment calculations
      call outvci ('iform-1',nnett,iform(1,1))
      call outvci ('iform-2',nnett,iform(1,2))
!
!
!                                  generate the quick summary of input
!
      call insumm
      if ( nnetsv.ne.0  .and.  k.ne.nnetsv ) goto 6110
!
!      write out offbody points info on unit nti.  number of record is
!      16.
!
      if(nflowv.eq.0)go to 710
      nof3 = 3*nof
      nidq(16) = nof3
      if ( nof.gt.0 ) call writmd (nti,zof,nof3,16,-1,0)
  710 continue
!
!      write streamlines points on unit nti (=15) as record no 18
!      no of words writtten is stored in nidq(18)
!
      if(nstmln.eq.0)go to 720
         nidq(18) = 7*numpts
      if ( nidq(18).gt.0 ) call writmd (nti,stmln,nidq(18),18,-1,0)
  720 continue
!
!                                  count the mesh points and save the
!                                  unmodified geometry
      nzmesh  =  0
      do 730 k = 1,nnett
          nzmesh  =  nzmesh + nm(k)*nn(k)
  730 continue
!
      nidq(19) = 3*nzmesh
      call writmd (nti,zm,nidq(19),19,-1,0)
!
!                        test whether networks have at least
!                        2 rows & columns in each network
!
      ifrwcl = 0
      do 735 k=1,nnett
        if( nm(k) .gt. 1 .and. nn(k) .gt. 1 ) go to 735
        ifrwcl = 1
        write(ntsout,5026)
 5026   format(1x,'less than 2 rows or 2 columns were ',                &
     &            'found in network #',i4)
  735 continue
      if( ifrwcl .eq. 1 ) go to 9000
!
!                          force partial abutments if desired by user
!
      if(npeabt.eq.0) go to 741
      write(ntsout,5027)
 5027 format(1h1,//,                                                    &
     &22x,53hrecord of forced partial edge abutment processing    ,/,   &
     &22x,53h      (only changed points are reported)             ,     &
     &//)
      notokg = 0
!                                  use the procedure of tgeomc to set ep
      epssav  =  epsgeo
      call abtdim (nnett,nm,nn,zm,ntd,  diamin,diamax)
      epsmax  =  .1d0*diamin
      epsdef  =  .001d0*diamin
      if ( epsgeo .eq. 0.d0 ) epsgeo = epsdef
      if ( epsgeo .gt. epsmax ) epsgeo = epsmax
      epsgeo  =  abs(epsgeo)
      if ( movusr.ge.3 ) write (6,5083) epsgeo
 5083 format ('    global geometry tolerance used in $pea processing:'  &
     &       ,1p,e12.4)
!                                  enforce the $pea specifications
      call setcor ('peaidn')
      call getcor ('zorg',llzorg,3*maxpts)
      call getcor ('dzcr',lldzcr,  mxempt)
      call igtcor ('kpte',llkpte,  mxempt)
      call igtcor ('kemp',llkemp,  mxempt)
      call igtcor ('kptp',llkptp,  mxempt)
!
      call igtcor ('nedm',llnedm,4*mxnett+1)
      call igtcor ('iedg',lliedg,4*mxnett)
      call peaidn (nnett,nm,nn,zm,ntd,  comprs,epsgeo,mthfrc,movusr     &
     &            ,npeabt,netpea,nedges,peatol,nza                      &
     &            ,w(llzorg),w(lldzcr),w(llkpte),w(llkemp),w(llkptp)    &
     &            ,w(llnedm),w(lliedg)                                  &
     &            )
      call frecor ('peaidn')
!                                  reset epsgeo
      epsgeo  =  epssav
      write(ntsout,5084)
  741 continue
!
!                          force abutments if desired by the user.
!
      if(iabut.ne.1)go to 751
      do 750 i=1,nabut
      call abtfor (abnet1(i),absid1(i),abnet2(i),absid2(i),nok)
      if (nok .eq. 0) go to 6120
  750 continue
      write(ntsout,5085)
  751 continue
!
!
!                                       if restart, check for consistenc
!                                       between ipot(k) and nckaic value
!
      if(nckaic.ne.2)go to 761
      do 760 k=1,nnett
      if(ipot(k).ne.2)go to 6230
  760 continue
  761 continue
!                          generate an input file for a-a451 post-
!                          processor on pdp if ndtchk . ne .0
!
      if(ndtchk.eq.0)go to 770
      call mspnt1
      write(ntsout,5090)
  770 continue
      if ( ndtchk.ne.0 .and. icontp.ge.0 ) icontp = 1
      if ( icontp.lt.0 ) icontp = 0
!                                  set the flag for printing normals
!                                  defaults: datacheck ==> on
!                                            solution  ==> off
      ntmp    =  nprten
      nprten  =  0
      if ( ntmp.gt.0 ) nprten = 1
!
!
!     return
      close (22,status='delete')
      return
 5020 format(1h1,//,                                                    &
     &22x,54h                record of input processing            ,    &
     &//)
 5030 format(20a4)
!
!
!
 5045 format(2x,20a4)
 5050 format (8a10)
 5051 format (2f10.0,a10)
 5052 format (f10.0)
 5070 format(6f10.5)
 5071 format(7f10.5)
 5084 format(//,2x,                                                     &
     &       49hforced partial edge abutments processing complete,//)
 5085 format(//,5x,36hforced abutments processing complete,//)
 5090 format(//,5x,42ha-a451 postprocessor input deck is written,//)
!
!                             error exit
!
!
!                  program exit due to improper keyword.
!
 6003 continue
      write(6,7003)
      write(ntsout,7003)icard
 7003 format(//,5x,'following card does not match designated keyword'   &
     &        /,5x,20a4//)
      go to 9000
!
!                     program exit due input of abutment data out of ord
!
 6005 continue
      write(ntsout,7005)
 7005 format(//,5x,36habutments should be forced after all,             &
     &18h geometry is input  )
      go to 9000
!
!     nnett check 1
!
 6010 write(ntsout,7010)
 7010 format(//5x,76h--- number of networks ($net) should be greater tha&
     &n 0 and less than 101 ---)
      write(ntsout,7015)  icard(1:4)
 7015 format(//5x,42h--- error exit from processing data under ,a4,4h --&
     &-)
      go to 9000
!
!     m/ superinclined inconsistency
!
 6030 write (ntsout,7030)
 7030 format (//5x,'--- mach number less than or equal to 1 ',          &
     &             'for superinclined networks ---')
      go to 9000
!
!     nnett check 3
!
 6100 write(ntsout,7100)  icard(1:4)
 7100 format(//5x,108h--- preprocessor ($quadrilateral or $gothic wing) &
     &or input corner points ($points) must be specified before ,a4,4h -&
     &--)
      go to 9000
 6110 write(ntsout,7110)  k
 7110 format(//5x,'--- total number of networks (',i3,') processed is', &
     &' not equal to the number of networks given under ($net) ---')
      go to 9000
 6115 write(ntsout,7115)
 7115 format(//5x,'fatal error(s) detected in partial edge abutment(s)'/&
     &         5x,'please check above listing for cited error(s)')
!
      go to 9000
 6120 write (6,7120) abnet1(i),absid1(i),abnet2(i),absid2(i)
 7120 format (//5x,'--- program failed to find specified abutment ---'/ &
     &         /10x,'net1 =',i5,5x,'side1 =',i5                         &
     &         /10x,'net2 =',i5,5x,'side2 =',i5)
      go to 9000
 6210 write(ntsout,7210)ntr
 7210 format(//,5x,'--- ntr can only be 1 or 2',i10)
!
!      to many offbody points. write error message and exit.
!
 6220 write(ntsout,7220) j1
 7220 format(//5x,75h--- too many additional offbody points were specifi&
     &ed in $grids grid number ,i10)
      go to 9000
 6230 continue
      write(6,7230)nckaic
 7230 format(//,5x,22h---wrong--ipot value--,i5,//)
      go to 9000
 9000 continue
!
!                              write message for the exit stop
!
      write(ntsout,9010)
 9010 format(//,5x,'this stop occurred in subroutine inputa',//)
!
      stop
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'inputa', 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('inputa',' program failure due to ill-formatted data')
      return
!
      END subroutine inputa
! **deck inside
      subroutine inside (q,ics,anm,p,within)
      implicit double precision (a-h,o-z)
      dimension q(3,4), anm(3), p(3)
!         given a vector anm that determines a plane passing through
!         the origin, inside determines if the projection of  p  on
!         that plane lies inside or outside the plane quadrilateral
!         determined by the projection of q(*,j), j=1,4, on that
!         plane
      logical  within
      dimension a(4), rm(3), rp(3), x(3)
      amax    =  0.d0
      ifst    =  1
      if ( ics .eq. 1 ) ifst = 2
      call vadd (q(1,ifst),-1.d0,p,rp,3)
!                                  cycle on edges
      do 100 i = 1,4
          if ( i .eq. ics ) go to 100
          call xfera (rp,rm,3)
          ip1     =  mod(i,4) + 1
          if ( ip1.eq.ics ) ip1 = mod(ip1,4) + 1
          call vadd (q(1,ip1),-1.d0,p,rp,3)
          call cross (rm,rp,x)
          a(i)    =  ddot (3,  x,1,  anm,1)
          if ( abs(a(i)) .ge. abs(amax) ) amax = a(i)
  100 continue
      within  =  .true.
!                                  check areas for consistent signs
      do 200 i = 1,4
          if ( i.eq.ics ) go to 200
          if ( a(i)*amax .gt. 0.d0 ) go to 200
               within  =  .false.
               go to 210
  200 continue
  210 continue
      return
      END subroutine inside
! **deck insumm
      subroutine insumm
      implicit double precision (a-h,o-z)
!
!         generate a summary of the user's input data
!
!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 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 brwi
      parameter (nsbp=6)
      common/brwi/nbdq,nsb,nrb,ntb,nnb,nib((maxcp+nsbp-1)/nsbp+1)
!end  brwi
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call curpan
      common/curpan/cpnorm(150)
!end  curpan
!call boundl
!                                                           /boundl/
      common /boundl/ itapbl, ivcorr
!end  boundl
!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 fmcof
      common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof
!end  fmcof
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!call titles
      common /titles/ title1(20),title2(20)
      character*4 title1, title2
!end  titles
!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 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 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 irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!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 chkpnt
      common /chkpnt/  nckaic, nckusp
!end  chkpnt
!call slofbd
!         information about off-body input and streamline input is
!         stored in  /slofbd/.  the array  zof(1:5000)  contains up
!         the coordinates of up to  1666  off-body points.   the
!         array  stmln(7,1:500)  contains the following information
!         about the streamline start points (up to 500 in all):
!              stmln(1,i) = starting x value
!              stmln(2,i) = starting y value
!              stmln(3,i) = starting z value
!              stmln(4,i) = max value of del(x) along the streamline
!              stmln(5,i) = max value of del(y) along the streamline
!              stmln(6,i) = max value of del(z) along the streamline
!              stmln(7,i) = forward/backward indicator. (0 ==> forward,
!                                nonzero ==> backward integration )
      common /slofbd/ zof(5000), stmln(7,500)
!end  slofbd
!call iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
!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
      character*10 qmatu, qmatl
!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
!call kutflg
!                                                            /kutflg/
      common /kutflg/ kutta(150), kttype(150)
!end  kutflg
      logical rhctr1, rhctr2
!call datchk
!                                                            /datchk/
      common/datchk/ndtchk
!end  datchk
!call exdign
!                                                            /exdign/
      common/exdign/nexdgn
!end  exdign
!
!
!
      write (6,6000) title1, title2
 6000 format (1h1,15x,'***  quick summary of a502 input  ***'           &
     &  ,/,' title1:',1x,20a4                                           &
     &  ,/,' title2:',1x,20a4                                           &
     &  )
!
      itpoff  =  tpoff
      itpsl   =  tpsl
      write (6,6010) ndtchk, nckusp, nckaic, itapbl, ivcorr             &
     &             , nflowv,  itpoff, itpsl, nof, numpts
 6010 format (1h0,15x,'processing options'/                             &
     &1x,i12,' = datacheck.   ',                                        &
     &   '(0=regular run,1=full datacheck,2=short datacheck) '/         &
     &1x,i12,' = s.p. flag.   (0 ==> no s.p. file (ft09) provided,',    &
     &   ' 1 ==> local file ft09 with singularity values is provided) '/&
     &1x,i12,' = aic flag.    (0 ==>  no aic file (ft04) provided,',    &
     &   ' 1 ==> local file ft04 with aic-s is provided by the user) '/ &
     &1x,i12,' = b.l. flag    (0 ==> no boundary layer file requested,',&
     &   ' 1 ==> boundary layer data will be written to file ft17) '/   &
     &1x,i12,' = velocity correction index.  (0 ==> no correction,',    &
     &   ' 1 ==> mclean correction, 2 ==>  boctor correction) '/        &
     &1x,i12,' = flow visualization flag.  (nonzero ==> off-body and',  &
     &   ' streamline processing will be performed)'/                   &
     &1x,i12,' = off-body calculation type.',                           &
     &   ' (0 ==> mass flux, nonzero ==> velocity)'/                    &
     &1x,i12,' = streamline calculation type.',                         &
     &   ' (0 ==> mass flux, nonzero ==> velocity)'/                    &
     &1x,i12,' = number of off-body points.'/                           &
     &1x,i12,' = number of streamlines to be traced.'                   &
     & )
!
      write (6,6020) nacase, amach, alpc, betc
 6020 format (1h0,15x,'case summary'                                    &
     & ,/,1x,i12,' = number of cases '                                  &
     & ,/,1x,f12.6,' = mach number '                                    &
     & ,/,1x,f12.6,' = compressibility axis angle of attack (alpc) '    &
     & ,/,1x,f12.6,' = compressibliity axis angle of sideslip (betc) '  &
     &  )
      write (6,6021)
 6021 format (1h0,'  case',2x,'     alpha  ',2x,'      beta  ',2x,      &
     &  '  mag(f-s-v)'                                                  &
     &   ,/,  1h ,'------',2x,'  ----------',2x,'  ----------',2x,      &
     &  ' -----------'                                                  &
     & )
      do 210 i = 1,nacase
          write (6,6022) i, alpha(i), beta(i), fsvm(i)
  210 continue
 6022 format (1x,i6,2x,f12.6,2x,f12.6,2x,f12.6)
!
      write (6,6030) nsymm, misym, mjsym
 6030 format (1h0,15x,'symmetry options'                                &
     & ,/,1x,i12,' = number of planes of symmetry '                     &
     & ,/,1x,i12,' = x-z plane of symmetry flag (0 ==> no symmetry, 1==>&
     & flow symmetry, -1 ==> flow antisymmetry) '                       &
     & ,/,1x,i12,' = x-y plane of symmetry flag (0 ==> no symmetry, 1==>&
     & flow symmetry, -1 ==> flow antisymmetry) '                       &
     &  )
!
      nza(1)  =  0
      npa(1)  =  0
      do 410 k = 1,nnett
          nza(k+1) = nza(k) + nm(k)*nn(k)
          npa(k+1) = npa(k) + ( nm(k)-1 ) * ( nn(k)-1 )
  410 continue
      nzmpt   =  nza(nnett+1)
      npant   =  npa(nnett+1)
      write (6,6040) nnett, nzmpt, npant
 6040 format (1h0,15x,'configuration summary'                           &
     & ,/,1x,i12,' = total number of networks read in '                 &
     & ,/,1x,i12,' = total number of mesh points '                      &
     & ,/,1x,i12,' = total number of panels '  )
      write (6,6041)
 6041 format (1h0,                                                      &
     &  'network id','&index',2x,' #rows',2x,' #cols',2x,'kt',2x,'src', &
     &  2x,'dblt',2x,'nlopt1',2x,'nropt1',2x,'nlopt2',2x,'nropt2',2x,   &
     &  '  ipot',2x,' # pts',2x,'# pans',2x,'cpnorm'                    &
     &   ,2x,'cum pt',2x,'cum pn'                                       &
     &  ,/, 1x ,                                                        &
     & '----------' ,' -----',2x,' -----',2x,' -----',2x,'--',2x,'---', &
     &  2x,'----',2x,'------',2x,'------',2x,'------',2x,'------',2x,   &
     &  '  ----',2x,'  ----',2x,'  ----',2x,'------'                    &
     &   ,2x,'------',2x,'------'                                       &
     &  )
! --- 6043 format (1x,a10,  14(i6,2x), i6)
 6043 format (1x,a10,  3(i6,2x), i2,2x, i3,2x, i4,2x, 9(i6,2x), i6)
      ierglo  =  0
!                                  define the surface conventions for th
!                                  nlopt values
      call icopy (26,  0,0,  isfrgn(0),1)
      isfrgn(2)  = 1
      isfrgn(3)  = 2
      isfrgn(6)  = 1
      isfrgn(7)  = 2
      isfrgn(11) = 1
      isfrgn(12) = 2
      ierctr  =  0
      do 420 k = 1,nnett
          ierk    =  0
          nl1     =   0
          nr1     =  0
          nl2     =  0
          nr2     =  0
          ica1    =  nbca(k) + 1
          ica2    =  nbca(k+1)
          imatlo  =  matnet(2,k)
          imatup  =  matnet(1,k)
          kctr1   =  0
          kctr2   =  0
          do 415 ica = ica1,ica2
               call btrns (ica,cu1)
!                                  check that any nropt=4 or 9 b.c. is
!                                  clearly applied to either the lower
!                                  or the upper surface.
               ianr1   =  iabs(nropt1)
               ianr2   =  iabs(nropt2)
               ianl1   =  iabs(nlopt1)
               ianl2   =  iabs(nlopt2)
               rhctr1  =  ianr1.eq.4 .or. ianr1.eq.9
               rhctr2  =  ianr2.eq.4 .or. ianr2.eq.9
               isurf1  =  isfrgn(ianl1)
               isurf2  =  isfrgn(ianl2)
               if(ianl1.ne.0 .and. rhctr1 .and.isurf1.eq.0)kctr1=kctr1+1
               if(ianl2.ne.0 .and. rhctr2 .and.isurf2.eq.0)kctr2=kctr2+1
               if ( nlopt1.eq.3.or.nlopt1.eq.7 ) nropt1 = -iabs(nropt1)
               if ( nlopt2.eq.3.or.nlopt2.eq.7 ) nropt2 = -iabs(nropt2)
               call ibtrns (ica,cu1)
               if ( nlopt1.ne.0 ) nl1 = nlopt1
               if ( nropt1.ne.0 ) nr1 = nropt1
               if ( nlopt2.ne.0 ) nl2 = nlopt2
               if ( nropt2.ne.0 ) nr2 = nropt2
               if ( nlopt1.eq.nlopt2  .and.                             &
     &              nlopt1.ne.0       .and.                             &
     &              nlopt1.ne.1            ) ierk = ierk + 1
  415     continue
          kbcrgn(k) = kctr1 + kctr2
          icpnrm  =  cpnorm(k)
          nzk     =  nza(k+1) - nza(k)
          npk     =  npa(k+1) - npa(k)
          ktk     =  kttype(k)
          write (6,6043)                                                &
     &   iduser(k)(1:10),k,nm(k),nn(k),ktk,nts(k),ntd(k),nl1,nr1,nl2,nr2&
     &                  ,ipot(k),nzk,npk,icpnrm                         &
     &                    ,nza(k),npa(k)
          ierglo  =  ierglo + ierk
          if ( ierk.ne.0 ) write (6,6044) ierk
 6044 format ('  *****  error  *****  the above network had identical'  &
     & ,' values of nlopt1 and nlopt2 (not 0 or 1) at',i4,' control'    &
     & ,' points.'                                                      &
     &   ,/,  '                       this would lead to a singular'    &
     & ,' aic matrix.  you must specify two independent boundary'       &
     & ,' conditions'                                                   &
     &   ,/,  '                       on this network'                  &
     &    )
          if ( kbcrgn(k).gt.1 ) then
               ierctr = ierctr + 1
               write (6,6045)
          endif
 6045 format ('  *****  error  *****  the above network specified'      &
     &    ,' nropt = 4 or 9  with an nlopt value that is not clearly'   &
     &  ,/,' associated with either the upper or lower surface')
!
  420 continue
      write (6,6151)
      do 440 k = 1,nnett
      imatu   =  matnet(1,k)
      imatl   =  matnet(2,k)
      qmatu   =  qratio( imatu )
      qmatl   =  qratio( imatl )
      write (6,6153) k,iduser(k)(1:10),  matnet(1,k),qmatu              &
     &                                  ,matnet(2,k),qmatl
  440 continue
 6151 format (////,                                                     &
     & '                material properties on network surfaces '       &
     & ,//,                                                             &
     & ' index, network-id',4x,' upper surface ',4x,' lower surface '   &
     & ,/,                                                              &
     & ' -----  ----------',4x,' ------------- ',4x,' ------------- '   &
     &  )
 6153 format (1x,i5,2x,a10, 4x, i3,1x,a10,       5x,  i3,1x,a10)
      write (6,6161)
      nmat = 0
      do 460 imat = 0,nprop
      write (6,6163) qratio(imat),imat,tratio(imat),pratio(imat)        &
     &              , gcnmat(imat),pcnmat(imat), rcnmat(imat)           &
     &              ,vfmat(imat),wfmat(imat),cpfmat(imat)
  460 continue
 6161 format (///,12x                                                   &
     & ,'material properties for the various values of surface index'   &
     & ,//,                                                             &
     & 1x,'  material',' index'   ,2x,'temperature ratio'               &
     &   ,2x,'pressure ratio'  ,2x,'    g    ',2x,'    p    '           &
     &   ,2x,'    r    '                                                &
     &    ,2x,'k/v ratio',2x,'k/w ratio',2x,'k/p ratio'                 &
     & ,/,                                                              &
     & 1x,'----------','------'   ,2x,'-----------------'               &
     &   ,2x,'--------------'  ,2x,'---------',2x,'---------'           &
     &   ,2x,'---------'                                                &
     &    ,2x,'---------',2x,'---------',2x,'---------'                 &
     &  )
 6163 format (1x,a10,i6, 2x,f17.5, 2x,f14.4, 2x,f9.5, 2x,f9.5, 2x,f9.5  &
     &    ,2x,f9.5       ,2x, f9.5      ,2x, f9.5                       &
     &  )
      write (6,6180)
 6180 format  (20x,'  free stream vectors for each material ')
      write (6,6181)
 6181 format (                                                          &
     &         ' material &',' index','case 1 vx      vy      vz  '     &
     & ,'case 2 vx      vy      vz  ','case 3 vx      vy      vz  '     &
     & ,'case 4 vx      vy      vz  '                                   &
     &  ,/,                                                             &
     &         ' ----------','  ----','     ------  ------  ------'     &
     & ,'     ------  ------  ------','     ------  ------  ------'     &
     & ,'     ------  ------  ------'                                   &
     &   )
      do 480 iprop = 0,nprop
      write (6,6182) qratio(iprop), iprop                               &
     &             , ((vfsmat(i,ia,iprop),i=1,3),ia=1,nacase)
  480 continue
 6182 format (1x,a10,i6,  3x,3f8.4,3x,3f8.4,3x,3f8.4,3x,3f8.4)
      if ( ierglo.gt.0 ) call a502ms ('insumm'                          &
     &                      ,'duplicate bc-s==>singular aic, see above')
      if ( ierctr.gt.0 ) call a502ms ('insumm'                          &
     &                     ,'indefinite surface for bc w nropt=4,9')
!
      joutpr  =  ioutpr - 1
      jfmcpr  =  ifmcpr - 1
      write (6,6050) isings, igeomp, isingp, icontp, ibconp, iedgep     &
     &             , ipraic, nexdgn, joutpr, jfmcpr, icostp, ispmap
 6050 format (1h0,15x,'print options'                                   &
     & ,/,1x,i12,' = singularity grid print flag '                      &
     & ,/,1x,i12,' = panel geometry print flag  '                       &
     & ,/,1x,i12,' = spline data flag  ( 0 ==> off, nonzero ==> on )'   &
     & ,/,1x,i12,' = control point information print flag '             &
     & ,/,1x,i12,' = boundary condition data print flag '               &
     & ,/,1x,i12,' = edge matching information print flag'              &
     & ,/,1x,i12,' = index of control point for which aic-s are printed'&
     & ,/,1x,i12,' = edge control point flow properties print flag'     &
     & ,/,1x,i12,' = output control flag (-1 ==> no surface flow propert&
     &ies, 0 ==> standard output, 1 ==> short form output ) '           &
     & ,/,1x,i12,' = force/moment control flag (-1 ==> no force and mome&
     &nt data, 0 ==> standard output, 1 ==> nw totals only )'           &
     & ,/,1x,i12,' = print flag for detailed cost information during exe&
     &cution of job '                                                   &
     & ,/,1x,i12,' = print flag for singularity parameter maps '        &
     &   )
!
      itrint  =  0
      if ( xtrint ) itrint = 1
      write (6,6060) epsgeo, igeoin, igeout, nwxref, itrint, iabsum
 6060 format (1h0,15x,'abutment processing options'                     &
     & ,/,1x,1pe12.4,' = global edge abutment tolerance specified by use&
     &r.  if this value is zero, a default value will be calculated'    &
     & ,/,1x,12x,    '   later.   this default value is taken as:  .001 &
     & * (minimum panel diameter)  '                                    &
     & ,/,1x,i12 ,   ' = print flag controlling geometry printout  b e f&
     & o r e  the abutment processing.  ( nonzero ==> do print )'       &
     & ,/,1x,i12 ,   ' = print flag controlling geometry printout  a f t&
     & e r    the abutment processing.  ( nonzero ==> do print )'       &
     & ,/,1x,i12 ,   ' = network/abutment/abutment-intersection print fl&
     &ag.  ( nonzero ==> generate the cross referenced abutment listing'&
     & ,/,1x,i12 ,   ' = control index for panel intersection checking. &
     & ( nonzero ==> do perform the check. )  '                         &
     & ,/,1x,i12 ,   ' = abutment/abutment-intersection (short listing) &
     &print flag ( 0 ==> suppress, nonzero ==> generate usual print )'  &
     &  )
      write (6,6070) sref, bref, cref, dref, xref, yref, zref           &
     &          ,nprcof
 6070 format (1h ,/,16x,'force and moment reference parameters'         &
     & ,/,1x,1pe12.4 ,' = reference area for force and moment calculatio&
     &ns.    (sref) '                                                   &
     & ,/,1x,1pe12.4 ,' = rolling moment reference length  (bref) '     &
     & ,/,1x,1pe12.4 ,' = pitching moment reference length (cref)'      &
     & ,/,1x,1pe12.4 ,' = yawing moment reference length   (dref) '     &
     & ,/,1x,1pe12.4 ,' = x - coordinate for the point about which momen&
     &ts will be calculated  (xref) '                                   &
     & ,/,1x,1pe12.4 ,' = y - coordinate for the point about which momen&
     &ts will be calculated  (yref) '                                   &
     & ,/,1x,1pe12.4 ,' = z - coordinate for the point about which momen&
     &ts will be calculated  (zref) '                                   &
     & ,/,1x,i12,' = pressure coefficient index (nprcof) (1=linear,'    &
     &          ,' 2=slenderbody, 3=2nd, 4=isentropic) '                &
     & )
!
      if ( nof.le.0 ) go to 800
      write (6,6080) nof
 6080 format (1h0,15x,'coordinates of',i4,' off-body points ')
      call outmvc (' ',1,1,nof,zof)
  800 continue
!
      if ( numpts.le.0 ) go to 900
      write (6,6090) numpts
 6090 format (1h0,15x,'input data for streamlines.  number of streamline&
     &s =',i6,//                                                        &
     & 2x,'    x(start)',2x,'    y(start)',2x,'    z(start)',           &
     & 2x,'   delx(max)',2x,'   dely(max)',2x,'   delz(max)',           &
     & 2x,'up/down flag (0==> downstream, #0==> upstream)' ,/,          &
     & 2x,'    --------',2x,'    --------',2x,'    --------',           &
     & 2x,'   ---------',2x,'   ---------',2x,'   ---------',           &
     & 2x,'------------'                                                &
     & )
      do 850 ipt = 1,numpts
          write (6,6091)  (stmln(i,ipt),i=1,7)
  850 continue
 6091 format ( 7(2x,1pe12.4) )
  900 continue
!
!
!
      return
      END subroutine insumm
! **deck intchk
      logical function intchk (a)
      character*4 a
      character*1 ch(4)
!        determine if a number is an integer by examining the exponent
!        field bits
      ch(1)  =  a(1:1)
      ch(2)  =  a(2:2)
      ich1   =  ichar( ch(1) )
      ich2   =  ichar( ch(2) )
!                               if initial byte is 0  or  255, the numbe
!                               is most probably an integer
      intchk = .false.
      if ( ich1.eq.0 .or. ich2.eq.255 ) intchk = .true.
!
      return
      END function intchk
! **deck integr
      subroutine integr (npant,array,prcoef,isurf)
      implicit double precision (a-h,o-z)
      dimension array(21,npant),prcoef(3,npant)
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     * compute panel forces and moments                              *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * *  m e t h o d  * * *                   *
!     *                          - - - - - -                          *
!     *                                                               *
!     *     array is constructed to contain force and moment          *
!     *     information.  array is dimensioned as                     *
!     *     array( k, panel number) where k in this routine ranges    *
!     *     over:                                                     *
!     *         15 integrated force    x                              *
!     *         16 integrated force    y                              *
!     *         17 integrated force    z                              *
!     *         18 integrated moment   x                              *
!     *         19 integrated moment   y                              *
!     *         20 integrated moment   z                              *
!     *         21 length of cut                                      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     --------------------- formal parameter list ---------------------
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   array               output    sectional properties for cut  *
!     *                                                               *
!     *   prcoef              output    pressure coefficients data for*
!     *                                 networks in a group           *
!     *                                                               *
!     *   isurf     input     user requested side for properties      *
!     *                       1 - upper surface (normal points "out") *
!     *                       2 - lower surface (normal points "in")  *
!     *                       3 - difference (upper-lower)            *
!
!     --------------------- labelled common blocks --------------------
!
!
!
!
!     reference parameters
!
!     xref : x coordinate of the reference point for the moment
!     yref : y coordinate of the reference point for the moment
!     zref : z coordinate of the reference point for the moment
!     sref : refrenece area
!     bref : reference length for moment about x axis
!     cref : reference length for moment about y axis
!     dref : reference length for moment about z  axis
!
!
!     scratch common block used in sectional properties.
!
!      igrps  : group number (often used as an index)
!      netwrk : network number (an index)
!call fmcof
      common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof
!end  fmcof
!call secscr
      common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin  &
     &             , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2)
!end  secscr
!
!     --------------------- local array declarations ------------------
!
!
!     --------------------- executable code ---------------------------
!
      isign = (-1)**isurf
!
      do 1000 ipan=1,npant
        if( nint(array(1,ipan)) .eq. 0 ) go to 1000
!
!       the following data items are available:
!       pressure coefficients are contained in prcoef(1,ipan)
!       panel normal vector is in array(12,ipan) through array(14,ipan)
!       intersection data in mean plane coordinates is in
!       array(8,ipan) through array(9,ipan)
!
        cpin  = prcoef(1,ipan)                +                         &
     &          prcoef(2,ipan)*array( 8,ipan) +                         &
     &          prcoef(3,ipan)*array( 9,ipan)
!
        cpout = prcoef(1,ipan)                +                         &
     &          prcoef(2,ipan)*array(10,ipan) +                         &
     &          prcoef(3,ipan)*array(11,ipan)
!
!       compute average pressure across intersection line
        cpavg  = .5d0 * (cpin + cpout)
!
!       save intersection length
        array(21,ipan) = sqrt( ( array(8,ipan)-array(10,ipan) )**2 +    &
     &                         ( array(9,ipan)-array(11,ipan) )**2 )
!
!       calculate unit tangent vector along cut
        dx = array(5,ipan) - array(2,ipan)
        dy = array(6,ipan) - array(3,ipan)
        dz = array(7,ipan) - array(4,ipan)
        cutlen = sqrt(dx*dx + dy*dy + dz*dz)
        utanx = dx / cutlen
        utany = dy / cutlen
        utanz = dz / cutlen
!
!       integrate pressure to obtain normal force normalized by chord
        array(15,ipan) = isign*cpavg*array(21,ipan)*array(12,ipan)/chrd
        array(16,ipan) = isign*cpavg*array(21,ipan)*array(13,ipan)/chrd
        array(17,ipan) = isign*cpavg*array(21,ipan)*array(14,ipan)/chrd
!
!       integrate force to obtain moment normalized by square of chord
        delcp = cpout - cpin
        coef1 = (delcp / 3.0d0) + (cpin / 2.0d0)
        coef2 = (delcp / 4.0d0) + (cpin / 2.0d0)
!
!       xmomx etc - moment of pressures along segment around segment
!                   center point
        xmomx  = isign*cutlen * ( cutlen*coef1 *                        &
     &           (array(14,ipan)*utany - array(13,ipan)*utanz) +        &
     &           coef2*(array(14,ipan) * (array(3,ipan) - array(6,ipan))&
     &           -      array(13,ipan) * (array(4,ipan) - array(7,ipan))&
     &           ))
        xmomy  = isign*cutlen * ( cutlen*coef1 *                        &
     &           (array(12,ipan)*utanz - array(14,ipan)*utanx) +        &
     &           coef2*(array(12,ipan) * (array(4,ipan) - array(7,ipan))&
     &           -      array(14,ipan) * (array(2,ipan) - array(5,ipan))&
     &           ))
        xmomz  = isign*cutlen * ( cutlen*coef1 *                        &
     &           (array(13,ipan)*utanx - array(12,ipan)*utany) +        &
     &           coef2*(array(13,ipan) * (array(2,ipan) - array(5,ipan))&
     &           -      array(12,ipan) * (array(3,ipan) - array(6,ipan))&
     &           ))
!
!       ymomx etc - moment of force acting at segment center point
!                   around reference point
        ymomx  = isign*cpavg*array(21,ipan)*(                           &
     &         ((array(6,ipan)+array(3,ipan))*.5d0-yr)*array(14,ipan)-  &
     &         ((array(7,ipan)+array(4,ipan))*.5d0-zr)*array(13,ipan))
        ymomy  = isign*cpavg*array(21,ipan)*(                           &
     &         ((array(7,ipan)+array(4,ipan))*.5d0-zr)*array(12,ipan)-  &
     &         ((array(5,ipan)+array(2,ipan))*.5d0-xr)*array(14,ipan))
        ymomz  = isign*cpavg*array(21,ipan)*(                           &
     &         ((array(5,ipan)+array(2,ipan))*.5d0-xr)*array(13,ipan)-  &
     &         ((array(6,ipan)+array(3,ipan))*.5d0-yr)*array(12,ipan))
!
        array(18,ipan) = (xmomx + ymomx)/(chrd**2)
        array(19,ipan) = (xmomy + ymomy)/(chrd**2)
        array(20,ipan) = (xmomz + ymomz)/(chrd**2)
!
 1000 continue
!
      return
!
      END subroutine integr
! **deck intnrm
      subroutine intnrm (z1,z2,y1,y2,  en)
      implicit double precision (a-h,o-z)
      dimension  z1(3), z2(3), y1(3), y2(3), en(3)
!         compute an edge interior normal given two point along the
!         edge (z1,z2) and two points just interior to these (y1,y2)
      dimension  u(3), v(3), w(3)
      do 10 i = 1,3
          u(i)    =  y1(i) + y2(i) - z1(i) - z2(i)
          v(i)    =  z2(i) - z1(i)
   10 continue
      call cross (v,u,w)
      call cross (w,v,en)
      call uvect ( en )
      return
      END subroutine intnrm
! **deck intp1
      subroutine intp1(zx,x,f,n,fx)
      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 perform one dimensional linear interpolation
!
!     input    calling sequence
!              zx - point to interpolate for
!              x - independent variable array
!              f - dependent variable array
!              n - dimension of the array x
!
!     output   calling sequence
!              fx - result of linear interpolation
!
!     discussion  first search for the interval where zx lies.  then
!              perform the linear interpolation using the endpoints of
!              the interval.
!******
      dimension x(n),f(n)
!                             search for the interval
      call binsch(zx,x,n,il,iu)
      if(il.ne.iu)  go to 10
!                             return exact value or nearest endpoint
      fx = f(il)
      go to 20
!                             perform linear interpolation
   10 sm = (f(il) - f(iu))/(x(il) - x(iu))
      fx = sm*(zx - x(il)) + f(il)
   20 return
      END subroutine intp1
! **deck intp2
      subroutine intp2(zx,zy,x,y,f,nx,ny,nfx,nfy,fxy)
      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 perform two dimensional linear interpolation
!
!     input    calling sequence
!              zx,zy - point to interpolate for
!              x,y - arrays of independent variables
!              f - a two dimensional array of dependent variables
!              nx - dimension of the array x
!              ny - dimension of the array y
!              nfx,nfy - dimension of the 2-d array f
!
!     output   calling sequence
!              fxy - result of interpolation
!
!     discussion  first search for the rectangle where (zx,zy) lies.
!              then perform the linear interpolation along both the x
!              and y directions.
!******
      dimension x(nx),y(ny),f(nfx,nfy)
!                             search for the rectangle
      call binsch(zx,x,nx,ilx,iux)
      call binsch(zy,y,ny,ily,iuy)
      if((ilx.eq.iux).and.(ily.eq.iuy))  go to 10
      if((ilx.eq.iux).and.(ily.ne.iuy))  go to 20
      if((ilx.ne.iux).and.(ily.eq.iuy))  go to 30
      go to 40
!                             return exact value or nearest corner point
   10 fxy = f(ilx,ily)
      go to 50
!                             x exact, perform linear interpolation on
!                             y
   20 sm = (f(ilx,ily) - f(ilx,iuy))/(y(ily) - y(iuy))
      fxy = sm*(zy - y(ily)) + f(ilx,ily)
      go to 50
!                             y exact, perform linear interpolation on
!                             x
   30 sm = (f(ilx,ily) - f(iux,ily))/(x(ilx) - x(iux))
      fxy = sm*(zx - x(ilx)) + f(ilx,ily)
      go to 50
!                             perform linear interpolation on x and y
   40 sxl = (f(ilx,ily) - f(iux,ily))/(x(ilx) - x(iux))
      fxl = sxl*(zx - x(ilx)) + f(ilx,ily)
      sxu = (f(ilx,iuy) - f(iux,iuy))/(x(ilx) - x(iux))
      fxu = sxu*(zx - x(ilx)) + f(ilx,iuy)
      sm = (fxl - fxu)/(y(ily) - y(iuy))
      fxy = sm*(zy - y(ily)) + fxl
   50 return
      END subroutine intp2
! **deck intpnt
      subroutine intpnt(p,q,c,   pint,intf)
      implicit double precision (a-h,o-z)
!
!     purpose: compute the point of intersection of a line segment
!              with a plane defined by its normalized coefficients
!              c(1), c(2), c(3), c(4)
!
!     inputs:  p, q     points in space
!              c        coefficients of a plane where
!                       c(1), c(2), c(3) are direction cosines
!                       of the normal to the plane and
!                       c(4) is (+ve) distance from the origin to the
!                       plane in the direction of the normal
!
!     outputs: pint     point of intersection of line segment with plane
!              intf     flag to indicate if intersection with plane
!                       occurs within line segment
!
      dimension p(3), q(3)
      dimension c(4)
      dimension pint(3)
!
      logical   intf
!
      dis(pt1,pt2,pt3,cf1,cf2,cf3,cf4) =                                &
     &       pt1*cf1 + pt2*cf2 + pt3*cf3 - cf4
      data tol / 1.0d-6 /
!
!     initialize the intersection flag, intf, to .false. where,
!       intf = .true.    means intersection did occur within segment
!       intf = .false.   means intersection did not occur
!
      intf = .false.
!
!     initialize intersection point 'pint' and number of points in plane
!
      pint(1) = 0.d0
      pint(2) = 0.d0
      pint(3) = 0.d0
!
      px   = p(1)
      py   = p(2)
      pz   = p(3)
!
      qx   = q(1)
      qy   = q(2)
      qz   = q(3)
!
!     test whether the input points are coincident
!
      tstval = sqrt ( (px-qx)**2+(py-qy)**2+(pz-qz)**2 )
      if ( .not. (tstval .le. tol ) ) go to 100
!
!     since the points are coincident, are they in the plane
!
      d = dis(p(1),p(2),p(3),c(1),c(2),c(3),c(4))
      if ( .not. ( abs( d ) .le. tol ) )    go to 999
!
      intf    = .true.
      pint(1) = px
      pint(2) = py
      pint(3) = pz
      go to 999
!
  100 denom= (qx - px) * c(1) + (qy - py) * c(2) + (qz - pz) * c(3)
!
!     test the denominator to see if the points lie in the plane
!
      if ( .not. ( abs ( denom ) .le. tol )) go to 200
!
      d = dis(p(1),p(2),p(3),c(1),c(2),c(3),c(4))
      if ( .not. ( abs(d) .le. tol ) ) go to 999
!
!
!     the points do lie in the plane
!
      intf    = .true.
      pint(1) = -9999.d0
      pint(2) = -9999.d0
      pint(3) = -9999.d0
      go to 999
!
  200 tau  = ( c(4) - ( px*c(1) + py*c(2) + pz*c(3) )) / denom
!
!     check to see whether there is an intersection between the two
!     points p and q.  if so, set intf to .true.
!
!     if ( .not. (tau .le. 1.0 .and. tau .ge. 0.0 )) go to 999
      if ( .not. (tau .le. 1.d0+tol  .and.                              &
     &            tau .ge. -tol  )) go to 999
      if( abs( tau - 1.d0 ) .le. tol ) tau = 1.d0
      if( abs( tau       ) .le. tol ) tau = 0.d0
      intf = .true.
      pint(1)  = px + tau * ( qx - px )
      pint(2)  = py + tau * ( qy - py )
      pint(3)  = pz + tau * ( qz - pz )
!
  999 return
      END subroutine intpnt
! **deck inxcmt
      subroutine inxcmt (lun,ier,line)
      implicit double precision (a-h,o-z)
      character*80 line
!
!     read a line from unit lun, excluding comment lines (= or ! in c.1)
!
      nline   =  0
  100 continue
      read (lun,6001,end=500) line
      nline   =  nline + 1
 6001 format (a80)
      if ( line(1:1) .eq. '='  .or.  line(1:1)  .eq. '!' ) goto 100
      ier     =  0
      return
!                                      end-of-file before data found
  500 continue
      ier     =  1
      write (6,6002) lun, nline
 6002 format(' inxcmt: failure to read, unit =',i5,'  no. of tries:',i5)
      write (6,6003) line
 6003 format (a)
      return
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'inxcmt', 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('inxcmt',' program failure due to ill-formatted data')
      return
!
!
      END subroutine inxcmt
! **deck iorfn
      integer function iorfn (ipos,jpos)
!
!     evaluate  ipos .or. jpos  for  0  <=  ipos,jpos  <=  3
!
      dimension kor(0:3,0:3)
      data kor  / 0,1,2,3                                               &
     &         ,  1,1,3,3                                               &
     &         ,  2,3,2,3                                               &
     &         ,  3,3,3,3 /
!
      if ( ipos.lt.0 .or. ipos.gt.3 ) goto 500
      if ( jpos.lt.0 .or. jpos.gt.3 ) goto 500
!
      iorfn  =  kor(ipos,jpos)
      return
!
  500 continue
      write (6,'( '' bad  (ipos,jpos) passed to iorfn:'',2i10)')        &
     &     ipos, jpos
      call remarx (' bad data passed to iorfn ')
      CALL AbortPanair('iorfn')
      return
      END function iorfn
! **deck iscal
      subroutine iscal(cp,ics)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  flag triangular panel                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  identify collapsed edge if any using routine pident          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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        argument  input     four panel corner points in   *
!     *                                 counter-clockwise order       *
!     *                                                               *
!     *   ics       argument  output    =0 - no collapsed edge        *
!     *                                 =number of collapsed edge     *
!     *                                  otherwise                    *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      logical ident
      dimension cp(3,4)
      do 500 is=1,4
      isp1=mod(is,4)+1
      ics=is
      call pident(cp(1,is),cp(1,isp1),ident)
      if(ident) go to 950
  500 continue
      ics=0
  950 return
      END subroutine iscal
! **deck ishel2
      subroutine ishel2 (n,a,key)
      implicit double precision (a-h,o-z)
!c
!     ishel2 sorts an integer array a(n) that is actually 4*n words
!     in length. each set of four words is addressed by a single
!     index into the array: 4*i-3, 4*i-2, 4*i-1 and 4*i.
!     this array structure was formed when the 4 integer per word
!     packed structure was unraveled in the conversion of a502 to
!     unicos cray-2 at nasa-ames.
!
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   ishell 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 * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   ishell 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  a(4*n), key(n), asv
!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
!
!     update the increment, m, and test for completion
!
  100 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 do 160 i=1,4
      if ( a(4*ia-4+i) .lt. a(4*iap-4+i) ) go to 200
      if ( a(4*ia-4+i) .eq. a(4*iap-4+i) ) go to 160
        do 155 k=1,4
        asv           =  a(4*ia-4+k)
        a(4*ia-4+k)   =  a(4*iap-4+k)
  155   a(4*iap-4+k)  =  asv
!
        asv     =  key(ia)
        key(ia) =  key(iap)
        key(iap)=  asv
!
        iap     =  ia
        ia      =  ia - m
        if ( ia.gt.0 ) go to 150
        go to 200
  160 continue
  200 continue
!c
!     go on to the next value for the increment m
!
      go to 100
      END subroutine ishel2
! **deck isitin
      subroutine isitin(p1,p2,p3,c,p,   iedgef,insidf)
      implicit double precision (a-h,o-z)
!
!     purpose: is it in?  determine whether point p lies within
!              triangle, or on a side, or outside
!
!     inputs:  p1,p2,p3 three points in space
!              c        coefficients of the plane through p1, p2, p3,
!                       where c(1), c(2), c(3) are direction cosines
!                       of the normal to the plane and
!                       c(4) is (+ve) distance from the origin to the
!                       plane in the direction of the normal
!
!              p        point intercepting the plane
!
!     outputs: insidf   flag to indicate point is inside triangle
!              iedgef   flag to indicate point on edge
!
      dimension p1(3),p2(3),p3(3)
      dimension c(4)
      dimension p(3)
      logical   iedgef,insidf
      data tol / 1.0d-6 /
!
!     initialize flags, insidf, to .false. where,
!       insidf = .true.    means point is inside triangle
!       insidf = .false.   means point is outside triangle
!
      insidf = .false.
      iedgef = .false.
!
      x1   = p1(1)
      y1   = p1(2)
      z1   = p1(3)
!
      x2   = p2(1)
      y2   = p2(2)
      z2   = p2(3)
!
      x3   = p3(1)
      y3   = p3(2)
      z3   = p3(3)
!
      x    = p(1)
      y    = p(2)
      z    = p(3)
!
      abar   = (   (y2-y1)*(z-z1) - (z2-z1)*(y-y1)   )
      bbar   = (   (z2-z1)*(x-x1) - (x2-x1)*(z-z1)   )
      cbar   = (   (x2-x1)*(y-y1) - (y2-y1)*(x-x1)   )
      q1     = c(1) * abar + c(2) * bbar + c(3) * cbar
!
      abar   = (   (y3-y2)*(z-z2) - (z3-z2)*(y-y2)   )
      bbar   = (   (z3-z2)*(x-x2) - (x3-x2)*(z-z2)   )
      cbar   = (   (x3-x2)*(y-y2) - (y3-y2)*(x-x2)   )
      q2     = c(1) * abar + c(2) * bbar + c(3) * cbar
!
      abar   = (   (y1-y3)*(z-z3) - (z1-z3)*(y-y3)   )
      bbar   = (   (z1-z3)*(x-x3) - (x1-x3)*(z-z3)   )
      cbar   = (   (x1-x3)*(y-y3) - (y1-y3)*(x-x3)   )
      q3     = c(1) * abar + c(2) * bbar + c(3) * cbar
!
      if ( .not. ( abs( q1*q2*q3 ) .le. tol ) ) go to 100
!
      if( .not. ( abs(q1) .le. tol )) go to 50
      if((x-x1)*(x2-x1)+(y-y1)*(y2-y1)+(z-z1)*(z2-z1) .le.              &
     &        0.d0 )  go to 50
      dpoint = sqrt( (x-x1)**2 + (y-y1)**2 + (z-z1)**2 )
      dcoord = sqrt( (x2-x1)**2+ (y2-y1)**2+ (z2-z1)**2)
      if( dpoint .le. dcoord ) iedgef = .true.
      go to 50
!
   50 if( .not. ( abs(q2) .le. tol ) ) go to 60
      if((x-x2)*(x3-x2)+(y-y2)*(y3-y2)+(z-z2)*(z3-z2) .le.              &
     &         0.d0 )  go to 60
      dpoint = sqrt( (x-x2)**2 + (y-y2)**2 + (z-z2)**2 )
      dcoord = sqrt( (x3-x2)**2+ (y3-y2)**2+ (z3-z2)**2)
      if( dpoint .le. dcoord ) iedgef = .true.
      go to 60
!
   60 if( .not. ( abs(q3) .le. tol ) ) go to 999
      if((x-x3)*(x1-x3)+(y-y3)*(y1-y3)+(z-z3)*(z1-z3) .le.              &
     &        0.d0 )  go to 999
      dpoint = sqrt( (x-x3)**2 + (y-y3)**2 + (z-z3)**2 )
      dcoord = sqrt( (x1-x3)**2+ (y1-y3)**2+ (z1-z3)**2)
      if( dpoint .le. dcoord ) iedgef = .true.
      go to 999
!
  100 if   (  ( q1 .gt. 0.d0 ) .and.                                    &
     &        ( q2 .gt. 0.d0 ) .and.                                    &
     &        ( q3 .gt. 0.d0 )         ) insidf = .true.
!
  999 return
      END subroutine isitin
! **deck istrns
      subroutine istrns(ip,pdq)
      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 store panel geometry and singularity strength defining    *
!     *  quantities                                                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the information is stored via writms                         *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   ip        argument  input     index identifying given panel *
!     *                                                               *
!     *   nis       /srwi/    input     index array for nts           *
!     *                                                               *
!     *   nns       /srwi/    input     length of nis                 *
!     *                                                               *
!     *   nsdq      /srwi/    input     number of panel defining      *
!     *                                 quantities per block          *
!     *                                                               *
!     *   nts       /srwi/    input     file on which panel defining  *
!     *                                 quantity blocks are stored    *
!     *                                                               *
!     *   pdq       argument input      panel defining quantity block *
!     *                                 for given panel ip            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 srwi
      common/srwi/nsdq,nss,nrs,nts,nns,nis(maxpan+1)
!end  srwi
      dimension pdq(1)
!c
!     *  the information is stored via writms                         *
!
      call writms(nts,pdq,nsdq,ip,-1,0)
      return
      END subroutine istrns
! **deck itewic
      subroutine itewic (tol,aa,bb,  aint,aint2,aerr,nfcn)
      implicit double precision (a-h,o-z)
      dimension aint(6), aint2(6), aerr(6)
!
!         perform the low level integrals associated with trailing edge
!         wake influence coefficients.  itewic performs the following
!         integrals along a wake panel trailing edge parameterized by
!         the variable tau. (in all calls, aa=0. and bb=1.)   the
!         algorithm is a recursive adaptive quadrature scheme based
!         on simpson's rule.  the local arrays dimensioned with the
!         parameter 'levmax' are used to manage the data associated
!         with the pushdown stack required for the recursion.
!
!         ( j(1:3) )   tau = bb ( phi(1:3)(tau) /[r*(r + xi'(tau) - x)]
!         ( j(4:6) ) = integral ( phi(1:3)(tau) /[   r + xi'(tau) - x ]
!                      tau = aa
!
!         tol     i   r*8   integration error tolerance
!         aa      i   r*8   initial value for tau
!         bb      i   r*8   final value for tau
!         aint    o   r*8   aint(1:5) = estimates for 5 required integra
!         aint2   o   r*8   aint2(1:5) = estimates for 5 req'd integrals
!                           obtained using half the the step size of ain
!         err     o   r*8   estimate of the error in the aint2 estimates
!         nfcn    i/o int   increased by the number of function evaluati
!                           required for this call
!
!         common input:
!         cpl     i   r*8   initial point on the req'd edge of the wake,
!                           local coordinate system for the wake filamen
!         dcpl    i   r*8   edge vector on the req'd edge of the wake,
!                           local coordinate system for the wake filamen
!         zl      i   r*8   control point location,
!                           local coordinate system for the wake filamen
!
!         michael epton, 30 november 1988
!
      parameter (levmax=15)
!
      dimension a(levmax), b(levmax), h(levmax), ind(levmax)
      dimension x(5,levmax), f(6,5,levmax), s(6), s2(6)
      dimension phi(3)
!call ktewic
      common /ktewic/ cpl(3), dcpl(3), zl(3)
!end  ktewic
!
      integer top, recur, nxtlev, nxtind, done
      logical writn
!
      writn   =  .false.
      p166    =  1.d0/6.d0
      p33     =  1.d0/3.d0
      p66     =  2.d0/3.d0
      p0833   =  1.d0/12.d0
!                                  initialize top level of recursion
      call dcopy (6,  0.d0,0,  aint,1)
      call dcopy (6,  0.d0,0,  aint2,1)
      lev     =  1
      a(lev)  =  aa
      b(lev)  =  bb
      h(lev)  =  b(lev) - a(lev)
      x(1,lev)=        aa
      x(2,lev)=  .75d0*aa + .25d0*bb
      x(3,lev)=  .50d0*aa + .50d0*bb
      x(4,lev)=  .25d0*aa + .75d0*bb
      x(5,lev)=                   bb
      do 10 k = 1,5
!-----------------------------------------------
          tau     =  x(k,lev)
!
          phi(1)  =  2.d0*(tau-.5d0)*(tau-1.d0)
          phi(2)  =  4.d0*tau*(1.d0-tau)
          phi(3)  =  2.d0*tau*(tau-.5d0)
!
          ximx    =  cpl(1) - zl(1) + tau*dcpl(1)
          etmy    =  cpl(2) - zl(2) + tau*dcpl(2)
          ztmz    =  cpl(3) - zl(3)
          r       =  sqrt( ximx**2 + etmy**2 + ztmz**2 )
          fab     =  1.d0/( r*(r+ximx)  )
          if ( ximx .gt. 0.d0 ) then
             fa      =  1.d0/( r+ximx )
          else
             fa      =  (r-ximx)/( etmy**2 + ztmz**2 )
          endif
          fab     =  fa/r
!
          f(1,k,lev)  =  fab*phi(1)
          f(2,k,lev)  =  fab*phi(2)
          f(3,k,lev)  =  fab*phi(3)
          f(4,k,lev)  =  fa*phi(1)
          f(5,k,lev)  =  fa*phi(2)
          f(6,k,lev)  =  fa*phi(3)
!------------------------------------------------
          nfcn    =  nfcn + 1
   10 continue
!
! top
  100 continue
!                                  perform quadrature at level  lev  and
!                                  estimate accuracy
      dsnm    =  0.d0
      do 110 i = 1,6
          s(i)    =  h(lev)*( p166 *f(i,1,lev)                          &
     &                       +p66  *f(i,3,lev)                          &
     &                       +p166 *f(i,5,lev) )
!
          s2(i)   =  h(lev)*( p0833*f(i,1,lev)                          &
     &                       +p33  *f(i,2,lev)                          &
     &                       +p166 *f(i,3,lev)                          &
     &                       +p33  *f(i,4,lev)                          &
     &                       +p0833*f(i,5,lev) )
          dsnm    =   max ( dsnm, abs(s(i)-s2(i))  )
!----     write (6,6004) lev,ind(lev),a(lev),b(lev),h(lev),s(i),s2(i)
  110 continue
!                                  if error budget not met, go deeper (3
      if ( lev.eq.levmax ) then
         if ( .not.writn )                                              &
     & write (6,'( '' ===== levmax hit '',2e12.4)') x(1,lev),x(2,lev)
         writn = .true.
         goto 115
      endif
      if ( dsnm*.066667d0*h(1) .gt. tol*h(lev) ) go to 300
  115 continue
!                                  looks good: accumulate
          do 120 i = 1,6
               aint2(i)=  aint2(i) + s2(i)
               aint(i) =  aint(i) + s(i)
  120     continue
!                                  increment loop index at current level
!                                  and pop stack (possibly more than onc
! recur
  200     continue
          if ( lev.eq.1 ) go to 500
          ind(lev) = ind(lev) + 1
          if ( ind(lev).le.1 ) go to 400
               lev     =  lev - 1
               go to 200
!                                  increase recursion level and initiali
!                                  loop index at the new level
! nxtlev
  300 continue
          lev     =  lev + 1
          if ( lev.gt.levmax ) go to 1000
          ind(lev)=  0
! nxtind
  400     continue
!                                  let the quadrature at level  lev
!                                  inherit appropriate data from level
!                                  lev-1
               ix      =  2*ind(lev)
               x(1,lev)=  x(1+ix,lev-1)
               x(3,lev)=  x(2+ix,lev-1)
               x(5,lev)=  x(3+ix,lev-1)
!
               a(lev)  =  x(1,lev)
               b(lev)  =  x(5,lev)
               h(lev)  =  .5d0*h(lev-1)
!                                  function value inheritance
               do 420 i = 1,6
                    f(i,1,lev)=  f(i,1+ix,lev-1)
                    f(i,3,lev)=  f(i,2+ix,lev-1)
                    f(i,5,lev)=  f(i,3+ix,lev-1)
  420          continue
!                                  generate required new function values
!                                  new recursion level
               do 450 k = 2,4,2
                    x(k,lev) = .5d0*( x(k-1,lev) + x(k+1,lev) )
!-----------------------------------------------
                    tau     =  x(k,lev)
!
                    phi(1)  =  2.d0*(tau-.5d0)*(tau-1.d0)
                    phi(2)  =  4.d0*tau*(1.d0-tau)
                    phi(3)  =  2.d0*tau*(tau-.5d0)
!
                    ximx    =  cpl(1) - zl(1) + tau*dcpl(1)
                    etmy    =  cpl(2) - zl(2) + tau*dcpl(2)
                    ztmz    =  cpl(3) - zl(3)
                    r       =  sqrt( ximx**2 + etmy**2 + ztmz**2 )
                    fab     =  1.d0/( r*(r+ximx)  )
!
                    f(1,k,lev)  =  fab*phi(1)
                    f(2,k,lev)  =  fab*phi(2)
                    f(3,k,lev)  =  fab*phi(3)
                    fa          =  1.d0/( r+ximx )
                    f(4,k,lev)  =  fa*phi(1)
                    f(5,k,lev)  =  fa*phi(2)
                    f(6,k,lev)  =  fa*phi(3)
!
!------------------------------------------------
                    nfcn    =  nfcn + 1
  450          continue
               go to 100
! done
  500 continue
!
      do 510 i = 1,6
          aerr(i) = ( aint2(i) - aint(i) )/15.d0
  510 continue
!
      return
!
!
!
 1000 continue
      write (6,6001) aa,bb
 6001 format (' level count exceeds levmax in itewic.  aa,bb:',2f12.6)
 6004 format (' level:',i3,'  ind:',i2,'  a,b:',2f12.6,'  h:',f12.6     &
     &  ,'  s,s2',2f12.9)
      CALL AbortPanair('itewic')
      END subroutine itewic
! **deck itrns
      subroutine itrns(q,s,nq,ns,nr,nt,ni,i)
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  accumulate data blocks in a buffer until a new buffer is     *
!     *  required. buffer is then written to disk via random io.      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   i         argument  input     sequence number of the data   *
!     *                                 block to store                *
!     *   k         -local-   - - - -   record number data block is in*
!     *                                                               *
!     *                                                               *
!     *   l         -local-   - - - -   position within buffer to     *
!     *                                 insert data block             *
!     *                                                               *
!     *   ni        argument  input     index array for records on nt *
!     *                                                               *
!     *   nq        argument  input     length of data block          *
!     *                                                               *
!     *   nr        argument  in/output record number currently in    *
!     *                                 buffer (= - for modified      *
!     *                                 records and = + for unmodified*
!     *                                 records).                     *
!     *                                                               *
!     *   ns        argument  input     number of data blocks to      *
!     *                                 store in buffer before it is  *
!     *                                 full                          *
!     *                                                               *
!     *   nt        argument  input     i/o device to write buffer to *
!     *                                 when it is full               *
!     *                                                               *
!     *   q         argument  input     block of data to be stored    *
!     *                                                               *
!     *   s         argument  in/out    buffer to hold data in        *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      logical gh1,gh2,gh3,gh4
      integer rewrit
      integer q(nq), s(nq,ns), ni(1:*)
!c
!     *  calculate record number and data block number within record  *
!
      k = (i-1)/ns+1
      l = i-ns*(k-1)
      key = iabs(nr)
      gh1 = k.eq.key.or.key.eq.0
!c
!     *  if record is already in buffer then do not read record       *
!
      if(gh1) go to 100
      gh2 = nr.gt.0
!c
!     *  if record currently in buffer has not been modified then     *
!     *  do not re-write record                                       *
!
      if(gh2) go to 50
      gh3 = ni(key).ne.0
      if(gh3) go to 25
      rewrit = 0
      go to 30
   25 continue
      rewrit = 1
   30 continue
      length = nq*ns
      length=64*((length+63)/64)
!c
!     *  write old record if new record is to be created or modified  *
!
      call writms(nt,s(1,1),length,key,rewrit,0)
      if ( ni(key).eq.0  ) ni(key) = 1
   50 continue
      gh4 = ni(k).ne.0
      if(.not.gh4) go to 80
      length = nq*ns
      length=64*((length+63)/64)
!c
!     *  read record to be modified if not already in core            *
!
      call readms(nt,s(1,1),length,k)
   80 continue
  100 continue
!c
!     *  transfer data block into buffer                              *
!
      call icopy (nq,  q,1,  s(1,l),1)
      nr = -k
      return
      END subroutine itrns
! **deck ivtrns
      subroutine ivtrns (jc,ne,dvdfs)
      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 store influence coefficient array for given control point *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the information is stored via  writms. for the case ne=1     *
!     *  potential influence coefficients are assumed to be in        *
!     *  consecutive order beginning with the first element of dvdfs  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                 *
!     *                                                               *
!     *   dvdfs     argument  output    control point influence       *
!     *                                 coefficient array             *
!     *                                                               *
!     *  ne         -local-   - - - -   number of components of       *
!     *                                 influence coefficients stored *
!     *                                 for given control point       *
!     *                                 =0 no influence coefficients  *
!     *                                 stored                        *
!     *                                 =1 only potential influence   *
!     *                                    coefficients are stored    *
!     *                                 =4 both potential and velocity*
!     *                                    influence coefficients are *
!     *                                    stored                     *
!     *                                                               *
!     *   niv       /vrwi/    input     index array for ntv           *
!     *                                                               *
!     *   nnv       /vrwi/    input     length of niv                 *
!     *                                                               *
!     *   ntv       /vrwi/    input     file on which control point   *
!     *                                 influence coefficient arrays  *
!     *                                 are stored                    *
!     *                                                               *
!     *   nvdq      /vrwi/    input     number of singularity         *
!     *                                 parameters influencing control*
!     *                                 point                         *
!     *                                                               *
!     *   nwpr      -local-   - - - -   total number of influence     *
!     *                                 coefficients per record       *
!     *                                                               *
!     *   nwv       /vrwi/    input     array containing number of    *
!     *                                 components (0 thru 4) of      *
!     *                                 influence coefficients stored *
!     *                                 for each 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 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 vrwi
      common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp)
!end  vrwi
      dimension dvdfs(1)
!c
!     *  if no influence coefficients are to be stored for ths        *
!     *  control point then return                                    *
!
      if(ne.eq.0) go to 900
!c
!     *  calculate number of influence coefficients to be stored      *
!
      nwpr    =  ityprc*ne*nvdq
!c
!     *  the information is stored via writms                         *
!
      call writmd(ntv,dvdfs,nwpr,jc,-1,0)
  900 return
      END subroutine ivtrns
! **deck ixtrns
      subroutine ixtrns (irec,iar,lth)
      implicit double precision (a-h,o-z)
      dimension iar(1:*)
!call xrwi
      common /xrwi/ ntxrwi, nnxrwi, nwxrwi(200), nixrwi(202)
!end  xrwi
      nwxrwi(irec) = lth
      lthx    =  lth
      if ( lth.le.0 ) then
       write (7,'('' ixtrns called with lth.le.0, irec:'',2i6)')irec,lth
       lthx = 1
      endif
      call writms (ntxrwi,iar,lthx,irec,-1,0)
      return
      END subroutine ixtrns
! **deck iytrns
      subroutine iytrns (irec,iar,lth)
      implicit double precision (a-h,o-z)
      dimension iar(*)
!
!         write a record of data to unit  ntyrwi,  a random unit with
!         control information in /yrwi/
!
!         irec    i   int   index of record to write
!         iar     i   int   iar(1:lth) is the data to be written
!         lth     i   int   number of data items to be written
!
!         michael epton, 30 november 1988
!
!         limitations: don't write more records than allowed by /yrwi/ d
!                      allocations
!
!call yrwi
      common /yrwi/ ntyrwi, nnyrwi, nwyrwi(200), niyrwi(202)
!end  yrwi
      nwyrwi(irec) = lth
      call writmd (ntyrwi,iar,lth,irec,-1,0)
      return
      END subroutine iytrns
! **deck izamax
      integer function izamax (n,  y,iy)
      implicit double precision (a-h,o-z)
      dimension y(n)
      complex*16 y
!
!        standard blas izamax
!
      izamax = 0
      if ( n.le.0 ) return
      ly      =  1
      if ( iy.le.0 ) ly = ly + iabs(iy)*(n-1)
      imax    =  1
      ymax    =  abs(y(ly))
      do 100 k = 1,n
                                            ! was cdabs
          if ( ymax.lt. ABS(y(ly)) ) then
               imax = k
                                            ! was cdabs
               ymax = ABS(y(ly))
          endif
          ly      =  ly + iy
  100 continue
      izamax  =  imax
      return
      END Function izamax
! **deck jshell
      subroutine jshell (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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   jshell 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 * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   jshell 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  a(n), key(n), asv
!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
!
          asv     =  key(ia)
          key(ia) =  key(iap)
          key(iap)=  asv
!
          iap     =  ia
          ia      =  ia - m
          if ( ia.gt.0 ) go to 150
  200 continue
!c
!     *   go on to the next value for the increment m                 *
!
      go to 100
      END subroutine jshell
! **deck jzero
      subroutine jzero (a,n)
      implicit double precision (a-h,o-z)
!
!         zero an integer array: stupid interface to be used for convers
!         method: use the vectorpack routine scopy; change during conver
!
!         a       o   int   array to be zeroed
!         n       i   int   number of zeroes to put in
!
!         michael epton, 30 november 1988
!
      integer a(n)
      do 10 k = 1,n
   10 a(k) = 0
      return
      END subroutine jzero
! **deck keysrd
      subroutine keysrd (n,a,key)
      implicit double precision (a-h,o-z)
!          apply the permutation array key to the d.p. input array a
!          so that on output:
!                                a[out](i) = a[in](key(i))
      dimension a(n), key(n)
!
      icyc    =  1
      if ( n.le.0 ) return
!     *   find an unprocessed cycle                                   *
   10 continue
      if ( key(icyc) .gt. 0 ) go to 40
      icyc    =  icyc + 1
      if ( icyc .le. n ) go to 10
!     *   restore the signs in the key array and return               *
      do 20 i = 1,n
   20 key(i)  =  -key(i)
      return
!     *   beginning at location icyc, update this cycle of the        *
!     *   permutation until   key(key(...(key(icyc))...)) = icyc      *
   40 continue
      i       =  icyc
      asv     =  a(i)
      go to 60
!
   50 a(i)    =  a(ik)
      i       =  ik
   60 ik      =  key(i)
      key(i)  =  -ik
      if ( ik.ne.icyc ) go to 50
!     *   set last element of the cycle equal to the original first   *
!     *   element and go on to the next cycle                         *
      a(i)    =  asv
      go to  10
      END subroutine keysrd
! **deck keysrt
      subroutine keysrt (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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   keysrt uses a permutation vector key to rearrange the       *
!     *   elements of an array  a  so that                            *
!     *             a(i)(new) = a(key(i))(old)                        *
!     *   keysrt may be used to bring an array a back into correspond-*
!     *   ence with a array that has been sorted.  when this is done  *
!     *   the key array must contain the original addresses of the    *
!     *   key array                                                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   keysrt rearranges the elements of a by threading its way    *
!     *   through the cycles of the permutation key.   cycles in key  *
!     *   that have already been processed are flagged by setting     *
!     *   the corresponding elements in key negative.                 *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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    the array to be permuted      *
!     *                                                               *
!     *   asv       local     - - - -   a save area for the first     *
!     *                                 element of a cycle in the     *
!     *                                 unpermuted array  a           *
!     *                                                               *
!     *   i         local     - - - -   index of element in a that is *
!     *                                 about to be updated           *
!     *                                                               *
!     *   ik        local     - - - -   location in a that is used to *
!     *                                 update a(i).  a(i) = a(ik)    *
!     *                                                               *
!     *   icyc      local     - - - -   smallest address in the cycle *
!     *                                 currently being processed     *
!     *                                                               *
!     *   key       argument  input     a permutation array           *
!     *                                                               *
!     *   n         argument input      number of entries in the      *
!     *                                 arrays  a and key             *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
      integer a(n), asv, key(n)
      icyc    =  1
      if ( n.le.0 ) return
!c    *                                                               *
!     *   find an unprocessed cycle                                   *
!     *                                                               *
   10 continue
      if ( key(icyc) .gt. 0 ) go to 40
      icyc    =  icyc + 1
      if ( icyc .le. n ) go to 10
!c    *                                                               *
!     *   restore the signs in the key array and return               *
!     *                                                               *
      do 20 i = 1,n
   20 key(i)  =  -key(i)
      return
!c    *                                                               *
!     *   beginning at location icyc, update this cycle of the        *
!     *   permutation until   key(key(...(key(icyc))...)) = icyc      *
!     *                                                               *
   40 continue
      i       =  icyc
      asv     =  a(i)
      go to 60
!
   50 a(i)    =  a(ik)
      i       =  ik
   60 ik      =  key(i)
      key(i)  =  -ik
      if ( ik.ne.icyc ) go to 50
!c    *                                                               *
!     *   set last element of the cycle equal to the original first   *
!     *   element and go on to the next cycle                         *
!     *                                                               *
      a(i)    =  asv
      go to  10
      END subroutine keysrt
! **deck kmp2gd
      subroutine kmp2gd (kmp,  nedmpa,  knet,ig,jg)
      implicit double precision (a-h,o-z)
      dimension nedmpa(601)
!
!     given an edge meshpoint index (kmp) compute the network index
!     knet and the grid point indices (ig,jg).
!
!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
!
      nind    =  4*nnett + 1
!                                   nedmpa(kedg) < kmp <= nedmpa(kedg+1)
      call ibsrch (nedmpa,nind,kmp,kedg)
      if ( kedg.le.0 .or. kedg.ge.nind ) then
         write (6,'( '' bad kmp value: '',2i10)') kmp,nnett
         call outvci ('nedmpa',nind,nedmpa)
         call abtend ('kmp2gd: kmp value out of range ')
      endif
      call mnmod (kedg,4,ksd,knet)
      kpt     =  kmp - nedmpa(kedg)
      call edg2gd (kpt,ksd,  nm(knet),nn(knet),  ig,jg)
      return
      END subroutine kmp2gd
! **deck labort
      subroutine labort (n,nmax,label)
      implicit double precision (a-h,o-z)
      character*(*) label
      character*50 xmsg
!
      write (6,6001) label
 6001 format ('0  *** execution terminated due to limit on ',a40)
      write (6,6002) n,nmax
 6002 format ('       number requested by user =',i10/                  &
     &        '                  program limit =',i10)
      xmsg(1:10) = 'limit abt:'
      xmsg(11:50)= label
      call remarx (xmsg)
      stop
      END subroutine labort
! **deck lchvar
      subroutine lchvar (v,x0,dx,idim,inc)
      implicit double precision (a-h,o-z)
!         perform a linear change of variables -  x = x0 + dx*tau - on
!         a vector  v(0:idim) = lin. functional ( tau**i, i=0:idim )
      dimension     v(1)
      last    =  1 + idim
!                                  for id = idim,idim-1,...,1
      do 100 idbk = 1,idim
      id      =  1 + idim - idbk
          lstinc  =  last+inc
          do 50 j = 1,id
               v(lstinc+1-j) =  dx*v(last+1-j) + x0*v(last-j)
   50     continue
          last    =  lstinc
  100 continue
      return
      END subroutine lchvar
! **deck legndr
      subroutine legndr (n,x,p,pd)
      implicit double precision (a-h,o-z)
!
!         evaluate the legendre polynomials of degrees (0:n+1) and
!         the corresponding derivatives
!
      dimension p(n), pd(n)
!
      p(1)  =  1.d0
      pd(1) =  0.d0
      p(2)  =  x
      pd(2) =  1.d0
!
      np2   =  n+2
      do 100 kp2 = 3,np2
          k      =  kp2 - 2
          ak     =  k
          ak1    =  k+1
          alf    =  (2*k+1)/ak1
          beta   =  ak/ak1
          p(kp2) =  alf*x*p(k+1) - beta*p(k)
          pd(kp2)=  alf*x*pd(k+1)- beta*pd(k) + alf*p(k+1)
  100 continue
      return
      END subroutine legndr
! **deck limval
      subroutine limval( k, zk, nmk, nnk, icoor )
      implicit double precision (a-h,o-z)
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     * determine minimum and maximum x, y, z coordinate limits of    *
!     * single network                                                *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * *  m e t h o d  * * *                   *
!     *                          - - - - - -                          *
!     *                                                               *
!     * construct the array xyzlim having max and min array for x,y,z *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!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                   *
!     *                                                               *
!     *   icoor               input     coordinate for which to       *
!     *                                 determine limits: 1=x,2=y,3=z *
!     *                                                               *
!     *   k                   input     network number                *
!     *                                                               *
!     *   nmk                 input     number of rows                *
!     *                                                               *
!     *   nnk                 input     number of columns             *
!     *                                                               *
!     *   xyzlim    /secprp/  output    x,y,z minimum and maximum     *
!     *                                 values                        *
!     *                                                               *
!     *   zk                  input     network 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 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 secscr
      common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin  &
     &             , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2)
!end  secscr
!
      dimension zk(3,nmk,nnk)
!
          valmax = zk( icoor,1,1 )
          valmin = zk( icoor,1,1 )
!
          do 150, i = 1,nmk
            do 149, j = 1,nnk
              valmin =  min ( valmin, zk(icoor,i,j) )
              valmax =  max ( valmax, zk(icoor,i,j) )
  149       continue
  150     continue
!
          xyzlim( k,icoor,1 ) = valmin
          xyzlim( k,icoor,2 ) = valmax
      END subroutine limval
! **deck ljbf10
      subroutine ljbf10 (a)
      implicit double precision (a-h,o-z)
      character*10 a,b,c
      character*1 blk
!
!         take the 10 column character string  'a', left justify it, bla
!
      blk = ' '
      c  =  a
      kb = 0
      do 100 ka = 1,10
          if ( a(ka:ka).eq.blk ) goto 100
               kb = kb+1
               b(kb:kb) = a(ka:ka)
  100 continue
      a = b
      kb = kb+1
      do 200 ka = kb,10
          a(ka:ka) = blk
  200 continue
!
!
! *** write (6,6001) c,a
 6001 format ('  ===ljbf10 call.  in=',a10,3x,'out=',a10)
      return
      END subroutine ljbf10

! **deck locfcn
      FUNCTION locfcn(ia) RESULT(k)
! ----------------------------------------------------------------------
!!!      IMPLICIT NONE
      INTEGER ia(*)
!      locfcn  =  POINTER( ia(1) )
      INTEGER:: k
      INTRINSIC:: LOC

      k = LOC(ia(1))
      return
      END Function Locfcn !-----------------------------------------------------
! **deck lproj
      subroutine lproj(a,r0,b,c)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  project given point onto plane preserving distance to a      *
!     *  specified point on plane                                     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  first form the vector from the specified point on plane to   *
!     *  given point. project this vector onto plane and then scale   *
!     *  it back to original length.                                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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     normal to plane               *
!     *                                                               *
!     *   b         argument  input     given point                   *
!     *                                                               *
!     *   c         argument  output    resultant projected point     *
!     *                                                               *
!     *   d         -local-   - - - -   direction of projection       *
!     *                                                               *
!     *   r0        argument  input     specified point on plane      *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension a(3),r0(3),b(3),c(3),d(3)
!c
!     *  form vector from specified point on plane to given point     *
!
      call vadd(b,-1.d0,r0,c,3)
      call mag(c,cmag)
!c
!     *  project vector onto plane                                    *
!
      call proj(c,a,d)
      call uvect(d)
!c
!     *  scale to original length                                     *
!
      call mxm(cmag,1,d,1,c,3)
      call vadd(c,1.d0,r0,c,3)
      return
      END subroutine lproj
! **deck lsqsf
      subroutine lsqsf
      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 solve a rectangular system of equations by the weighted   *
!     *  least squares method                                         *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the system of equations to be formed are defined by          *
!     *       [a] [x] = [b], where [a] has fewer columns than rows.   *
!     *  this system is solved by forming the least squares normal    *
!     *  weighted system                                              *
!     *       [a] transpose [w] [a] [x] = [a] transpose [w] [b], where*
!     *  [w] is the diagonal weighting matrix.  this system is square,*
!     *  symmetric, positive-definite.  the latter system is solved   *
!     *  via the symmetric decomposition routine sqroot.              *
!     *  the matrix [a] is set up in this routine using the functions *
!     *  (1,x,y) for the linear fit, and (1,x,y,x**2/2,y**2/2,xy) for *
!     *  the quadratic fit                                            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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/  output    least-square solution         *
!     *                                                               *
!     *   b         -local-   - - - -   scratch array for             *
!     *                                 holding least square normal   *
!     *                                 equations                     *
!     *                                                               *
!     *   c         -local-   - - - -   scratch array for holding     *
!     *                                 right hand side               *
!     *                                                               *
!     *   ni        -local-   - - - -   order of problem              *
!     *                                 (3 for linear, 6 for          *
!     *                                 quadratic)                    *
!     *                                                               *
!     *   no        /lsqsfc/  input     order of least-square fit     *
!     *                                 (one or two)                  *
!     *                                                               *
!     *   npk       /lsqfc/   input     number of corner points in    *
!     *                                 the network                   *
!     *                                                               *
!     *   v         -local-   - - - -   scratch array used for        *
!     *                                 holding [a] and [x]           *
!     *                                                               *
!     *   wtk       /lsqsfc/  input     least-square weights          *
!     *                                                               *
!     *   zk        /lsqsfc/  input     corner points of panel network*
!     *                                 zk(1,i)  is x(i)              *
!     *                                 zk(2,i)  is y(i)              *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                      * * * n o t e * * *                      *
!     *                            - - - -                            *
!     *                                                               *
!     *  this routine has been set to do the least square inverse     *
!     *  ([b]=[i])                                                    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call lsqsfc
!                                                            /lsqsfc/
      common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk
!end  lsqsfc
!call sginvc
!                                                            /sginvc/
      common /sginvc/ eps,tol,q(6),v(96),b(36),qp(6),irank,mrank
!end  sginvc
      dimension c(16,6)
      data mr,mc /16,6/
!c
!     *  determine problem order                                      *
!
      ni=6
      if((no.lt.2).or.(npk.lt.4)) ni=3
      if((no.lt.1).or.(npk.lt.2)) ni=1
!c
!     *  form [a] and multiply by the diagonal weights matrix         *
!     *  loop ranges over number of points in least-square fit        *
!
      do 250 k=1,npk
      l=ni*(k-1)
      v(l+1)=1.d0
      if(ni.lt.2) go to 200
      v(l+2)=zk(1,k)
      v(l+3)=zk(2,k)
      if(ni.lt.4) go to 200
      v(l+4)=.5d0*zk(1,k)*zk(1,k)
      v(l+5)=zk(1,k)*zk(2,k)
      v(l+6)=.5d0*zk(2,k)*zk(2,k)
  200 continue
!c
!     *  multiply by the diagonal weights matrix                      *
!
      do 225 i=1,ni
      l=i+ni*(k-1)
      c(k,i) = wtk(k)*v(l)
  225 continue
  250 continue
!c
!     *  store the solution vector in matrix form                     *
!
      call zero(ak,6*npk)
!
!     *  use generalized inverse routine                              *
!
      mrank = ni
      call sginvx (c,mr,mc,npk,ni,ak)
      do 499 k=1,npk
      do 450 i=1,ni
      ak(i,k) = ak(i,k)*wtk(k)
  450 continue
  499 continue
      return
      END subroutine lsqsf
! **deck lsqsg
      subroutine lsqsg
      implicit double precision (a-h,o-z)
!         lsqsg computes just the first row of the pseudoinverse of
!         the matrix  c  defined by the   295  loop.  thus it is
!         more efficient for this particular application than  lsqsf
!***created  on 76.056    w.o. no.   0   version        ftj.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to solve a rectangular system of equations by the weighted   *
!     *  least squares method                                         *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the system of equations to be formed are defined by          *
!     *       [a] [x] = [b], where [a] has fewer columns than rows.   *
!     *  this system is solved by forming the least squares normal    *
!     *  weighted system                                              *
!     *       [a] transpose [w] [a] [x] = [a] transpose [w] [b], where*
!     *  [w] is the diagonal weighting matrix.  this system is square,*
!     *  symmetric, positive-definite.  the latter system is solved   *
!     *  via the symmetric decomposition routine sqroot.              *
!     *  the matrix [a] is set up in this routine using the functions *
!     *  (1,x,y) for the linear fit, and (1,x,y,x**2/2,y**2/2,xy) for *
!     *  the quadratic fit                                            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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/  output    least-square solution         *
!     *                                                               *
!     *   b         -local-   - - - -   scratch array for             *
!     *                                 holding least square normal   *
!     *                                 equations                     *
!     *                                                               *
!     *   c         -local-   - - - -   scratch array for holding     *
!     *                                 right hand side               *
!     *                                                               *
!     *   ni        -local-   - - - -   order of problem              *
!     *                                 (3 for linear, 6 for          *
!     *                                 quadratic)                    *
!     *                                                               *
!     *   no        /lsqsfc/  input     order of least-square fit     *
!     *                                 (one or two)                  *
!     *                                                               *
!     *   npk       /lsqfc/   input     number of corner points in    *
!     *                                 the network                   *
!     *                                                               *
!     *   v         -local-   - - - -   scratch array used for        *
!     *                                 holding [a] and [x]           *
!     *                                                               *
!     *   wtk       /lsqsfc/  input     least-square weights          *
!     *                                                               *
!     *   zk        /lsqsfc/  input     corner points of panel network*
!     *                                 zk(1,i)  is x(i)              *
!     *                                 zk(2,i)  is y(i)              *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                      * * * n o t e * * *                      *
!     *                            - - - -                            *
!     *                                                               *
!     *  this routine has been set to do the least square inverse     *
!     *  ([b]=[i])                                                    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call lsqsfc
!                                                            /lsqsfc/
      common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk
!end  lsqsfc
!call sginvc
!                                                            /sginvc/
      common /sginvc/ eps,tol,q(6),v(96),b(36),qp(6),irank,mrank
!end  sginvc
!                                  get the  qrp  factorization of  c
      dimension  d(6), sa(6), jq(6)
      equivalence (d,q), (sa,qp), (jq,b)
      dimension c(16,6)
      data mr,mc /16,6/
!c
!     *  determine problem order                                      *
!
      ni=6
      if((no.lt.2).or.(npk.lt.4)) ni=3
      if((no.lt.1).or.(npk.lt.2)) ni=1
!c
!     *  form [a] and multiply by the diagonal weights matrix         *
!     *  loop ranges over number of points in least-square fit        *
!
      do 250 k=1,npk
      l=ni*(k-1)
      v(l+1)=1.d0
      if(ni.lt.2) go to 200
      v(l+2)=zk(1,k)
      v(l+3)=zk(2,k)
      if(ni.lt.4) go to 200
      v(l+4)=.5d0*zk(1,k)*zk(1,k)
      v(l+5)=zk(1,k)*zk(2,k)
      v(l+6)=.5d0*zk(2,k)*zk(2,k)
  200 continue
!c
!     *  multiply by the diagonal weights matrix                      *
!
      do 225 i=1,ni
      l=i+ni*(k-1)
      c(k,i) = wtk(k)*v(l)
  225 continue
  250 continue
!c
!     *  store the solution vector in matrix form                     *
!
      call zero(ak,6*npk)
      call dcbht (c,d,sa,jq,mr,npk,ni)
!                                  note:   a  =  q * r * p
!                                         a+  =  p(t)*(rh(-1),0)*q(t)
!                                       a+(t) =  q * ( rh(-t) ) * p
!                                                    (    0   )
!                                  we want   a+(t) * e(1)
!
!                                  find k such that  p*e(1) = e(k)
      do 300 j = 1,ni
          k       =  j
          if ( jq(j).eq.1 ) go to 310
  300 continue
      call uabend
  310 continue
!                                  apply rh(-t) to  e(k),  get v
      call zero (v,npk)
      v(k)    =  1.d0/d(k)
      kp1     =  k+1
      if ( kp1.gt.ni ) go to 360
      do 350 i = kp1,ni
          zed=ddot(i-k,v(k),1,c(k,i),1)
          v(i)    =  -zed/d(i)
  350 continue
  360 continue
!                                  apply  q = h(1)*h(2)*   *h(ni) to v
      do 400 kb = 1,ni
          k       =  ni+1-kb
          zed=ddot(npk+1-k,v(k),1,c(k,k),1)
          zed     =  zed/( c(k,k)*d(k) )
          call vadd (v(k),zed,c(k,k),v(k),npk+1-k)
  400 continue
!                                  apply weights
      do 500 k = 1,npk
  500 ak(1,k) =  v(k)*wtk(k)
      return
      END subroutine lsqsg
! **deck mag
      subroutine mag(a,amag)
      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 magnitude of a vector with 3 components            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   magnitude is calculated as square root of sum of squares of *
!     *   components                                                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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     vector with 3 components      *
!     *                                                               *
!     *   amag      argument  output    magnitude of a                *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension a(3)
      amag=sqrt(a(1)*a(1)+a(2)*a(2)+a(3)*a(3))
      return
      END subroutine mag
! **deck matvfs
      subroutine matvfs (ttmat,tpmat,vfsair                             &
     &                  ,rmat,vfmat,wfmat,cpfmat,vfsmat)
      implicit double precision (a-h,o-z)
      dimension vfsair(3), vfsmat(3)
!
!         calculate the material free-stream vector for a substance havi
!         total temperature  ttmat  and total pressure  tpmat,  given th
!         free-stream vector is  vfsair(1:3).   this routine also
!         returns the  r-coefficient used in pressure calculations
!
!         ttmat   i   r*8   total temperature ratio for the substance
!         tpmat   i   r*8   total pressure ratio for the substance
!         vfsair  i   r*8   vfsair(1:3) = free stream velocity in 'air',
!                           substance 0.
!         rmat    o   r*8   total density ratio
!         vfmat   o   r*8   ratio of free stream velocity magnitude in
!                           current substance to the value in air
!         wfmat   o   r*8   ratio of free stream massflux magnitude in
!                           current substance to the value in air
!         cpfmat  o   r*8   product of vfmat*wfmat, used in computing
!                           the pressure coefficient in the current subs
!         vfsmat  o   r*8   vfsmat(1:3) = free stream velocity in the cu
!                           substance.
!
!         michael epton, 30 november 1988
!
!
!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
      data gm /1.4d0/
!
!                                  set low mach number defaults
      rmat    =  1.d0
      vfmat   =  1.d0
      wfmat   =  1.d0
      cpfmat  =  1.d0
      call dcopy (3,  vfsair,1,  vfsmat,1)
      if ( amach.lt.(.01d0) ) goto 900
      amach2  =  amach**2
      betasq  =  abs(1.d0-amach2)
      qsqair  =  vfsair(1)**2 +vfsair(2)**2 +vfsair(3)**2
      vxair   =  compd(1)*vfsair(1) +compd(2)*vfsair(2)                 &
     &                              +compd(3)*vfsair(3)
!                                  put transverse components into vfsmat
      f0      =  tpmat**( (1.d0-gm)/gm )
      rmat    =  1.d0/(f0*ttmat)
      rinv    =  1.d0/rmat
!                                  calculate qsqmat and back out transve
!                                  components to get component in compd
      qsqmat  =  qsqair*2.d0*ttmat*( 1.d0 +.5d0*(gm-1.d0)*amach2 -f0) / &
     &                                            ( (gm-1.d0)*amach2 )
      vfmat   =  sqrt( qsqmat/qsqair )
      wfmat   =  rmat*vfmat
      cpfmat  =  vfmat*wfmat
      vfsmat(1) = vfmat*vfsair(1)
      vfsmat(2) = vfmat*vfsair(2)
      vfsmat(3) = vfmat*vfsair(3)
!
  900 continue
      return
      END subroutine matvfs
! **deck maxcor
      subroutine maxcor
!
!         print current maxima for dynamic cm package
!
!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,6300) mxxlev, maxlev, mxxlws, maxlws, mxxdyn, maxdyn
 6300 format (//,1x,100(1h*),//,                                        &
     &  '  dynamic memory summary    ', '      used',2x,' allocated',/, &
     &  '  maximum number of levels  ',i10,2x,i10 ,/,                   &
     &  '  maximum number of arrays  ',i10,2x,i10 ,/,                   &
     &  '  maximum dynamic memory    ',i10,2x,i10 ,/,                   &
     &  /,1x,100(1h*) )
      return
      END subroutine maxcor
! **deck mccopy
      subroutine mccopy (m,n,  a,ia,ja,  b,ib,jb)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1)
      complex*16 a, b
!         copy the comples matrix a to the complex matrix b
      la      =  1
      lb      =  1
      if ( n.gt.m ) go to 500
      do 100 j = 1,n
          laij    =  la
          lbij    =  lb
          do 50 i = 1,m
               b(lbij) = a(laij)
               lbij    =  lbij + ib
               laij    =  laij + ia
   50     continue
          la      =  la + ja
          lb      =  lb + jb
  100 continue
      go to 950
!
  500 continue
      do 600 i = 1,m
          laij    =  la
          lbij    =  lb
          do 550 j = 1,n
               b(lbij) =  a(laij)
               lbij    =  lbij + jb
               laij    =  laij + ja
  550     continue
          la      =  la + ia
          lb      =  lb + ib
  600 continue
!
  950 continue
      return
      END subroutine mccopy
! **deck mcopy
      subroutine mcopy (m,n,  a,ia,ja,  b,ib,jb)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1)
!         copy the matrix a to the matrix b
      la      =  1
      lb      =  1
      if ( n.gt.m ) go to 500
      do 100 j = 1,n
          laij    =  la
          lbij    =  lb
          do 50 i = 1,m
               b(lbij) = a(laij)
               lbij    =  lbij + ib
               laij    =  laij + ia
   50     continue
          la      =  la + ja
          lb      =  lb + jb
  100 continue
      go to 950
!
  500 continue
      do 600 i = 1,m
          laij    =  la
          lbij    =  lb
          do 550 j = 1,n
               b(lbij) =  a(laij)
               lbij    =  lbij + jb
               laij    =  laij + ja
  550     continue
          la      =  la + ia
          lb      =  lb + ib
  600 continue
!
  950 continue
      return
      END subroutine mcopy
! **deck meshp
      subroutine meshp(k,ipter,amnsw,dnsmsh)
      implicit double precision (a-h,o-z)
      character*90 qline
!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 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
!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
!call iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
!call nwprnt
      common /nwprnt/ imnwpr
      logical imnwpr
!end  nwprnt
!call inp3
      common /inp3/ ntsin,ntsout
!end  inp3
!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 nwlst
      common /cnwlst/ nwname(mxnett)
      character*10 nwname
      common /anwlst/ nnwlst
!end  nwlst
      logical wkat, wknew
      dimension dum(6)
      character*10 chdum(6)
!            poi qua got *** tra cam cir ell
      go to (100,200,300,450,400,500,410,420), ipter
!
! $poi
!
  100 continue
      read (ntsin,'( a )') qline
      read(qline,5060,err=9950) dum, iduser(k)
      write(6,4070) k, dum, iduser(k)
 4070 format(5x,25hnetwork # being processed,i4,1x,6f10.4,5x,a,/)
!
!                             check for the correct card
!
!                             if dum(3)-dum(6) are non zero there is an
!                                error.
!
      do 110 i = 3,4
      ndum=dum(i)
      if(ndum.ne.0)go to 6010
  110 continue
      a=dum(1)
      b=dum(2)
 5060 format(6e10.0,10x,a)
 5061 format (6a10,10x,a10)
 5062 format (f10.0)
 5070 format (6e10.0)
      m = a
      n = b
      nm(k) = m
      nn(k) = n
      nz    = nm(k) * nn(k)
      nza(k+1) = nza(k) + nz
      l = nza(k)
      do 150 j=1,n
      do 140 i1 = 1,m,2
         i2      =  min(m,i1+1)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950)                                     &
     &                        (zm(1,l+i),zm(2,l+i),zm(3,l+i),i=i1,i2)
  140 continue
      l = l + m
  150 continue
      go to 1000
!
! $qua
!
  200 continue
      read (ntsin,'( a )') qline
      read(qline,5065,err=9950) ( sc(1,j), sc(2,j), sc(3,j), j=1,2),    &
     &            iduser(k)
 5065 format( 6e10.0, 10x, a )
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950) ( sc(1,j), sc(2,j), sc(3,j), j=3,4)
      write(6, 5075) k,  iduser(k)
 5075 format(5x,25hnetwork # being processed,i4,66x,a,/)
!
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dummy
      nrow = dummy
      nm(k) = nrow
      do 220 i1 = 1,nrow,6
         i2      =  min(nrow,i1+5)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (ypc(i),i=i1,i2)
  220 continue
!
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dummy
      ncol = dummy
      nn(k) = ncol
      do 230 j1 = 1,ncol,6
         j2      =  min(ncol,j1+5)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (xpc(j),j=j1,j2)
  230 continue
!
      nz    = nm(k) * nn(k)
      nza(k+1) = nza(k) + nz
!
      call quadnt(k,nrow,ncol)
      go to 1000
!
! $got
!
  300 continue
      read (ntsin,'( a )') qline
      read (qline,5060,err=9950) dum, iduser(k)
      dummy   =  dum(1)
      write(6, 5075) k,  iduser(k)
      ncol = dummy
      nn(k) = ncol
      do 310 j1 = 1,ncol,2
         j2      =  min(ncol,j1+1)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (sc(1,j),sc(2,j),sc(3,j),j=j1,j2)
  310 continue
!
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dummy
      nrow = dummy
      nm(k) = nrow
      do 320 i1 = 1,nrow,6
         i2      =  min(nrow,i1+5)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (ypc(i),i=i1,i2)
  320 continue
!
      nz    = nm(k) * nn(k)
      nza(k+1) = nza(k) + nz
!
      read (ntsin,'( a )') qline
      read (qline,5070,err=9950) dummy
      ncen = dummy
      call gadnet(k,nrow,ncol,ncen)
      go to 1000
!
! $tra
!
  400 continue
      read (ntsin,'( a )') qline
      read (qline,5061,err=9950) chdum, iduser(k)
      call nwindx (k,  chdum(1),inat)
      a       =  inat
      read (chdum(2),5062) b
      read (chdum(3),5062) xwake
      read (chdum(4),5062) twake
 5072 format(4e10.0,30x,2a5)
      write(6, 5075) k, iduser(k)
      inat = a
      insd = b
      wkat =  ntd(inat).eq.6 .or. ntd(inat).eq.18 .or. ntd(inat).eq.20
      wknew=     ntd(k).eq.6 .or.    ntd(k).eq.18 .or.    ntd(k).eq.20
      if ( wkat .and. (insd.ne.3) .and. wknew ) then
          write (6,6240) k,nwname(k),ntd(k)                             &
     &                  ,inat,nwname(inat),ntd(inat),insd
          call a502ms ('trwake'                                         &
     &           ,'wake nw '//nwname(k)//' improperly attached')
      endif
 6240 format (                                                          &
     &   ' network',i3,' (',a10,', a wake with doublet type',i3,')'     &
     &  ,' cannot be attached to '                                      &
     &,/,' network',i3,' (',a10,', a wake with doublet type',i3,')'     &
     &  ,' on edge',i3,'.  it must be attached to edge 3.'              &
     &,/,' before changing this, make sure that edge 3 of network',i3   &
     &  ,' is truly a trailing edge'                                    &
     & )
      call trwake (k,xwake,twake)
      go to 1000
!
  450 go to 1000
!
! $cir circular sections
!
  410 continue
      call circ(k)
      go to 1000
!
! $ell  elliptical sections.
!
  420 continue
      call ellpt(k)
      go to 1000
!
!
!
!     $cam
!
  500 continue
      read (ntsin,'( a )') qline
      read (qline,5060,err=9950) dum, iduser(k)
      ntrl    =  dum(1)
      if (ntrl.eq.1) go to 510
      if (ntrl.eq.2) go to 520
      go to 6120
!
  510 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)dummy,dum1,amnsw
      ncen=dum1
      npct = dummy
      do 514 j1 = 1,npct,6
         j2      =  min(npct,j1+5)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (xpc(j),j=j1,j2)
  514 continue
      do 516 i1 = 1,npct,6
         i2      =  min(npct,i1+5)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (zpc(i,1),i=i1,i2)
  516 continue
      nyst = 0
      nzap1=nza(k)+1
      if ( amnsw .eq. 1.d0 ) call mtrxtr (zm(1,nzap1),nm(k),nn(k),3)
      call camber (k,npct,nyst,ncen,ntrl)
      go to 1000
!
  520 continue
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)a,dum1,amnsw,b
      ncen=dum1
      npct = a
      nyst = b
      do 521 j1 = 1,npct,6
         j2      =  min(npct,j1+5)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (xpc(j),j=j1,j2)
  521 continue
      do 525 i=1,nyst
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)ypc(i)
      do 523 j1 = 1,npct,6
         j2      =   min(npct,j1+5)
         read (ntsin,'( a )') qline
         read (qline,5070,err=9950) (zpc(i,j),j=j1,j2)
  523 continue
  525 continue
      nzap1=nza(k)+1
      if ( amnsw .eq. 1.d0 ) call mtrxtr (zm(1,nzap1),nm(k),nn(k),3)
      call camber (k,npct,nyst,ncen,ntrl)
!
 1000 nzap1 = nza(k) + 1
      if ( amnsw .eq. 1.d0 ) call mtrxtr (zm(1,nzap1),nm(k),nn(k),3)
      if(dnsmsh.eq.0.d0)go to 9000
      read (ntsin,'( a )') qline
      read(qline,5070,err=9950)akn,akm
      kn=akn
      km=akm
      call mshdns(zm(1,nzap1),nm(k),nn(k),km,kn)
      nza(k+1)=nza(k)+nm(k)*nn(k)
      go to 9000
!
!          error exit
!
!
!                             program exit due to improper input to
!                               points preprocessor.
!
 6010 continue
      write(6,7010)k
 7010 format(//,5x,24herror in column/row card,                         &
     &27h while processing network #,i4)
 6120 write (6,7120) ntrl
 7120 format(//5x,'--- cntrl =',i3,' is not an option under cambered ' &
     &,'wing preprocessor ($cam) ---')
      stop
!
 9000 continue
      if ( .not.imnwpr ) go to 9900
!                                  print the geometry immediately per re
      write (6,'(1x,a10,1x,  i12)')                                     &
     & 'network',k
      call outmvc ('mesh pts',nm(k),nm(k),nn(k),zm(1,nzap1))
 9900 continue
      return
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'meshp', 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('meshp',' program failure due to ill-formatted data')
      return
!
      END subroutine meshp
! **deck mnmod
      subroutine mnmod(i,nm,m,n)
      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 perform the modulus operation m = i mod nm, and n=i/nm    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   i         argument  input     first argument for modulus    *
!     *                                                               *
!     *   m         argument  output    i mod nm                      *
!     *                                                               *
!     *   nm        argument  input     second argument for modulus   *
!     *                                                               *
!     *   n         argument  output    i/nm (integer divide)         *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      n=(i-1)/nm+1
      m=i-nm*(n-1)
      return
      END subroutine mnmod
! **deck mpnorm
      subroutine mpnorm ( z1, z2, z3, z4, en)
      implicit double precision (a-h,o-z)
      dimension z1(3), z2(3), z3(3), z4(3), en(3)
      dimension ps(3), pt(3)
!         compute the mean plane panel normal given the 4 corner points
      do 10 i = 1,3
          ps(i) = .25d0*( z4(i) + z1(i) - z2(i) - z3(i) )
          pt(i) = .25d0*( z1(i) + z2(i) - z3(i) - z4(i) )
   10 continue
      call cross (ps,pt,en)
      call uvect (en)
      return
      END subroutine mpnorm
! **deck mpnrml
      subroutine mpnrml (z,m,n,  en)
      implicit double precision (a-h,o-z)
      dimension z(3,m,n), en(3)
!
!     compute the (un-normalized) mean panel normal for a panel
!
      dimension u(3), v(3)
!
      do 100 l = 1,3
         u(l) = z(l,1,2) + z(l,2,2) - z(l,2,1) - z(l,1,1)
         v(l) = z(l,2,1) + z(l,2,2) - z(l,1,2) - z(l,1,1)
  100 continue
      call cross (u,v,en)
      call dscal (3,  .25d0,  en,1)
      return
      END subroutine mpnrml
! **deck mpteqc
      subroutine mpteqc (kpt,npt,  ix,jx)
      implicit double precision (a-h,o-z)
      dimension  kpt(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) then
          call abtend ('fatal error in mpteqc, 1')
      endif
!
      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
      go to 950
!                                  kpt(ix) $ ix,  kpt(jx) = jx
  200 continue
      kpt(ix) =  kpt(jx)
      kpt(jx) =  ix
      go to 950
!                                  kpt(ix) = ix,  kpt(jx) $ jx
  300 continue
      kpt(jx) = kpt(ix)
      kpt(ix) = jx
!                                  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
!
      kptsv   =  kpt(jx)
      kpt(jx) =  kpt(ix)
      kpt(ix) =  kptsv
!
  950 continue
      return
!
 1200 continue
      call abtend ('looping error in mpteqc')
      return
      END subroutine mpteqc
! **deck mshdns
      subroutine mshdns(zm,nm,nn,mf,nf)
      implicit double precision (a-h,o-z)
      dimension zm(3,1)
      character*2 ichm, ichn
      if ( mf.ne.0  .and.  nf.ne.0 ) go to 50
          write (6,6001) mf, nf
          go to 90
!
   50 continue
      nmx     =  mf*(nm-1) + 1
      nnx     =  nf*(nn-1) + 1
      if ( mf.lt.0 ) nmx = -(nm-1)/mf + 1
      if ( nf.lt.0 ) nnx = -(nn-1)/nf + 1
      ichm    =  '  '
      ichn    =  '  '
      if ( mf.lt.0 ) ichm = '1/'
      if ( nf.lt.0 ) ichn = '1/'
      nmi     =  nm
      nni     =  nn
      mfa     =  iabs(mf)
      nfa     =  iabs(nf)
      write (6,6002) nmi,ichm,mfa,nmx,  nni,ichn,nfa,nnx
      call outmvc ('z input',nm,nm,nn,zm)
   90 continue
      l=nm*nn
      iret=0
      mfp=mf
      nfp=nf
      if((mf.lt.-1).and.(nf.gt.1)) nfp=1
      if((mf.gt.1).and.(nf.lt.-1)) mfp=1
  100 continue
      nnp=nfp*(nn-1)+1
      if(nfp.lt.0) nnp=-(nn-1)/nfp+1
      nmp=mfp*(nm-1)+1
      if(mfp.lt.0) nmp=-(nm-1)/mfp+1
      if((nfp.le.0).and.(nn.ne.(1-nfp*(nnp-1)))) go to 910
      if((mfp.le.0).and.(nm.ne.(1-mfp*(nmp-1)))) go to 910
      nl=nm*nn
      nlp=nmp*nnp
      maxnl=max (nl,nlp)
      write(6,1002) mfp,nfp,nmp,nnp,nl,nlp,maxnl
      do 350 lpr=1,nlp
      lp=nlp-lpr+1
      call mnmod(lp,nmp,mp,np)
      m=1-mfp*(mp-1)
      if(mfp.gt.0) m=1+(mp-1)/mfp
      n=1-nfp*(np-1)
      if(nfp.gt.0) n=1+(np-1)/nfp
      mp1=min (m+1,nm)
      np1=min (n+1,nn)
      l=maxnl-nlp+lp
      s=1.d0
      t=1.d0
      aaanum   =  (1-mp+m*mfp)
      aaaden   =  (mfp)
      if(mfp.gt.0) t=aaanum/aaaden
      aaanum   =  (1-np+n*nfp)
      aaaden   =  (nfp)
      if(nfp.gt.0) s=aaanum/aaaden
      l1=m+nm*(n-1)
      l2=m+nm*(np1-1)
      l3=mp1+nm*(np1-1)
      l4=mp1+nm*(n-1)
      do 300 i=1,3
  300 zm(i,l)=s*t*zm(i,l1)+t*(1.d0-s)*zm(i,l2)                          &
     &        +(1.d0-s)*(1.d0-t)*zm(i,l3)                               &
     &+s*(1.d0-t)*zm(i,l4)
  350 continue
      do 850 lp=1,nlp
      l=maxnl-nlp+lp
      do 800 i=1,3
  800 zm(i,lp)=zm(i,l)
  850 continue
      nm=nmp
      nn=nnp
      write(6,1001) ((zm(iw,jw),iw=1,3),jw=1,nlp)
 1001 format(1x,10e13.5)
      if((mf.eq.mfp).and.(nf.eq.nfp)) go to 900
      if(iret.eq.1) go to 900
      iret=1
      mfp=mf+1-mfp
      nfp=nf+1-nfp
      go to 100
  900 continue
      write (6,6003) nmi,ichm,mfa,nmx,  nni,ichn,nfa,nnx
      call outmvc ('z output',nm,nm,nn,zm)
      return
!
!
!
  910 write(6,9100) nm,nn,mf,nf,nmp,nnp
 9100 format(//,1x,21herror in mshdns, nm =,i5,5x,4hnn =,i5,5x,4hmf =,  &
     &i5,5x,4hnf =,i5,5x,5hnmp =,i5,5x,5hnnp =,i5)
      stop
 1002 format(' row factor= ',i4,' column factor= ',i4,                  &
     &          ' original # grid pts= ',i4,/,                          &
     &          ' new # rows= ',i4,' new # columns= ',i4,               &
     &          ' new # grid pts= ',5x,i4,                              &
     &          ' max(new,old)= ',i4)
 6001 format ('0 *** warning ***   a zero scale factor was passed to msh&
     &dns.   mf,nf = ',2i5 )
 6002 format ('0  mesh refinement call at   i n p u t  '                &
     & ,/,'   no. rows input: ',i5,'   row densing factor: ',a2,i3      &
     &   ,'   no. rows output: ',i5                                     &
     & ,/,'   no. cols input: ',i5,'   col densing factor: ',a2,i3      &
     &   ,'   no. cols output: ',i5                                     &
     &   )
 6003 format ('0  mesh refinement call at   o u t p u t  '              &
     & ,/,'   no. rows input: ',i5,'   row densing factor: ',a2,i3      &
     &   ,'   no. rows output: ',i5                                     &
     & ,/,'   no. cols input: ',i5,'   col densing factor: ',a2,i3      &
     &   ,'   no. cols output: ',i5                                     &
     &   )
      END subroutine mshdns
! **deck mshind
      subroutine  mshind(isd,iz,in,nm,nn,l)
      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 network index of mesh point given its indices      *
!     *  along and normal to a specified side. index along side runs  *
!     *  from first corner to second corner of side. orientation of   *
!     *  sides and corners is counterclockwise around network (side 3,*
!     *  for example, runs from mesh point (nm,nn) to mesh point      *
!     *  (nm,1)). the index normal to side runs from side to opposite *
!     *  side. the network index is the usual cumulative index based  *
!     *  on counting rows in each column.                             *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   in        argument  input     index of point normal to side *
!     *                                                               *
!     *   isd       argument  input     specified side of network     *
!     *                                                               *
!     *   iz        argument  input     index of point along side     *
!     *                                                               *
!     *   izmax     -local-   - - - -   number of points along side   *
!     *                                                               *
!     *   izmin     -local-   - - - -   number of points in direction *
!     *                                 normal to side                *
!     *                                                               *
!     *   l         argument  output    network index of mesh point   *
!     *                                                               *
!     *   nm        argument  input     number of rows of mesh points *
!     *                                                               *
!     *   nn        argument  input     number of columns of mesh     *
!     *                                 points                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      call mnmod(isd,2,misd,nisd)
      izmax=nn*(2-misd)+nm*(misd-1)
      izmin=nm*(2-misd)+nn*(misd-1)
      icd=nisd-1
      izf=in+(izmin-2*in+1)*iabs(misd-nisd)
      izr=iz+icd*(izmax+1-2*iz)
      m=izf*(2-misd)+izr*(misd-1)
      n=izr*(2-misd)+izf*(misd-1)
      l=m+nm*(n-1)
      return
      END subroutine mshind
! **deck mspnt1
      subroutine mspnt1
      implicit double precision (a-h,o-z)
!
!     this routine puts the network geometry on file -mspnt1-
!
!     command to obtain the geometry is -call mspnt1-  after
!     all the geometry is input in the input subroutine.
!
!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 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 datchk
!                                                            /datchk/
      common/datchk/ndtchk
!end  datchk
!call titles
      common /titles/ title1(20),title2(20)
      character*4 title1, title2
!end  titles
!call iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
!
      character*4 a1,a2,a3
      data  iout /77/
      data a1,a2,a3 /'sour','geom','case'/
!
      close(unit=iout)
      open(unit=iout,file='mspnt1',form='formatted')
      a=1.d0
      write(iout,5090) a3
      write(iout,5090) title1, title2
      write(iout,5090) a2
      write(iout,1000) a
      write(iout,5090) a1
!
      a=nnett
      if ( nstmln.ne.0  .and.  ndtchk.eq.0 ) a = nnett + numpts
      write(iout,1000)a
      l1=1
      do 100 k=1,nnett
      m=nm(k)
      n=nn(k)
      a=m
      b=n
      write(iout,1004)a,b,iduser(k)
      do 200 j=1,n
      l2=l1+m-1
!
      inlims = 0
      do 300 ni=l1,l2
      do 275 njj=1,3
      if((zm(njj,ni) .lt.   -999.99999d0)                               &
     &               .or.                                               &
     &   (zm(njj,ni) .gt.   9999.99999d0))inlims = 1
      if((zm(njj,ni) .lt.  -9999.99999d0)                               &
     &               .or.                                               &
     &   (zm(njj,ni) .gt.  99999.99999d0))inlims = 2
      if((zm(njj,ni) .lt. -99999.9999d0)                                &
     &               .or.                                               &
     &   (zm(njj,ni) .gt. 999999.9999d0)) inlims = 3
  275 continue
  300 continue
!
      if(inlims .eq. 0)then
         write(iout,1000)((zm(jj,i), jj=1,3), i=l1,l2)
      elseif(inlims .eq. 1)then
         write(iout,1001)((zm(jj,i), jj=1,3), i=l1,l2)
      elseif(inlims .eq. 2)then
         write(iout,1002)((zm(jj,i), jj=1,3), i=l1,l2)
      elseif(inlims .eq. 3)then
         write(iout,1003)((zm(jj,i), jj=1,3), i=l1,l2)
      endif
!
  200 l1=l1+m
  100 continue
!
!
 1000 format(6f10.4)
 1001 format(6f10.3)
 1002 format(6f10.2)
 1003 format(1p,6e10.3)
 1004 format(2f10.5,50x,a)
 5090 format(20a4)
!
      return
      END subroutine mspnt1
! **deck msrotm
      subroutine msrotm(zm,nm,nn,m,n,amr)
      implicit double precision (a-h,o-z)
!***created  on 76.010    w.o. no.   0   version        ftj.00
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to define a local tangent plane coordinate system at a       *
!     *  network grid point                                           *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  msrotm constructs a local tangent plane coordinate system    *
!     *  at a given grid point of the network.  the coordinate        *
!     *  transformation is defined by (q) =[amr] ((p)-(zm(m,n))),     *
!     *  where (p) is a vector expressed in global coordinates, and   *
!     *  (q) is the same vector expressed in local coordinates, the   *
!     *  origin of the local coordinate system is (zm(m,n)) - the grid*
!     *  point corresponding to the indices m and n.  the local kse   *
!     *  and eta axes are defined by differencing neighboring grid    *
!     *  points, and the local zeta axis then approximates the surface*
!     *  normal                                                       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   amrt      -local-   - - - -   inverse of amr                *
!     *                                                               *
!     *   amr       argument  output    required rotation matrix      *
!     *                                 defining tangental plane      *
!     *                                                               *
!     *   l         -local-   - - - -   index of loop over degrees of *
!     *                                 freedom                       *
!     *                                                               *
!     *   mm1       -local-   - - - -   index of adjacent grid point  *
!     *                                                               *
!     *   mpi       -local-   - - - -   index of adjacent grid point  *
!     *                                                               *
!     *   m         argument  input     row index of grid point       *
!     *                                                               *
!     *   nm1       -local-   - - - -   index of adjacent grid point  *
!     *                                                               *
!     *   nm        argument  input     number of rows of grid points *
!     *                                                               *
!     *   nn        argument  input     number of columns of          *
!     *                                 grid points                   *
!     *                                                               *
!     *   np1       -local-   - - - -   index of adjacent grid point  *
!     *                                                               *
!     *   n         argument  input     column index of grid point    *
!     *                                                               *
!     *   u         -local-   - - - -   first distinct vector in      *
!     *                                 tangent plane                 *
!     *                                                               *
!     *   v         -local-   - - - -   second distinct vector in     *
!     *                                 tangent plane                 *
!     *                                                               *
!     *   zm        argument  input     coordinates of network        *
!     *                                 grid points                   *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension zm(3,nm,nn),amr(9)
      dimension u(3),v(3),w(3),amrt(9)
      equivalence (u(1),amrt(1)), (v(1),amrt(4)), (w(1),amrt(7))
!c
!     *  define indices of adjacent grid points                       *
!
      mm1=max (1,m-1)
      mp1=min (nm,m+1)
      nm1=max (1,n-1)
      np1=min (nn,n+1)
!c
!     *  define two distinct vectors in the tangent plane             *
!
!c
!     *  loop ranges over the components of (u) and (v)               *
!
      do 100 l=1,3
      u(l)=.125d0*(zm(l,mm1,np1)+2.d0*zm(l,m,np1)+zm(l,mp1,np1)         &
     &-zm(l,mm1,nm1)-2.d0*zm(l,m,nm1)-zm(l,mp1,nm1))
      v(l)=.125d0*(zm(l,mp1,nm1)+2.d0*zm(l,mp1,n)+zm(l,mp1,np1)         &
     &-zm(l,mm1,nm1)-2.d0*zm(l,mm1,n)-zm(l,mm1,np1))
  100 continue
!c
!     *  (u) cross (v) gives vector normal to panel                   *
!
      call cross(u,v,w)
!c
!     *  ((u) cross (v)) cross (u) gives vector normal to (u)         *
!     *  in plane                                                     *
!
      call cross(w,u,v)
!c
!     *  (u),(v), and (w) are orthogonal vectors defining bases of    *
!     *  tangential plane - normalize them to produce the inverse of  *
!     *  the required rotation matrix                                 *
!
      call uvect(u)
      call uvect(v)
      call uvect(w)
!c
!     *  inverse of matrix is its transpose                           *
!
      call trans(amrt,amr,3,3)
      return
      END subroutine msrotm
! **deck mtrxtp
      subroutine mtrxtp (iar,m,n, l)
      integer iar(l,m,n)
      parameter (nscr=5000)
      integer iscr(nscr)
!
!         transpose a matrix in place
!
      mn      =  m*n
      if (mn.gt.nscr) then
         write (6, '( ''  mtrxtp error, reqd scratch:'',i7,'' avail:''  &
     &                ,i7)'  )  mn,nscr
         call a502er ('mtrxtp',' inadequate scratch space ')
      endif
!
      do 100 il = 1,l
!
         do 20 j = 1,n
            call icopy (m,  iar(il,1,j),l,  iscr(j),n)
   20    continue
         call icopy (m*n,  iscr,1,  iar(il,1,1),l)
  100 continue
      msv = m
      m   = n
      n   = msv
      return
      END subroutine mtrxtp
! **deck mtrxtr
      subroutine mtrxtr (ar,m,n, l)
      implicit double precision (a-h,o-z)
      dimension ar(l,m,n)
!
!         transpose a matrix of real vectors in place
!
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
!
      mn      =  m*n
      call setcor ('mtrxtr')
      call getcor ('scr',llscr,mn)
!
      do 100 il = 1,l
!
         do 20 j = 1,n
            call dcopy (m,  ar(il,1,j),l,  w(llscr+j-1),n)
   20    continue
         call dcopy (m*n,  w(llscr),1,  ar(il,1,1),l)
  100 continue
      msv = m
      m   = n
      n   = msv
!
      call frecor ('mtrxtr')
      return
      END subroutine mtrxtr
! **deck mul3x3
      subroutine mul3x3 (a,b,c,  n,  na,nb,nc)
      implicit double precision (a-h,o-z)
      dimension a(na,3), b(nb,1), x(3)
      dimension c(nc,1)
      if ( n.le.0 ) return
      do 100 j = 1,n
          x(1) = a(1,1)*b(1,j) +a(1,2)*b(2,j) +a(1,3)*b(3,j)
          x(2) = a(2,1)*b(1,j) +a(2,2)*b(2,j) +a(2,3)*b(3,j)
          x(3) = a(3,1)*b(1,j) +a(3,2)*b(2,j) +a(3,3)*b(3,j)
          c(1,j)  =  x(1)
          c(2,j)  =  x(2)
          c(3,j)  =  x(3)
  100 continue
      return
      END subroutine mul3x3
! **deck mxm
      subroutine mxm (a,m,b,l,c,n)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
!
!         perform   c <--  a * b  with all inputs having standard addres
!                  m,l    m,l l,n
!
      ia  =  1
      ja  =  m
!
      ib  =  1
      jb  =  l
!
      ic  =  1
      jc  =  m
! --straight from mxma--
!                                  perform matrix-matrix multiplication
      lc1j    =  1
      lb1j    =  1
      call mzero (m,n,  c,ic,jc)
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) + a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine mxm
! **deck mxma
      subroutine mxma (a,ia,ja,  b,ib,jb,  c,ic,jc,  m,l,n)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
!
!         perform   c <-- c +  a * b  with all inputs having generic add
!                  m,l   m,l  m,l l,n
      lc1j    =  1
      lb1j    =  1
      call mzero (m,n,  c,ic,jc)
      do 300 j = 1,n
          la1k    =  1
          lbkj    =  lb1j
          do 200 k = 1,l
               blbkj   =   b(lbkj)
               lcij    =  lc1j
               laik    =  la1k
               do 100 i = 1,m
                    c(lcij)  = c(lcij) + a(laik)*blbkj
                    lcij     =  lcij + ic
                    laik     =  laik + ia
  100          continue
               la1k    =  la1k + ja
               lbkj    =  lbkj + ib
  200     continue
          lc1j    =  lc1j + jc
          lb1j    =  lb1j + jb
  300 continue
      return
      END subroutine mxma
! **deck mzero
      subroutine mzero (m,n,  a,ia,ja)
      implicit double precision (a-h,o-z)
      dimension a(1)
!
!         zero a matrix given with generic indexing info
!
      la1j    =  1
      do 100 j = 1,n
          laij    =  la1j
          do 50 i = 1,m
               a(laij) = 0.d0
               laij    =  laij + ia
   50     continue
          la1j    =  la1j + ja
  100 continue
      return
      END subroutine mzero
! **deck neghbr
      subroutine neghbr( nmk, nnk, ip,      neighs)
      implicit double precision (a-h,o-z)
!
!     purpose - find all possible neighbors ('neighs') of panel 'ip'
!
!     nmk
!          *       *       *       *
!              1       2       3
!    rows  *       * * * * *       *   panel numbering scheme around
!              4   *   5   *   6       subject panel (#5) for array
!          *       * * * * *       *   'neighs'
!              7       8       9
!          *       *       *       *
!             columns                   nnk
!
      dimension neighs(9,2)
!
!     neighs(x,1) = neighbor panel number - x = 1,2,3,4,  6,7,8,9
!     neighs(x,2) = edge flag             - x = 1,2,3,4,  6,7,8,9
!
!     find row(m) and column(n) index numbers
!
      do 100 icol = 1, nnk-1
         do 100 irow = 1, nmk-1
            ic = icol
            ir = irow
            call pannum( irow, nmk, icol, iptest)
            if( iptest .eq. ip ) go to 105
  100    continue
  105 continue
!
      icol = ic
      irow = ir
!
      do 125 i = 1, 9
         neighs(i,2) = 0
  125 continue
!
      if( irow .eq. 1    )   neighs(5,2) = neighs(5,2) + 1
      if( irow .eq. nmk-1)   neighs(5,2) = neighs(5,2) + 1
      if( icol .eq. 1    )   neighs(5,2) = neighs(5,2) + 1
      if( icol .eq. nnk-1)   neighs(5,2) = neighs(5,2) + 1
!
!     find 'top'
      neighs(2,2) = 0
      irowt = irow
      if( irow+1 .ne. nmk) go to 150
      neighs(2,2) = 1
      irowt = 0
  150 irowt = irowt + 1
      call pannum( irowt, nmk, icol, neighs(2,1) )
!
!     find 'left' panel
      neighs(4,2) = 0
      icoll = icol
      if( icol-1 .ne. 0) go to 170
      neighs(4,2) = 1
      icoll = nnk
  170 icoll = icoll - 1
      call pannum( irow, nmk, icoll, neighs(4,1) )
!
!     find 'right' panel
      neighs(6,2) = 0
      icolr = icol
      if( icol+1 .ne. nnk) go to 180
      neighs(6,2) = 1
      icolr = 0
  180 icolr = icolr + 1
      call pannum( irow, nmk, icolr, neighs(6,1) )
!
!     find 'bottom' panel
      neighs(8,2) = 0
      irowb = irow
      if( irow-1 .ne. 0) go to 190
      neighs(8,2) = 1
      irowb = nmk
  190 irowb = irowb - 1
      call pannum( irowb, nmk, icol, neighs(8,1) )
!
!     find corner panels, 'top-left'
!                         'top-right'
!                         'bottom-left'
!                         'bottom-right'
!
      if(( neighs(4,2).eq.1 ).or.( neighs(2,2).eq.1 )) neighs(1,2)=1
      if(( neighs(2,2).eq.1 ).or.( neighs(6,2).eq.1 )) neighs(3,2)=1
      if(( neighs(8,2).eq.1 ).or.( neighs(4,2).eq.1 )) neighs(7,2)=1
      if(( neighs(6,2).eq.1 ).or.( neighs(8,2).eq.1 )) neighs(9,2)=1
!
      call pannum( irowt, nmk, icoll, neighs(1,1) )
      call pannum( irowt, nmk, icolr, neighs(3,1) )
      call pannum( irowb, nmk, icoll, neighs(7,1) )
      call pannum( irowb, nmk, icolr, neighs(9,1) )
!
      return
      END subroutine neghbr
! **deck nftpic
      subroutine nftpic (amach,iin,aj,arp,p,ics,ns,its,x,ne,nf,dvs,dvd)
      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 call appropriate panel influence coefficient calculation  *
!     *  routine. also to transform calculated induced velcoity       *
!     *  coefficients from local back to global coordinates           *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   aj        argument  input     sub-panel  area jacobian      *
!     *                                 (ratio of area element in     *
!     *                                 global coordinates to area    *
!     *                                 element in local sub-panel    *
!     *                                 coordinates)                  *
!     *                                                               *
!     *   amach     argument  input     freestream mach number        *
!     *                                                               *
!     *   arp       argument  input     matrix transforming the       *
!     *                                 combined potential/velocity   *
!     *                                 vector from local sub-panel to*
!     *                                 gobal coordinates             *
!     *                                                               *
!     *   dvd       argument  output    influence of taylors series   *
!     *                                 doublet coefficients on       *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvdp      /skrch3/  -local-   influence of taylors series   *
!     *                                 doublet coefficients on       *
!     *                                 potential (and possibly local *
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvsp      /skrch3/  -local-   influence of taylors series   *
!     *                                 source coefficients on        *
!     *                                 potential (and possibly local *
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvs       argument  output    influence of taylors series   *
!     *                                 source coefficients on        *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   ics       argument  input     =0 - panel is quadrilateral   *
!     *                                 =1 thru 4 - panel is triangle *
!     *                                     because edge ics is       *
!     *                                    collapsed                  *
!     *                                                               *
!     *   iin       argument  input     sub-panel inclination         *
!     *                                 indicator                     *
!     *                                 =+1  subinclined              *
!     *                                 =-1  superinclined            *
!     *                                                               *
!     *   its       argument  input     panel singularity type        *
!     *                                 =1 source alone               *
!     *                                 =2 doublet alone              *
!     *                                 =3 source and doublet         *
!     *                                                               *
!     *   ne        argument  input     number of components of       *
!     *                                 combined potential/velocity   *
!     *                                 coefficients desired          *
!     *                                                               *
!     *   nf        argument  input     number of taylors series      *
!     *                                 coefficients in sub-panel     *
!     *                                 doublet distribution          *
!     *                                 =6   quadratic                *
!     *                                 =10  cubic                    *
!     *                                                               *
!     *   p         argument input      local coordinates of sub-     *
!     *                                 panel vertices                *
!     *                                                               *
!     *   x         argument  input     field point location in local *
!     *                                 coordinates                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension p(3,4), x(3), arp(9), dvs(1), dvd(1)
!c
!     *  use subsonic panel influence coefficient routine if mach     *
!     *  number is subsonic                                           *
!
      if(amach.lt.1.d0)                                                 &
     &    call subsbi (p,ics,ns,its,x,aj,ne,nf,dvs,dvd)
!c
!     *  use supersonic/subinclined panel influence coefficient       *
!     *  routine if mach number is supersonic and panel is sub-       *
!     *  inclined                                                     *
!
      if((amach.gt.1.d0).and.(iin.gt.0))                                &
     &    call supsbi (p,ics,ns,its,x,aj,ne,nf,dvs,dvd)
!c
!     *  use supersonic/superinclined panel influence coefficient     *
!     *  routine if mach number is supersonic and panel is super-     *
!     *  inclined                                                     *
!
      if((amach.gt.1.d0).and.(iin.lt.0))                                &
     &    call supspi (p,ics,ns,its,x,aj,ne,nf,dvs,dvd)
!c
!     *  if only potential coefficients are required skip velocity    *
!     *  transformation                                               *
!
      if ( ne.eq.1 ) go to 900
!c
!     *  if panel has doublet distribution transform doublet velocity *
!     *  coefficients from local to global coordinate system          *
!
      if (its.le.1) go to 1000
          k1 = 0
          do 1100 j = 1,nf
        c11 = arp(1)*dvd(2+k1)+arp(2)*dvd(3+k1)+arp(3)*dvd(4+k1)
        c21 = arp(4)*dvd(2+k1)+arp(5)*dvd(3+k1)+arp(6)*dvd(4+k1)
        c31 = arp(7)*dvd(2+k1)+arp(8)*dvd(3+k1)+arp(9)*dvd(4+k1)
            dvd(2+k1) = c11
            dvd(3+k1) = c21
            dvd(4+k1) = c31
            k1 = k1+4
 1100     continue
 1000 continue
!c
!     *  if panel has source distribution transform source velcotiy   *
!     *  coefficients from local to global coordinate system          *
!
      ng      =  3
      if ( nf.gt.6 ) ng = 6
      if (its.eq.2) go to 2000
      k1 = 0
      do 2100 j = 1,ng
        c11 = arp(1)*dvs(2+k1)+arp(2)*dvs(3+k1)+arp(3)*dvs(4+k1)
        c21 = arp(4)*dvs(2+k1)+arp(5)*dvs(3+k1)+arp(6)*dvs(4+k1)
        c31 = arp(7)*dvs(2+k1)+arp(8)*dvs(3+k1)+arp(9)*dvs(4+k1)
               dvs(2+k1) = c11
               dvs(3+k1) = c21
               dvs(4+k1) = c31
               k1 = k1+4
 2100     continue
 2000 continue
  900 return
      END subroutine nftpic
! **deck nftpiv
      subroutine nftpiv                                                 &
     &   (amach,iin,aj,arp,p,ics,ns,its,x,nf,nv,sc,nsc,dc,ndc,pvsd)
      implicit double precision (a-h,o-z)
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to call appropriate panel influence coefficient calculation  *
!     *  routine. also to transform calculated induced velcoity       *
!     *  coefficients from local back to global coordinates.          *
!     *  also to multiply by known source and/or doublet parameters   *
!     *  to get potential and velocity influences for a known         *
!     *  singularity strength distribution.                           *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   aj        argument  input     sub-panel  area jacobian      *
!     *                                 (ratio of area element in     *
!     *                                 global coordinates to area    *
!     *                                 element in local sub-panel    *
!     *                                 coordinates)                  *
!     *                                                               *
!     *   amach     argument  input     freestream mach number        *
!     *                                                               *
!     *   arp       argument  input     matrix transforming the       *
!     *                                 combined potential/velocity   *
!     *                                 vector from local sub-panel to*
!     *                                 gobal coordinates             *
!     *                                                               *
!     *   dc        argument  input     doublet panel parameters      *
!     *                                 (taylor series doublet        *
!     *                                 coefficients).                *
!     *                                                               *
!     *   dvd       argument  -local-   influence of taylors series   *
!     *                                 doublet coefficients on       *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvdp      /skrch3/  -local-   influence of taylors series   *
!     *                                 doublet coefficients on       *
!     *                                 potential (and possibly local *
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvsp      /skrch3/  -local-   influence of taylors series   *
!     *                                 source coefficients on        *
!     *                                 potential (and possibly local *
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvs       argument  -local-   influence of taylors series   *
!     *                                 source coefficients on        *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   ics       argument  input     =0 - panel is quadrilateral   *
!     *                                 =1 thru 4 - panel is triangle *
!     *                                     because edge ics is       *
!     *                                    collapsed                  *
!     *                                                               *
!     *   iin       argument  input     sub-panel inclination         *
!     *                                 indicator                     *
!     *                                 =+1  subinclined              *
!     *                                 =-1  superinclined            *
!     *                                                               *
!     *   its       argument  input     panel singularity type        *
!     *                                 =1 source alone               *
!     *                                 =2 doublet alone              *
!     *                                 =3 source and doublet         *
!     *                                                               *
!     *   ne        argument  -local-   number of components of       *
!     *                                 combined potential/velocity   *
!     *                                 coefficients desired.  always *
!     *                                 4 here.                       *
!     *                                                               *
!     *   nf        argument  input     number of taylors series      *
!     *                                 coefficients in sub-panel     *
!     *                                 doublet distribution          *
!     *                                 =6   quadratic                *
!     *                                 =10  cubic                    *
!     *                                                               *
!     *   p         argument input      local coordinates of sub-     *
!     *                                 panel vertices                *
!     *   pvsd      argument  output    potential and velocity        *
!     *                                 influences of panel at field  *
!     *                                 point.                        *
!     *                                                               *
!     *   sc        argument  input     source subpanel parameters    *
!     *                                 (taylor series source         *
!     *                                 coefficients).                *
!     *                                                               *
!     *                                                               *
!     *   x         argument  input     field point location in local *
!     *                                 coordinates                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call nftphd
      common /nftphd/ phimuz
!end  nftphd
      dimension p(3,4), x(3), arp(9), pv(4,4)
      dimension pvsd(4,1), sc(nsc,nv), dc(ndc,nv)
      dimension art(3,3),dvs(24),dvd(40)
      data ne /4/
!c
!     *  use subsonic panel influence coefficient routine if mach     *
!     *  number is subsonic                                           *
!
      if(amach.lt.1.d0)                                                 &
     &    call subsbi(p,ics,ns,its,x,aj,ne,nf,dvs,dvd)
!c
!     *  use supersonic/subinclined panel influence coefficient       *
!     *  routine if mach number is supersonic and panel is sub-       *
!     *  inclined                                                     *
!
      if((amach.gt.1.d0).and.(iin.gt.0))                                &
     &    call supsbi(p,ics,ns,its,x,aj,ne,nf,dvs,dvd)
!c
!     *  use supersonic/superinclined panel influence coefficient     *
!     *  routine if mach number is supersonic and panel is super-     *
!     *  inclined                                                     *
!
      if((amach.gt.1.d0).and.(iin.lt.0))                                &
     &    call supspi(p,ics,ns,its,x,aj,ne,nf,dvs,dvd)
      phimuz  =  0.d0
      if ( its.gt.1 ) phimuz = dvd(1)
      if ( its.ne.1  .and.  its.ne.3 ) go to 700
      ng=3
!
!c
!    *  multiply source influences by subpanel source parameters.     *
!
      call mxma    (dvs,1,4,  sc,1,nsc,  pv,1,4,  4,ng,nv)
      if ( its.ge.2 )                                                   &
     &call hsmmp2 (4,nf,nv,  dvd,1,4,  dc,1,ndc,  pv,1,4)
      go to 800
  700 continue
!
!c
!    *  multiply doublet influences by subpanel doublet parameters.   *
!
      if ( its.ge.2 )                                                   &
     &call mxma   (dvd,1,4,  dc,1,ndc,  pv,1,4,  4,nf,nv)
  800 continue
!
!c
!    *  transform from local to global coordinates.                   *
!
      call mxma (arp,3,1,  pv(2,1),1,4,  pvsd(2,1),1,4,  3,3,nv)
      call dcopy (nv,  pv(1,1),4,  pvsd(1,1),4)
  900 return
      END subroutine nftpiv
! **deck norcal
      subroutine norcal(a,b,c,en)
      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 unit normal to triangle. orientation of normal is    *
!     *  such that the vertices a,b, and c are in counterclockwise    *
!     *  order viewed from the direction of the normal.               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  take cross product of vector from vertex a to b with vector  *
!     *  from vertex a to c.                                          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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 vertex                  *
!     *                                                               *
!     *   b         argument  input     second vertex                 *
!     *                                                               *
!     *   c         argument  input     third  vertex                 *
!     *                                                               *
!     *   en        argument  output    unit  normal to triangle      *
!     *                                                               *
!     *   u         -local-   - - - -   vector from vertex a to b     *
!     *                                                               *
!     *   v         -local-   - - - -   vector from vertex a to c     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension a(3),b(3),c(3),en(3),u(3),v(3)
      call vadd(b,-1.d0,a,u,3)
      call vadd(c,-1.d0,a,v,3)
      call cross(u,v,en)
      call uvect(en)
      return
      END subroutine norcal
! **deck norprt
      subroutine norprt (z,m,n,  en,mp,np)
      implicit double precision (a-h,o-z)
      dimension z(3,m,n), en(3,mp,np)
!
!         calculate all the mean plane panel normals on a network
!         and print them
!
      dimension u(3), v(3)
!
      do 200 j = 1,np
      do 100 i = 1,mp
          do 50 k = 1,3
               u(k) = z(k,i+1,j+1) - z(k,i,j+1) + z(k,i+1,j) - z(k,i,j)
               v(k) = z(k,i+1,j+1) + z(k,i,j+1) - z(k,i+1,j) - z(k,i,j)
   50     continue
          call cross (v,u,en(1,i,j))
          call uvect (en(1,i,j))
  100 continue
  200 continue
!
      call outmvc ('       ',mp,mp,np,en)
      return
      END subroutine norprt
! **deck nredge
      subroutine nredge (p, ze,ince,ne, isgn,tsgn, pe,te,de)
      implicit double precision (a-h,o-z)
      dimension p(3), ze(3), pe(3)
!         find the point on the edge defined by (ze,ince,ne) nearest to
!         the point  p , subject to the condition (te-tsgn)*isgn .gt. 0.
!         where isgn =  +-1.
!
      dimension dz(3), pz(3), pex(3)
!
      if ( isgn .gt. 0 ) go to 200
!                                  isgn = -1: restrict t .lt. tsgn
!                                  set defaults
      te      =  1.d0
      pe(1)   =  ze(1)
      pe(2)   =  ze(2)
      pe(3)   =  ze(3)
      de2     =  (p(1)-pe(1))**2 +(p(2)-pe(2))**2 +(p(3)-pe(3))**2
      do 100 ie = 2,ne
          te1     =  ie - 1
          te2     =  ie
          if ( te1 .gt. tsgn ) go to 110
          te2     =   min ( te2, tsgn)
          if ( te2 .le. te1 ) go to 110
          le1     =  ince*(ie-2)*3
          le2     =  le1 + ince*3
          dz(1)   =  ze(1+le2) - ze(1+le1)
          dz(2)   =  ze(2+le2) - ze(2+le1)
          dz(3)   =  ze(3+le2) - ze(3+le1)
          pz(1)   =  p(1) - ze(1+le1)
          pz(2)   =  p(2) - ze(2+le1)
          pz(3)   =  p(3) - ze(3+le1)
          dzsq    =  dz(1)*dz(1) +dz(2)*dz(2) + dz(3)*dz(3)
          if ( dzsq .le. 0.d0 ) go to 100
          dzpz    =  dz(1)*pz(1) + dz(2)*pz(2) + dz(3)*pz(3)
          tau     =  max( 0.d0, min( te2-ie+1.d0,  dzpz/dzsq)  )
          pex(1)  =  ze(1+le1) + tau*dz(1)
          pex(2)  =  ze(2+le1) + tau*dz(2)
          pex(3)  =  ze(3+le1) + tau*dz(3)
          tex     =  ie - 1 + tau
          dex2    =  (pex(1)-p(1))**2 + (pex(2)-p(2))**2                &
     &                                + (pex(3)-p(3))**2
          if ( dex2 .ge. de2 ) go to 100
               te      =  tex
               de2     =  dex2
               pe(1)   =  pex(1)
               pe(2)   =  pex(2)
               pe(3)   =  pex(3)
  100 continue
  110 continue
      go to 950
!
!                                  isgn = +1.: restrict t .gt. tsgn
  200 continue
!                                  set defaults
      ieb     =  max( 1.d0, tsgn - .000001d0)
      ieb     =  max ( 2, ieb)
      te      =  ne
      le2     =  ince*(ne-1)*3
      pe(1)   =  ze(1+le2)
      pe(2)   =  ze(2+le2)
      pe(3)   =  ze(3+le2)
      de2     =  (p(1)-pe(1))**2 +(p(2)-pe(2))**2 +(p(3)-pe(3))**2
      if ( ieb .gt. ne ) go to 310
      do 300 ie = ieb,ne
          te1     =  ie - 1
          te2     =  ie
          if ( te2 .lt. tsgn ) go to 300
          te1     =   max ( te1, tsgn)
          if ( te2 .le. te1 ) go to 300
          le1     =  ince*(ie-2)*3
          le2     =  le1 + ince*3
          dz(1)   =  ze(1+le2) - ze(1+le1)
          dz(2)   =  ze(2+le2) - ze(2+le1)
          dz(3)   =  ze(3+le2) - ze(3+le1)
          pz(1)   =  p(1) - ze(1+le1)
          pz(2)   =  p(2) - ze(2+le1)
          pz(3)   =  p(3) - ze(3+le1)
          dzsq    =  dz(1)*dz(1) +dz(2)*dz(2) + dz(3)*dz(3)
          if ( dzsq .le. 0.d0 ) go to 300
          dzpz    =  dz(1)*pz(1) + dz(2)*pz(2) + dz(3)*pz(3)
          tau     =  max( te1-ie+1.d0, min( 1.d0, dzpz/dzsq)  )
          pex(1)  =  ze(1+le1) + tau*dz(1)
          pex(2)  =  ze(2+le1) + tau*dz(2)
          pex(3)  =  ze(3+le1) + tau*dz(3)
          tex     =  ie - 1 + tau
          dex2    =  (pex(1)-p(1))**2 + (pex(2)-p(2))**2                &
     &                                + (pex(3)-p(3))**2
          if ( dex2 .ge. de2 ) go to 300
               te      =  tex
               de2     =  dex2
               pe(1)   =  pex(1)
               pe(2)   =  pex(2)
               pe(3)   =  pex(3)
  300 continue
  310 continue
!
  950 continue
      de      =  sqrt(de2)
      return
      END subroutine nredge
! **deck nrmesh
      subroutine nrmesh (zx,  ze,ince,ne,  isgn,te,  znr,inr,dnr)
      implicit double precision (a-h,o-z)
      dimension  zx(3), ze(3), znr(3)
!         find the mesh point on the edge  (ze,ince,ne)  with
!         (ie-te)*isgn .ge. 0  nearest to zx.
      inr     =  0
      dsqmin  = -1.d0
      do 100 ie = 1,ne
          if ( (ie-te)*isgn .lt. 0.d0 ) go to 100
          lzb     =  3*(ie-1)*ince
          dsq     =  ( zx(1) - ze(lzb+1) )**2                           &
     &              +( zx(2) - ze(lzb+2) )**2                           &
     &              +( zx(3) - ze(lzb+3) )**2
          if ( dsq.ge.dsqmin .and. inr.ne.0 ) go to 100
               dsqmin  =  dsq
               inr     =  ie
  100 continue
!
      if ( inr .eq. 0 ) go to 950
          dnr     =  sqrt( dsqmin )
          lzb     =  3*(inr-1)*ince
          znr(1)  =  ze(lzb+1)
          znr(2)  =  ze(lzb+2)
          znr(3)  =  ze(lzb+3)
  950 continue
      return
      END subroutine nrmesh
! **deck nrpted
      subroutine nrpted (qm,qp,p,qnear,dist,tau)
      implicit double precision (a-h,o-z)
!         find a point on the edge determined by endpoints  qm and qp
!         that is closest to p in the euclidean norm.
!
      dimension  qm(3), qp(3), p(3), qnear(3)
      dimension delr(3), rm(3)
!                                  get  t
      call vadd (qp,-1.d0,qm,delr,3)
!                                  qnear is being used as scratch
      call vadd (qm,-1.d0,p,rm,3)
      call vip (  rm,1,  delr,1,  3,  tn)
      call vip (delr,1,  delr,1,  3,  td)
      t       =  -tn/td
      if ( t.le.0.d0 ) go to 10
      if ( t.ge.1.d0 ) go to 30
      go to 20
!                                  qm is near pt.
   10 call xfera (qm,qnear,3)
      tau     =  0.d0
      go to 40
!                                  qm + t*delr is near pt
   20 call vadd (qm,t,delr,qnear,3)
      tau     =  t
      go to 40
!                                  qp is near pt
   30 call xfera (qp,qnear,3)
      tau     =  1.d0
!                                  get distance and return
   40 continue
      call vadd (qnear,-1.d0,p,delr,3)
      call vip (delr,1,  delr,1,  3,  dist)
      dist    =  sqrt(dist)
      return
      END subroutine nrpted
! **deck nrpthp
      subroutine nrpthp (ftcmpd,cp,ics,pz,  sval,tval)
      implicit double precision (a-h,o-z)
      dimension cp(3,4), pz(3)
!         find an estimate of the point on an h-p surface closest
!         to a given control point, pz.  distance is measured in
!         scaled coordinates.
      common /skaic2/                                                   &
     &                t(4), qpl(3,4), a(4,4), h(2,2), f(2), phst(4,2)   &
     &              , x(4,2), ph(4), dst(2), stx(2), q(3,4), qp(3,4)    &
     &              , th1, th2, ss, tt, p(3),u(3), enb(3)               &
     &              , idum
      dimension st(2)
      equivalence (st(1),ss)
      dimension     qc(3), ps(3), pt(3), pst(3)
      equivalence (qp(1,1),qc),(qp(1,2),ps),(qp(1,3),pt),(qp(1,4),pst)
      logical onbdry, trumin, convgd, within
      logical print
      dimension ftcmpd(3,3)
      data print/.true./
      data tol /1.d-10/
      call hsmmp1 (3,3,4,  ftcmpd,1,3,  cp,1,3,  q,1,3)
      call hsmmp1 (3,3,1,  ftcmpd,1,3,  pz,1,3,  p,1,3)
      do 10 i = 1,3
          qc(i)   =  .25d0*( q(i,1) + q(i,2) + q(i,3) + q(i,4) )
          ps(i)   =  .25d0*( q(i,1) - q(i,2) - q(i,3) + q(i,4) )
          pt(i)   =  .25d0*( q(i,1) + q(i,2) - q(i,3) - q(i,4) )
          pst(i)  =  .25d0*( q(i,1) - q(i,2) + q(i,3) - q(i,4) )
   10 continue
      call cross (ps,pt,enb)
!
      onbdry  =  .false.
      trumin  =   .true.
      call inside (q,ics,enb,p,within)
      if ( within ) go to 200
!                                  outside, check boundary
  100 continue
      dist    =  1.d20
      do 120 i = 1,4
          if ( i.eq.ics ) go to 120
          ip1     =  mod(i,4) + 1
          if ( ip1 .eq. ics ) ip1 = mod(ip1,4) + 1
          call nrpted ( q(1,i), q(1,ip1), p, t, d, tau)
          if ( d.gt.dist ) go to 120
               dist    =  d
               isv     =  i
               tausv   =  tau
  120 continue
      t(1)    =  2.d0*tausv - 1.d0
      t(2)    =  1.d0
      jj      =  mod( isv-1,2 ) + 1
      kt      =  1 - 2*mod(isv/2,2)
      ks      =  2*((isv-1)/2) - 1
      ss      =  ks * t(jj)
      tt      =  kt * t(3-jj)
      if ( ics .eq. 0 ) go to 300
!                                  triangle.  we are done
      onbdry  =  .true.
      trumin  =  .false.
      go to 600
!                                  inside.  project down and get s,t
  200 continue
      call vip (enb,1,  enb,1,  3,  ensq)
      ensqi   =  1.d0/ensq
      call vadd (p,-1.d0,qc,t,3)
      call cross (t,pt,u)
      call vip (enb,1,  u,1,  3,  th1)
      th1     =  ensqi*th1
      call cross (ps,t,u)
      call vip (enb,1,  u,1,  3,  th2)
      th2     =  ensqi*th2
      call cross (pst,pt,u)
      call vip (enb,1,  u,1,  3,  g1)
      g1      =  ensqi*g1
      call cross (ps,pst,u)
      call vip (enb,1,  u,1,  3,  g2)
      g2      =  ensqi*g2
      delta   =  g1*th2 - g2*th1
      d       =  sqrt(  1.d0 + 2.d0*( g1*th2+g2*th1 )  +  delta**2  )
      if ( delta .lt. 0.d0 ) go to 220
          ss      =  2.d0*th1/( 1.d0+delta+d )
          tt      =  0.d0
          if ( abs(1.d0+g2*ss) .gt. tol ) tt = th2/( 1.d0+g2*ss )
          go to 250
  220 continue
          tt      =  2.d0*th2/( 1.d0-delta+d )
          ss      =  0.d0
          if ( abs(1.d0+g1*tt) .gt. tol ) ss = th1/( 1.d0+g1*tt )
          go to 250
  250 continue
      if ( ics .ne. 0 ) go to 600
!
  300 continue
!
!                                  perform newton iteration to find
!                                  the near point on the panel
!
!                                  r**2 =  phi(i) = a(i,j) * phi(j)
      call xfera (qp,qpl,12)
      call vadd (qpl,-1.d0,p,t,3)
      call xfera (t,qpl,3)
      do 410 i = 1,4
      do 410 j = i,4
      call vip (qpl(1,i),1,  qpl(1,j),1,  3,  a(i,j))
      a(j,i)  =  a(i,j)
  410 continue
!                                  set constant elements of ph, phst
      ph(1)   =  1.d0
!     ph(2)   =  ss
!     ph(3)   =  tt
!     ph(4)   =  ss*tt
!
      phst(1,1) = 0.d0
      phst(2,1) = 1.d0
      phst(3,1) = 0.d0
!     phst(4,1) = tt
!
      phst(1,2) = 0
      phst(2,2) = 0.d0
      phst(3,2) = 1.d0
!     phst(4,2) = ss
!                                  newton iteration
      convgd  =  .false.
      do 500 k = 1,12
          ph(2)   =  ss
          ph(3)   =  tt
          ph(4)   =  ss*tt
          phst(4,1)=  tt
          phst(4,2)=  ss
!                                  set variable entries of ph, gph
!                                  get hessian
          call hsmmp1 (4,4,2,  a,1,4,  phst,1,4,  x,1,4)
          call hsmmp1 (2,4,2,  phst,4,1,  x,1,4,  h,1,2)
          call hsmmp1  (1,4,1,  ph,1,1,  a(1,4),1,4,  z,1,1)
          h(1,2)  =  h(1,2) + z
          h(2,1)  =  h(1,2)
!                                  get function to be zeroed
          call hsmmp1 (1,4,2,  ph,1,1,  x,1,4,  f,1,1)
!                                  newton correction
          if (  (abs(ss).ne.1.d0) .and.  (abs(tt).ne.1.d0)  )  go to 450
               fnm     =  sqrt (  f(1)**2 + f(2)**2  )
               if ( fnm .eq. 0.d0 ) go to 510
               is      =  0
               if ( (abs(ss).eq.1.d0) .and. ( abs(ss-f(1)/fnm).gt.1.d0))&
     &              is  =  1
               it      =  0
               if ( (abs(tt).eq.1.d0) .and. ( abs(tt-f(2)/fnm).gt.1.d0))&
     &              it  =  1
!                                  case is = 0 (ss motion permissible)
               if ( is.ne.0 ) go to 430
                    dst(2)  =  0.d0
                    dst(1)  =  -f(1) / max( 1.d-8, h(1,1) )
                    go to 460
  430          continue
!                                  case it = 0 (tt motion permissible)
                    dst(1)  =  0.d0
                    dst(2)  =  -f(2) / max( 1.d-8, h(2,2) )
                    go to 460
  450     continue
          delta   =  h(1,1)*h(2,2) - h(1,2)**2
          if ( delta .eq. 0.d0 ) delta = 1.d-06
          delta   =  sign(  max(abs(delta), 1.d-8),  delta )
          dst(1)  =  - (  h(2,2)*f(1) - h(1,2)*f(2)  ) /delta
          dst(2)  =  - ( -h(1,2)*f(1) + h(1,1)*f(2)  ) /delta
  460     continue
          theta   =  1.d0
          if (  dst(1).ne.0.d0  )                                       &
     &         theta = min ( theta, (sign(1.d0,dst(1))-st(1))/dst(1)  )
          if (  dst(2).ne.0.d0  )                                       &
     &         theta = min ( theta, (sign(1.d0,dst(2))-st(2))/dst(2)  )
          theta   =  max (  0.d0,  min( 1.d0, theta*1.000001d0)   )
          dst(1)  =  theta * dst(1)
          dst(2)  =  theta * dst(2)
          stx(1)  =  max( -1.d0,  min(  1.d0,  st(1)+dst(1)  ))
          stx(2)  =  max( -1.d0,  min(  1.d0,  st(2)+dst(2)  ))
          iedg    =  0
          if ( stx(2) .eq. 1.d0 ) iedg = 1
          if ( stx(1) .eq.-1.d0 ) iedg = 2
          if ( stx(2) .eq.-1.d0 ) iedg = 3
          if ( stx(1) .eq. 1.d0 ) iedg = 4
          dx      =  abs(stx(1)-st(1))  +  abs(stx(2)-st(2))
          if ( iedg  .eq. 0 ) go to 490
               ist     =  mod(iedg-1,2) + 1
               sgn     =  -1.d0
               if ( iedg .ge. 3 ) sgn = 1.d0
               ip1     =  mod( iedg,4 ) + 1
               call nrpted ( q(1,iedg), q(1,ip1), p, t, d, tau)
               stx(ist)=  sgn*( 2.d0*tau-1.d0)
  490     continue
          st(1)   =  stx(1)
          st(2)   =  stx(2)
          if ( convgd .and.  dx.lt.1.d-10 ) go to 510
          convgd  =  .false.
          if ( dx .lt. 1.d-06 ) convgd = .true.
  500 continue
  510 continue
      onbdry  =  (abs(ss).eq.1.d0)  .or.  (abs(tt).eq.1.d0)
      trumin  =  .false.
      if(  (.not.onbdry)  .or.  (  (abs(f(1))+abs(f(2))) .lt. 1.d-06 )) &
     &    trumin  =  .true.
!
!                                  near point has been found
!                                  get a variety of info about the near
!
  600 continue
      sval    =  ss
      tval    =  tt
      return
      END subroutine nrpthp
! **deck ntewic
      subroutine ntewic (gen,  ne,zc,  indkgp,phvic,  awki)
      implicit double precision (a-h,o-z)
      dimension zc(3), phvic(4,12)
      dimension gen(3), genx(3)
!
!         low frequency version, with mu = mu/0 (tau) + sigma mu/1 (tau)
!
!         evaluate trailing edge ic's for a wake network using a
!         quadrature technique.  columns 1:9 contain the dependency of
!         phi  and  v  upon the 9 canonical doublet panel parameters.
!         column 10-12 contains the additional dependencies upon
!         the downstream gradient of the doublet strength at the
!         the 3 standard points on the wake panel trailing edge.
!         Numbering of points on the wake panel is as follows:
!
!               1---5---2
!               | x |   |  normal points into page
!               8   9   6
!               |   |   |
!               4---7---3
!   tau    <--- 3---2---1
!                       |
!                       | sigma
!                       V
!
!
!         gen     i   r*8   the generator for the wake filaments for thi
!         ne      i   int   the number of ic rows to generate.  admissab
!                           values:  1 ==> phi;  4 ==> phi+v
!         zc      i   r*8   zc(1:3) = control point location
!         indkgp  o   int   indkgp = the group index of the mu/x paramet
!                           if it exists
!         phvic   o   r*8   phvic(1:ne,1:12) contains the phi and
!                           (possibly) the v influence coefficients for
!                           the wake filaments trailing off the current
!         awki    o   r*8   the inverse of the reference to local transf
!                           associated with the current wake filaments
!
!         michael epton, 30 november 1988
!
!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 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 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 lndblx
!                                                           /lndblx/
      common /lndblx/ genwak(3,mxnett), slndbl(mxnett)                  &
     &              , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett)
!end  lndblx
!
!call ktewic
      common /ktewic/ cpl(3), dcpl(3), zl(3)
!end  ktewic
!
      dimension z(3), phz(3), ph1(3), vz(3,3), v1(3,3), wz(3,3), w1(3,3)
      dimension sg(3)
      dimension q(3)
      dimension dmu(3,3), rj(6), rj2(6), rjerr(6), etmy(3)
      dimension tmu(3,3)
      dimension phic(12), vic(3,12)
      dimension awk(9), awki(9), enwk(3), tg(3)
      dimension zmu(10,6), qpan(3,4), qpanz(3), dq(3)                   &
     &        , dvs(4,6), dvd(4,10)                                     &
     &        , zloc(3), pvpan(4,6), genhat(3)
      dimension ajd(3), akd(3), akt(3), w1j(3)
!
      data dmu/-3.d0,-1.d0,1.d0, 4.d0,0.d0,-4.d0, -1.d0,1.d0,3.d0 /
      data tmu/ 0.d0,-.5d0,1.d0, 0.d0,0.d0,-4.d0,  0.d0,.5d0,3.d0 /
!
!
!                                  compute the reference to local trans-
!                                  formation for the wake filament surfa
!                                  using 'gen' as a special direction
      call vadd (cp(1,4), -1.d0, cp(1,3), tg, 3)
      call cross (gen,tg,enwk)
      call uvect (enwk)
      call dcopy (3,  gen,1,  genhat,1)
      call uvect (genhat)
      call refloc (enwk,sbetam,gen,  awk,ajac,rjac, awki)
      alf     =  ddot (3,  awk,3,  genhat,1)
      a11inv  =  1.d0/alf
! -------------------------------------------------------start
!---  call outlinx ('alf,...',6,alf,a11inv,akap,akapin,ajac,rjac)
!---  call outvec ('enwk',3,enwk)
!---  call outmat ('awki',3,3,3,awki)
! -------------------------------------------------------end
      call mxma (awk,1,3, cp(1,3),1,3,  cpl,1,3,  3,3,1)
      call mxma (awk,1,3, cp(1,4),1,3, dcpl,1,3,  3,3,1)
      call mxma (awk,1,3, genhat,1,3,  genx,1,3,  3,3,1)
      dcpl(1) = dcpl(1) - cpl(1)
      dcpl(2) = dcpl(2) - cpl(2)
      dcpl(3) = dcpl(3) - cpl(3)
! ===========================================================
!                                  compute a downstream displacement
!                                  and apply it.
      call dcopy (3,  0.d0,0,  dq,1)
      call vip (zc,1,  genhat,1,  3,  zgen)
      call vip (cpl,1, genhat,1,  3,  cgen)
      call vip (dcpl,1,genhat,1,  3,  dcgen)
      cgen    =  max( cgen, cgen+dcgen )
      dcplnm  =  sqrt( dcpl(1)**2 + dcpl(2)**2 + dcpl(3)**2 )
!                                  if  cgen < zgen, add multiple
!                                  of gen to cpl
      dqmag    =  max( 1.1*(zgen-cgen), dcplnm)
!
      do 40 i = 1,3
         dq(i)   =  dqmag*genx(i)
         qpanz(i)   =  cpl(i)
         qpan(i,1)  =  0.d0
         qpan(i,2)  =  dq(i)
         qpan(i,3)  =  dq(i) + dcpl(i)
         qpan(i,4)  =          dcpl(i)
   40 continue
!                                  move the wake filament panel d.s.
      call daxpy (3,  1.d0,  dq,1,  cpl,1)
!                                  build the special distributions
      call dcopy (10*6,  0.d0,0,  zmu,1)
      dxi     =  dcpl(1)
      deta    =  dcpl(2)
      detasq  =  deta**2
!
      zmu(1,1)  =  1.d0
      zmu(3,1)  =        -3.d0/deta
      zmu(6,1)  =                   4.d0/detasq
!
      zmu(3,2)  =         4.d0/deta
      zmu(6,2)  =                  -8.d0/detasq
!
      zmu(3,3)  =        -1.d0/deta
      zmu(6,3)  =                   4.d0/detasq
!
      zmu(2,4)  =         1.d0/alf
      zmu(3,4)  =                -dxi/(alf*deta)
!
      t5      =  1.d0/(alf*deta)
      t6      =  dxi*t5/deta
      t9      =  1.d0/(alf*detasq)
      tx      =  dxi*t9/deta
!
      zmu(5,4)  =  -3.d0*t5
      zmu(5,5)  =            4.d0*t5
      zmu(5,6)  =                     -1.d0*t5
!
      zmu(6,4)  =   6.d0*t6
      zmu(6,5)  =           -8.d0*t6
      zmu(6,6)  =                      2.d0*t6
!
      zmu(9,4)  =   4.d0*t9
      zmu(9,5)  =           -8.d0*t9
      zmu(9,6)  =                      4.d0*t9
!
      zmu(10,4)  = -12.d0*tx
      zmu(10,5)  =           24.d0*tx
      zmu(10,6)  =                    -12.d0*tx
! ===========================================================
!                                  clear the phi and v buffers
      call dcopy (36,  0.d0,0,  vic,1)
      call dcopy (12,  0.d0,0,  phic,1)
!                                  loop over symmetry images for the 1-s
      sgni    =  -1.d0
      do 500 isymm = 1,nisym
      sgni    =  -sgni
!                                  loop over symmetry images for the 2-n
      sgnj    =  -1.d0
      do 400 jsymm = 1,njsym
      sgnj    =  -sgnj
!                                  set sgnk for antisymmetric/symmetric
      ksymm   =  isymm*jsymm
      sgnk    =  1.d0
      if ( isymm*misym  .eq.  -2 ) sgnk = -sgnk
      if ( jsymm*mjsym  .eq.  -2 ) sgnk = -sgnk
!                                  compute control point image
      z(1)    =  zc(1)
      z(2)    =  sgni*zc(2)
      z(3)    =  sgnj*zc(3)
!                                  rollin (1/4*pi) factor
      sgnk    =  akapin*sgnk
!                                  set sign vector for velocity inclusio
      sg(1)   =  sgnk
      sg(2)   =  sgnk*sgni
      sg(3)   =  sgnk*sgnj
! ----------------------------------------------------------------------
!                                  evaluate phz(1:3), ph1; vz(3,1:3), v1
      call dcopy (3,  0.d0,0,  ph1,1)
      call dcopy (3,  0.d0,0,  phz,1)
      call dcopy (3,  0.d0,0,  v1,1)
      call dcopy (9,  0.d0,0,  vz,1)
      zl(1)   =  awk(1)*z(1) + awk(4)*z(2) + awk(7)*z(3)
      zl(2)   =  awk(2)*z(1) + awk(5)*z(2) + awk(8)*z(3)
      zl(3)   =  awk(3)*z(1) + awk(6)*z(2) + awk(9)*z(3)
      ztmz    =  cpl(3) - zl(3)
      dxi     =  dcpl(1)
      deta    =  dcpl(2)
      ximx    =  cpl(1) - zl(1)
      etmy(1) =  cpl(2) - zl(2)
      etmy(2) =  etmy(1) + .5d0*dcpl(2)
      etmy(3) =  etmy(1) +    dcpl(2)
! ------------------------------------------start
!---  call outvec ('z',3,z)
!---  call outvec ('zl',3,zl)
!---  call outvec ('cpl',3,cpl(1))
!---  call outvec ('dcpl',3,dcpl(1))
!---  call outmat ('awk',3,3,3,awk)
!---  call outvec ('etmy',3,etmy)
! -----------------------------------------------------------
!      generate the following integrals:
!      j(1:3) =  phi(i)(t) / [ r * (r + xi'(tau) - x') ]
!      j(4:6) =  phi(i)(t) / [     (r + xi'(tau) - x') ]
!
      tol     =   1.d-10
      nfcn    =   0
      call itewic ( tol, 0.d0, 1.d0,    rj,rj2,rjerr,nfcn)
      call dcopy (6,  rj2,1,  rj,1)
!---  call outlin ('==itewic',1,nfcn)
      do 60 j = 1,3
         ajd(j) = rj(1)*dmu(1,j) +rj(2)*dmu(2,j) +rj(3)*dmu(3,j)
         akd(j) = rj(4)*dmu(1,j) +rj(5)*dmu(2,j) +rj(6)*dmu(3,j)
         akt(j) = rj(4)*tmu(1,j) +rj(5)*tmu(2,j) +rj(6)*tmu(3,j)
   60 continue
      w1j(1)  =  a11inv * ( -deta*ztmz )
      w1j(2)  =  a11inv * (  dxi *ztmz )
      w1j(3)  =  a11inv * (  deta*ximx - dxi*etmy(1) )
!                                  phz
      phz(1)  =  -deta*ztmz*rj(1)
      phz(2)  =  -deta*ztmz*rj(2)
      phz(3)  =  -deta*ztmz*rj(3)
!                                  ph1
      ph1(1)  =  -deta*ztmz*a11inv*rj(4) + dqmag*phz(1)
      ph1(2)  =  -deta*ztmz*a11inv*rj(5) + dqmag*phz(2)
      ph1(3)  =  -deta*ztmz*a11inv*rj(6) + dqmag*phz(3)
!                                  w1
!
      do 80 j = 1,3
         do 70 i = 1,3
            w1(i,j) = w1j(i)*rj(j)
   70    continue
         w1(2,j) = w1(2,j) - a11inv*ztmz*akd(j)
         w1(3,j) = w1(3,j) + a11inv*deta*rj(j+3)                        &
     &                     + a11inv*etmy(1)*akd(j)                      &
     &                     + a11inv*deta*akt(j)
   80 continue
!                                  wz, include shift effect in w1
      do 200 j = 1,3
          wz(1,j)  =  0.d0
          wz(2,j)  =  -ztmz*( dmu(1,j)*rj(1)                            &
     &                       +dmu(2,j)*rj(2)                            &
     &                       +dmu(3,j)*rj(3) )
!
          wz(3,j)  =  etmy(1)*dmu(1,j)*rj(1)                            &
     &               +etmy(2)*dmu(2,j)*rj(2)                            &
     &               +etmy(3)*dmu(3,j)*rj(3)
          w1(2,j)  =  w1(2,j) + dqmag*wz(2,j)
          w1(3,j)  =  w1(3,j) + dqmag*wz(3,j)
  200 continue
!---  call outliny ('ph1,w1',4,ph1,w1(1),w1(2),w1(3))
!---      call outvcy ('phz',3,phz)
!---      call outmty ('wz',3,3,3,wz)
!
! ===========================================================
      zloc(1) =  zl(1) - qpanz(1)
      zloc(2) =  zl(2) - qpanz(2)
      zloc(3) =  zl(3) - qpanz(3)
      icsx = 0
      nsx  = 4
      itsx = 2
      ajx  = 1.d0
      nex  =  4
      nfx  =  10
      call subsbi (qpan,icsx,nsx,itsx,zloc,ajx,nex,nfx,dvs,dvd)
!---      call outmat ('dvd',4,4,6,dvd)
!---      call hsmmp1 (4,10,6,  dvd,1,4,  zmu,1,10,  pvpan,1,4)
!
      do 220 i = 1,4
        pvpan(i,1)=dvd(i,1)*zmu(1,1)+dvd(i,3)*zmu(3,1)+dvd(i,6)*zmu(6,1)
        pvpan(i,2)=                  dvd(i,3)*zmu(3,2)+dvd(i,6)*zmu(6,2)
        pvpan(i,3)=                  dvd(i,3)*zmu(3,3)+dvd(i,6)*zmu(6,3)
        pvpan(i,4)=dvd(i,2)*zmu(2,4)+dvd(i,3)*zmu(3,4)+                 &
     &             dvd(i,5)*zmu(5,4)+dvd(i,6)*zmu(6,4)+                 &
     &             dvd(i,9)*zmu(9,4)+dvd(i,10)*zmu(10,4)
        pvpan(i,5)=                                                     &
     &             dvd(i,5)*zmu(5,5)+dvd(i,6)*zmu(6,5)+                 &
     &             dvd(i,9)*zmu(9,5)+dvd(i,10)*zmu(10,5)
        pvpan(i,6)=                                                     &
     &             dvd(i,5)*zmu(5,6)+dvd(i,6)*zmu(6,6)+                 &
     &             dvd(i,9)*zmu(9,6)+dvd(i,10)*zmu(10,6)
  220 continue
!---      write (6,6007) phz,ph1,((wz(i,j),j=1,3),(w1(i,j),j=1,3),i=1,3)
 6007 format (6f24.16)
      call dscal (24,  akap,  pvpan,1)
!
      do 250 j  = 1,3
         phz(j)  =  phz(j) + pvpan(1,j)
         ph1(j)  =  ph1(j) + pvpan(1,j+3)
         do 240 i = 1,3
            wz(i,j) = wz(i,j) + pvpan(i+1,j)
            w1(i,j) = w1(i,j) + pvpan(i+1,j+3)
  240    continue
  250 continue
!---      write (6,'( ''   new, added together '' )' )
!---      write (6,6007) phz,ph1,((wz(i,j),j=1,3),(w1(i,j),j=1,3),i=1,3)
!
! ===========================================================
! ----------------------------------------------------------------------
      call mxma (awk,3,1,  wz,1,3,  vz,1,3,  3,3,3)
      call mxma (awk,3,1,  w1,1,3,  v1,1,3,  3,3,3)
!                                  accumulate results to output ic's  c
      phic(3)  =  phic(3) + sgnk*phz(1)
      phic(7)  =  phic(7) + sgnk*phz(2)
      phic(4)  =  phic(4) + sgnk*phz(3)
      phic(10) =  phic(10)+ sgnk*ph1(1)
      phic(11) =  phic(11)+ sgnk*ph1(2)
      phic(12) =  phic(12)+ sgnk*ph1(3)
!
      if ( ne.eq.1 ) goto 310
      do 300 i = 1,3
          vic(i,3)  =  vic(i,3)  +  sg(i)*vz(i,1)
          vic(i,7)  =  vic(i,7)  +  sg(i)*vz(i,2)
          vic(i,4)  =  vic(i,4)  +  sg(i)*vz(i,3)
          vic(i,10) =  vic(i,10) +  sg(i)*v1(i,1)
          vic(i,11) =  vic(i,11) +  sg(i)*v1(i,2)
          vic(i,12) =  vic(i,12) +  sg(i)*v1(i,3)
  300 continue
  310 continue
!                                  end, loop on symmetry images
  400 continue
  500 continue
!                                  put ic results into output array
      call dcopy (12,  phic,1,  phvic,ne)
      if ( ne.eq.4 ) call mcopy (3,12,  vic,1,3,  phvic(2,1),1,4)
      indkgp  =  0
      return
      END subroutine ntewic
! **deck nwindx
      subroutine nwindx (netknt,  string,knet)
      implicit double precision (a-h,o-z)
      character*10 string
!
!         find the network index of the network identified by string,
!         which may be a character string, or may be a floating point nu
!
!         netknt  i    int  the largest nw index to be examined
!         string  i    ch   the string containing either an ascii
!                           network name, or the ascii characters that
!                           when read with f10.0 fmt, give the nw index
!         knet    o    int  the index of the network described by string
!
!         other input:
!         /iduser/  contains the network identifiers, stored as a pair
!                   of a5 strings for each identifier
!         /nwlst/   contains the ch*10 form of the network identifiers.
!                   nnwlst is the current number available
!
!         michael epton, 30 november 1988
!
      character*10 s
      character*90 qline
!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 iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
!call nwlst
      common /cnwlst/ nwname(mxnett)
      character*10 nwname
      common /anwlst/ nnwlst
!end  nwlst
!
      iflag   =  0
!                                  take string, and left justify, blank
      s       =  string
      call ljbf10 (s)
!                                  update the list of nw names, nwname
      do 100 kk  = (nnwlst+1),netknt
          write (nwname(kk),6001) iduser(kk)
          call ljbf10 (nwname(kk))
          if ( iflag.ne.0 )                                             &
     &         write (6,6002) kk, nwname(kk), iduser(kk)
          read  (nwname(kk),6001,err=9950) iduser(kk)
  100 continue
      nnwlst  =  max( nnwlst, netknt)
!
 6001 format (a10)
 6002 format (' nw list update, k=',i3,'  name:',a10,'  input:',a10     &
     &  ,/,   '                   ',3x,'       '                        &
     &       ,'1234567890','        ','1234567890')
 6003 format (f10.0)
!                                  list is updated, search for string
      do 200 kk = 1,netknt
          ksv      =  kk
          if ( s.eq.nwname(kk) ) goto 250
  200 continue
!                                  item not found, read as f10.0
!                                  note that the read will cause pgm
!                                  failure if the data is no good
      read (string,6003,err=9950) xknet
      knet    =  xknet
      goto 950
!                                  item was found
  250 continue
      knet    =  ksv
      goto 950
!
  950 continue
      return
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'nwindx', 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('nwindx',' program failure due to ill-formatted data')
      return
!
      END subroutine nwindx
! **deck offbdx
      subroutine offbdx (nof,ivzof,zof,pvof)
      implicit double precision (a-h,o-z)
!******
!     purpose  to calculate potential/velocity at off body points
!
!     input    common block
!              /ofbod/ - nof,ntob,nrob
!
!     discussion  the code reads the off body points from file ntob
!              and then calls pvcal to compute potential/velocity at
!              these points simultaneously. the velocity is then
!              converted to total mass flux and printed out along with
!              the calculated pressure
!******
!
!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
!ca cinout
!                                                           /cinout/
      common /cinout/ ntsin, ntsout
!end  cinout
!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 irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!call rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call updind
      common /updind/ nup(20) , dumup(120)
!end  updind
!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 fmcof
      common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof
!end  fmcof
!call boundl
!                                                           /boundl/
      common /boundl/ itapbl, ivcorr
!end  boundl
!call titles
      common /titles/ title1(20),title2(20)
      character*4 title1, title2
!end  titles
!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 ivzof(1)
      dimension zof(3,1666),                                            &
     &          pvof(4,1666),wof(4),cp(5)
      dimension pv(3), wt(3)
      dimension vt(3), pw(3)
      character*1 ch
      character*3 cpname(4)
      data cpname /'lin', 'sln', '2nd', 'isn'/
      data ntpoff /34/
!
!
!
      open (unit=ntpoff,file='ft34',form='formatted',status='unknown')
!
!                                  calculate the size of each output set
      nofset  =  nof/nacase
      ch      =  'w'
      if ( tpoff.ne.0.d0 ) ch = 'v'
      write (ntsout,1010)
 1010 format (1h1)
      call bmark ('off-body')
      write (ntsout,1000) ch,ch,ch,cpname(nprcof)
 1000 format (//,1x,'off body flow characteristics'                     &
     & ,//,' soln','   pt' ,4x ,8x,'x',2x ,8x,'y',2x ,8x,'z',2x         &
     & ,4x  ,7x,a1,'x',2x  ,7x,a1,'y',2x   ,7x,a1,'z '                  &
     & ,3x  ,6x,' ppot',1x  ,2x  ,4x,'cp/',a3,1x  ,6x,'mach',1x  )
 1001 format (1x,i4,i5     ,4x ,3f11.4                                  &
     & ,4x  ,3f11.4                                                     &
     & ,2x  ,f11.4          ,2x  ,f11.4           ,f11.4)
!
      write (ntpoff,5600)  (title1(i),i=1,18), (title2(i),i=1,18)
 5600 format ( '(f5.0,9e12.5)'                                          &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$      ','off-body flow-field properties'                &
     &  ,/,   '$      ','caution:  the data within a solution have not' &
     &                 ,' been given a runid.'                          &
     &  ,/,   '*dupt'                                                   &
     &  ,/,   '*dup'                                                    &
     &   )
 5601 format (i5,1p,9e12.5)
 5602 format ('s',i1)
 5603 format ('*eof')
 5604 format (3x,'pt'  ,11x,'x' ,11x,'y' ,11x,'z'                       &
     &       ,10x,a1,'x'  ,10x,a1,'y'  ,10x,a1,'z'                      &
     &       ,8x,'ppot'   ,6x,'cp/',a3   ,8x,'mach'                     &
     &       )
!
!                             cycle over off body points
      iaprv   =  0
      do 500 iof=1,nof
      call dcopy (4,pvof(1,iof),1,wof,1)
!
      ia    =  ivzof(iof)
      iacase = ia
!                                  correct velocities and compute
!                                  pressure coefficients
      call vadd (wof(2),-1.d0,fsv(1,ia),pv,3)
      if ( tpoff.ne.0.d0 ) goto 360
!                                     tpoff = 0., mass flux was calculat
          call dcopy (3,  wof(2),1,  wt,1)
          call cmpscl ( 1.d0/betams, compd, pv, pv)
          call vadd (fsv(1,ia), 1.d0, pv, vt, 3)
          goto 370
!                                     tpoff # 0., velocity was calculate
  360 continue
      call cmpscl (betams,compd,pv,pw)
      call vadd (fsv(1,ia),1.d0,pw,wt,3)
      call dcopy (3,  wof(2),1,  vt,1)
      if ( ivcorr.eq.0 ) goto 370
      call mag (fsv(1,ia),fsvmag)
      call velcor (ivcorr,fsv(1,ia),fsvmag,compd,amach,wt,wof(2))
      call vadd (wof(2),-1.d0,fsv(1,ia),pv,3)
      call dcopy (3,  wof(2),1,  vt,1)
  370 continue
      kmat    =  0
      call cpcal (kmat,pv,fsv(1,ia),betams,compd,cp)
!
      call mxm (vt,1,wt,3,amloc,1)
      amloc = amach * sqrt(max(0.d0,amloc)/(fsvm(ia)*fsvm(ia))/         &
     &        max(1.d-10, 1.d0 + .7d0*amach*amach*cp(nprcof)))
      amloc = min(1.d3,amloc)
      amloc   =  sqrt( cpfmat(kmat) )*amloc
!---- call machvl (kmat,pv,amloc)
!
!                             print results
      iacase  =  (iof-1)/nofset + 1
      iofset  =  iof - (iacase-1)*nofset
      if ( iofset.eq.1 .and. iacase.gt.1 ) write (ntpoff,5603)
      if ( iofset.eq.1 )  write (ntpoff,5602) iacase
      if ( iof.eq.1 ) write (ntpoff,5604) ch,ch,ch,cpname(nprcof)
      write (ntpoff,5601)         iofset, (zof(kk,iof),kk=1,3)          &
     &                  , (wof(kk),kk=2,4)                              &
     &                  , wof(1), cp(nprcof), amloc
      if ( iacase.ne.iaprv ) write (ntsout,1002)
 1002 format (' ')
      iaprv   =  iacase
      write (ntsout,1001) iacase, iofset, (zof(kk,iof),kk=1,3)          &
     &                  , (wof(kk),kk=2,4)                              &
     &                  , wof(1), cp(nprcof), amloc
  500 continue
      write  (ntpoff,5603)
      call emark ('off-body')
      return
      END subroutine offbdx
! **deck offch1
      subroutine offch1 (nnett,npant,nm,nn,nza,npa,zm                   &
     &                  ,zctr,rcsq,tctr,wctr)
      implicit double precision (a-h,o-z)
      dimension nm(nnett), nn(nnett), nza(nnett+1), npa(nnett+1)
      dimension zm(3,6000)
      dimension zctr(3,npant), rcsq(npant), tctr(npant), wctr(3,npant)
!
!     compute the list of all panel centers and the parameters of
!     the smallest (thin) cylinder containing the panel.  before
!     exit, the radius values are modified according to the rule:
!
!      r  <--  sqrt( r**2 + t**2 )
!
!     where  't'  is the semithickness returned in tctr
!
      dimension u(3), v(3), w(3), inc(4)
!
      do 800 k = 1,nnett
         mk      =  nm(k)
         nk      =  nn(k)
!                                   set increments for panel points
         inc(1)  =  0
         inc(2)  =  mk
         inc(3)  =  mk+1
         inc(4)  =  1
         lz     =  nza(k)+1
!                                   loop over panels
         do 700 jp = 1,nk-1
         do 600 ip = 1,mk-1
            lpan    =  ip + (jp-1)*(mk-1) + npa(k)
            lz      =  ip + (jp-1)*mk     + nza(k)
!                                   get panel center and normal
            do 100 ii = 1,3
               zctr(ii,lpan) = .25d0*( zm(ii,lz)   + zm(ii,lz+mk)       &
     &                                +zm(ii,lz+1) + zm(ii,lz+mk+1))
!
               u(ii)   =   -zm(ii,lz)   + zm(ii,lz+mk)                  &
     &                     -zm(ii,lz+1) + zm(ii,lz+mk+1)
!
               v(ii)   =   -zm(ii,lz)   - zm(ii,lz+mk)                  &
     &                     +zm(ii,lz+1) + zm(ii,lz+mk+1)
  100       continue
            w(1)    =  u(2)*v(3) - u(3)*v(2)
            w(2)    =  u(3)*v(1) - u(1)*v(3)
            w(3)    =  u(1)*v(2) - u(2)*v(1)
            wfac    =  1.d0/sqrt( w(1)**2 + w(2)**2 + w(3)**2 )
            w(1)    =  wfac*w(1)
            w(2)    =  wfac*w(2)
            w(3)    =  wfac*w(3)
            wctr(1,lpan) = w(1)
            wctr(2,lpan) = w(2)
            wctr(3,lpan) = w(3)
!                                  get r and z cylindrical coordinates
!                                  for each corner of the panel
            zmax    =  0.d0
            rmax2   =  0.d0
            do 200 is = 1,4
               lpt     =  lpan + inc(is)
               u(1)    =  zm(1,lpt) - zctr(1,lpan)
               u(2)    =  zm(2,lpt) - zctr(2,lpan)
               u(3)    =  zm(3,lpt) - zctr(3,lpan)
               zval    =  u(1)*w(1) + u(2)*w(2) + u(3)*w(3)
               usq     =  u(1)*u(1) + u(2)*u(2) + u(3)*u(3)
               rsq     =  usq - zval*zval
               zmax    =  max( zmax, abs(zmax))
               rmax2   =  max( rmax2, rsq)
  200       continue
!                                  set semi-thickness of cylinder
!                                  and modified radius (save squared
!                                  value to avoid square root when
!                                  using)
            rcsq(lpan) = rmax2 + zmax**2
            rmax       = sqrt(rmax2)
            tctr(lpan) = max( zmax, .001d0*rmax )
  600    continue
  700    continue
         lz     =  nza(k)+1
         lpan   =  npa(k)+1
! ---         call outmvc ('pan ctrs',mk-1,mk-1,nk-1,zctr(1,lpan))
! ---         call outmvc ('pan nrmls',mk-1,mk-1,nk-1,wctr(1,lpan))
! ---         call outmat ('pan rads',mk-1,mk-1,nk-1,rcsq(lpan))
! ---         call outmat ('pan thix',mk-1,mk-1,nk-1,tctr(lpan))
  800 continue
!
      return
      END subroutine offch1
!!      subroutine offch2 (nof,p,ipnd,  nsymm,nnett,npant,nm,nn,nza,npa,zm& ! Removed by Martin Hegedus, 4/21/09
!!     &                  ,zctr,rcsq,tctr,wctr)                             ! Removed by Martin Hegedus, 4/21/09
! **deck offch2
      subroutine offch2 (nof,p,ipnd,nisym,njsym,nnett,npant,nm,nn,nza,  & ! Added by Martin Hegedus, 4/21/09
     &                  npa,zm,zctr,rcsq,tctr,wctr)                       ! Added by Martin Hegedus, 4/21/09
      implicit double precision (a-h,o-z)
      dimension nm(nnett), nn(nnett), nza(nnett+1), npa(nnett+1)
      dimension p(3,nof), ipnd(nof), zm(3,6000)
      dimension zctr(3,npant), rcsq(npant), tctr(npant)                 &
     &                       , wctr(3,npant)
!
!     determine which (if any) panel an off-body point (or one of its
!     images) lies on.
!
      dimension yfac(4), zfac(4), pc(3), inc(4), pdel(3), pcn(3)
      logical nohead
!
      data  yfac / 1.d0, -1.d0,  1.d0, -1.d0 /
      data  zfac / 1.d0,  1.d0, -1.d0, -1.d0 /
!
      fudge   =  .999999d0
      nohead  =  .true.
!                                  zap indicator array
      call icopy (nof,  0,0,  ipnd,1)
!                                  loop over off-body point images
!!      ncnsym   =  max( 1, min( 4,  2**nsymm) )                            ! Removed by Martin Hegedus, 4/21/09
!!      do 600 icnsym = 1,ncnsym                                            ! Removed by Martin Hegedus, 4/21/09
      do 600 jj = 1,njsym                                                 ! Added by Martin Hegedus, 4/21/09
      sgnj    =  3-2*jj                                                   ! Added by Martin Hegedus, 4/21/09
!                                                                         ! Added by Martin Hegedus, 4/21/09
      do 600 ii = 1,nisym                                                 ! Added by Martin Hegedus, 4/21/09
      sgni    =  3-2*ii                                                   ! Added by Martin Hegedus, 4/21/09
      do 500 iof = 1,nof
         if ( ipnd(iof) .ne. 0 ) goto 500
         pc(1) =               p(1,iof)
!!         pc(2) =  yfac(icnsym)*p(2,iof)                                   ! Removed by Martin Hegedus, 4/21/09
!!         pc(3) =  zfac(icnsym)*p(3,iof)                                   ! Removed by Martin Hegedus, 4/21/09
         pc(2) =  sgni*p(2,iof)                                           ! Added by Martin Hegedus, 4/21/09
         pc(3) =  sgnj*p(3,iof)                                           ! Added by Martin Hegedus, 4/21/09
!                                  perform 1st pass tests using rcsq
         do 400 k = 1,nnett
         mk      =  nm(k)
         nk      =  nn(k)
!                                   set increments for panel points
         inc(1)  =  0
         inc(2)  =  mk
         inc(3)  =  mk+1
         inc(4)  =  1
!                                   loop over panels
         do 300 jp = 1,nk-1
         do 200 ip = 1,mk-1
            lpan    =  ip + (jp-1)*(mk-1) + npa(k)
            lz      =  ip + (jp-1)*mk     + nza(k)
!
            pdel(1)  =  pc(1) - zctr(1,lpan)
            pdel(2)  =  pc(2) - zctr(2,lpan)
            pdel(3)  =  pc(3) - zctr(3,lpan)
            psq      =  pdel(1)**2 + pdel(2)**2 + pdel(3)**2
            if ( psq .gt. fudge*rcsq(lpan) ) goto 200
            pz       =  pdel(1)*wctr(1,lpan)                            &
     &                 +pdel(2)*wctr(2,lpan)                            &
     &                 +pdel(3)*wctr(3,lpan)
            if ( abs(pz) .gt. fudge*tctr(lpan) ) goto 200
!                                   control point looks close: look
!                                   real hard
!!!---            write (6,6101) k,ip,jp,icnsym,iof,pc                      ! Removed by Martin Hegedus, 4/21/09
!---            write (6,6101) k,ip,jp,ii,jj,iof,pc                       ! Added by Martin Hegedus, 4/21/09
!---            call outmvc ('panel-zm',mk,2,2,zm(1,lz))
            call offch3 (pc,  zm(1,lz+inc(1)),zm(1,lz+inc(2))           &
     &                       ,zm(1,lz+inc(3)),zm(1,lz+inc(4))           &
     &                       ,zctr(1,lpan),rcsq(lpan)                   &
     &                  ,isub,pcn)
            if ( isub.eq.0 ) goto 400
               if ( nohead ) then
                  nohead = .false.
                  write (6,6102)
               endif
!
! NOTE: ipnd is not used outside of this routine                          ! Note by Martin Hegedus, 4/21/09
!       ipnd is an indicator array to show if point has already been      ! Note by Martin Hegedus, 4/21/09
!       moved, thus it is ok to change it arbitrarily.                    ! Note by Martin Hegedus, 4/21/09
!       ipnd should not be set to one                                     ! Note by Martin Hegedus, 4/21/09
!
!!               ipnd(iof) = lpan + (icnsym-1)*npant                        ! Removed by Martin Hegedus, 4/21/09
               ipnd(iof) = 1                                              ! Added by Martin Hegedus, 4/21/09
               p(1,iof) =              pcn(1)
!!               p(2,iof) = yfac(icnsym)*pcn(2)                             ! Removed by Martin Hegedus, 4/21/09
!!               p(3,iof) = zfac(icnsym)*pcn(3)                             ! Removed by Martin Hegedus, 4/21/09
!!               write (6,6100) iof, pc, pcn, icnsym,k,ip,jp                ! Removed by Martin Hegedus, 4/21/09
               p(2,iof) = sgni*pcn(2)                                     ! Added by Martin Hegedus, 4/21/09
               p(3,iof) = sgnj*pcn(3)                                     ! Added by Martin Hegedus, 4/21/09
               write (6,6100) iof, pc, pcn, ii, jj,k,ip,jp                ! Added by Martin Hegedus, 4/21/09
               goto 410
  200    continue
  300    continue
  400    continue
!                                  branch point out of search loop
  410    continue
!                                  end, loops on offbody pt images
  500 continue
  600 continue
!
      return
!
 6102 format (//,'  Summary of offbody points moved away from'          &
     &,' a subpanel boundary',/)
!! 6100 format (' offbody pt',i4,' moved from:'                           & ! Removed by Martin Hegedus, 4/21/09
!!     & ,3f11.5,' to:', 3f11.5,' (symm:',i2                              & ! Removed by Martin Hegedus, 4/21/09
!!     & ,' nw:',i3,' row:',i3,' col:',i3,')')                              ! Removed by Martin Hegedus, 4/21/09
!! 6101 format (' k,ip,jp:',3i5,'  icnsym,iof,pc:',2i5,3f12.6)              ! Removed by Martin Hegedus, 4/21/09
 6100 format (' offbody pt',i4,' moved from:'                           & ! Added by Martin Hegedus, 4/21/09
     & ,3f11.5,' to:', 3f11.5,' (isymm:',i2,' jsymm:',i2                & ! Added by Martin Hegedus, 4/21/09
     & ,' nw:',i3,' row:',i3,' col:',i3,')')                              ! Added by Martin Hegedus, 4/21/09
 6101 format (' k,ip,jp:',3i5,'  ii,jj,iof,pc:',3i5,3f12.6)               ! Added by Martin Hegedus, 4/21/09
      END subroutine offch2
! **deck offch3
      subroutine offch3 (pc,  z1,z2,z3,z4,zctr,rsq,  isub,pcn)
      implicit double precision (a-h,o-z)
      dimension pc(3), z1(3), z2(3), z3(3), z4(3), zctr(3), pcn(3)
!
!     perform a detailed check of an offbody point pc to see if
!     if lies on a panel.
!
      dimension cp(3,9), u(3), v(3), w(3), pl(3), wxp(3), qctr(3)
      dimension alf(3)
      dimension ind(3,8)
      data ind / 1,5,8,  2,6,5,  3,7,6,  4,8,7                          &
     &         , 9,8,5,  9,5,6,  9,6,7,  9,7,8 /
      data areatl /1.d-12/
      data proxtl /1.d-8/
      data theta  /.99d0/
!
      isub    =  0
      do 100 ii = 1,3
         cp(ii,1)  =  z1(ii)
         cp(ii,2)  =  z2(ii)
         cp(ii,3)  =  z3(ii)
         cp(ii,4)  =  z4(ii)
         cp(ii,5)  =  .5d0*( z1(ii) + z2(ii) )
         cp(ii,6)  =  .5d0*( z2(ii) + z3(ii) )
         cp(ii,7)  =  .5d0*( z3(ii) + z4(ii) )
         cp(ii,8)  =  .5d0*( z4(ii) + z1(ii) )
         cp(ii,9)  =  zctr(ii)
  100 continue
!
      rscale  =  sqrt(rsq)
      p33     =  1.d0/3.d0
      do 200 is = 1,8
         do 120 ii = 1,3
            u(ii)   = cp(ii,ind(2,is)) - cp(ii,ind(1,is))
            v(ii)   = cp(ii,ind(3,is)) - cp(ii,ind(1,is))
            pl(ii)  = pc(ii)           - cp(ii,ind(1,is))
            qctr(ii)= p33*( cp(ii,ind(1,is))                            &
     &                     +cp(ii,ind(2,is))                            &
     &                     +cp(ii,ind(3,is)) )
  120    continue
         w(1)    =  u(2)*v(3) - u(3)*v(2)
         w(2)    =  u(3)*v(1) - u(1)*v(3)
         w(3)    =  u(1)*v(2) - u(2)*v(1)
!                                  norm of w = 2 area of subpanel;
!                                  compare to rsq in test for null
!                                  subpanel
         wfac    =  sqrt( w(1)**2 + w(2)**2 + w(3)**2 )
! --- write (6,'('' wfac, areatl*rsq:'',i2,2e12.4)') is,wfac,areatl*rsq
         if ( wfac .lt. areatl*rsq ) goto 200
!                                  get unit normal
         wfac    =  1.d0/wfac
         w(1)    =  wfac*w(1)
         w(2)    =  wfac*w(2)
         w(3)    =  wfac*w(3)
!                                  get height above plane
         zl      =  w(1)*pl(1) + w(2)*pl(2) + w(3)*pl(3)
! ---      write (6,'('' zl, compare:'',2d12.4)') zl, proxtl*rscale
         if ( abs(zl) .gt. proxtl*rscale ) goto 200
!                                  project point down to subpanel
!                                  and get (s,t) coordinates
         wxp(1)  =  w(2)*pl(3) - w(3)*pl(2)
         wxp(2)  =  w(3)*pl(1) - w(1)*pl(3)
         wxp(3)  =  w(1)*pl(2) - w(2)*pl(1)
         alf(2)  =  wfac*( wxp(1)*v(1) + wxp(2)*v(2) + wxp(3)*v(3) )
         alf(3)  = -wfac*( wxp(1)*u(1) + wxp(2)*u(2) + wxp(3)*u(3) )
         alf(1)  =  1.d0 - alf(2) - alf(3)
         cmin    =  min( alf(1), alf(2), alf(3))
         cmax    =  max( alf(1), alf(2), alf(3))
! ---      call outvcy ('alf',3,alf)
         if ( cmin+proxtl .le. 0.d0 ) goto 200
         if ( cmax-proxtl .ge. 1.d0 ) goto 200
!                                  point lies on subpanel isub: move it
!                                  a bit putting exactly on subpanel.
            isub    =  is
!
            call dcopy (3,  qctr,1,  pcn,1)
            do 150 j = 1,3
               thalf   =  theta*alf(j)
               do 140 ii = 1,3
                  pcn(ii) = pcn(ii)                                     &
     &                      + thalf*( cp(ii,ind(j,is)) - qctr(ii) )
  140          continue
  150       continue
!                                  raise the pt slightly off surface
            call distnc (pc,pcn,dpc)
            dpn     =  .1d0*dpc
            call daxpy (3,  dpn,  w,1,  pcn,1)
            goto 300
!
  200 continue
!
  300 continue
      return
      END subroutine offch3
!!      subroutine offchk (nof,p,  nsymm,nnett,npant,nm,nn,nza,npa,zm)      ! Removed by Martin Hegedus, 4/21/09
! **deck offchk
      subroutine offchk(nof,p,nisym,njsym,nnett,npant,nm,nn,nza,npa,zm)   ! Added by Martin Hegedus, 4/21/09
      implicit double precision (a-h,o-z)
      dimension nm(nnett), nn(nnett), nza(nnett+1), npa(nnett+1)
      dimension p(3,nof), zm(3,6000)
!
!     check each off-body point in the user's list for being
!     coincident with some panel point
!
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
      call setcor ('offchk')
!                                  get parameters for the containing
!                                  cylinders
      call getcor ('zctr',llzctr,3*npant)
      call getcor ('rcsq',llrcsq,  npant)
      call getcor ('tctr',lltctr,  npant)
      call getcor ('wctr',llwctr,3*npant)
      call offch1 (nnett,npant,nm,nn,nza,npa,zm                         &
     &            ,w(llzctr),w(llrcsq),w(lltctr),w(llwctr))
!                                  perform the checks
      call igtcor ('ipnd',llipnd,nof)
!!      call offch2 (nof,p,w(llipnd),  nsymm,nnett,npant,nm,nn,nza,npa,zm & ! Removed by Martin Hegedus, 4/21/09
!!     &            ,w(llzctr),w(llrcsq),w(lltctr),w(llwctr))               ! Removed by Martin Hegedus, 4/21/09
      call offch2 (nof,p,w(llipnd),nisym,njsym,nnett,npant,nm,nn,nza,   & ! Added by Martin Hegedus, 4/21/09
     &            npa,zm,w(llzctr),w(llrcsq),w(lltctr),w(llwctr))         ! Added by Martin Hegedus, 4/21/09
!
!
      call frecor ('offchk')
      return
      END subroutine offchk
! **deck openms
      subroutine openms (lun,index,nind,istat)
      integer index(1:nind)
!
!         open a unit as a fake readms/writms file
!
!ca xrwi
      common /xrwi/ ntxrwi, nnxrwi, nwxrwi(200), nixrwi(202)
!end  xrwi
!call dictms
      common /dictms/ nrecmx(100), llindx(100), ndirwr(100)             &
     &              , rwmstr                                            &
     &              , lldict, lldmax, indxms(2,800000)                   &
     &              , buffms(512)
      integer buffms
      logical  rwmstr
!end  dictms
      character*2 iunit
      character*6 fname
      logical fexist
!
      if ( lun.lt.1 .or. lun.gt.100 ) then
         write (6,'( '' openms: unit number out of range, unit ='',i8)')&
     &        lun
         CALL AbortPanair('openms-1')
      endif
      if ( llindx(lun).ge.0 ) then
         if ( nind.ne.nrecmx(lun) ) then
            write (6,6000) lun, nrecmx(lun), nind
            call remarx('openms: attempt to change length of rwms file')
            CALL AbortPanair('openms-2')
         endif
      endif
 6000 format (' openms: attempt to reopen unit:',i4,' having',i6        &
     & ,' records as a file with',i6,' records.')
!
      if ( llindx(lun).lt.0 ) then
         llindx(lun) = lldict
         nrecmx(lun) = nind
         lldict  =  lldict + nind
         if ( lldict.gt.lldmax ) then
            write (6,6004) lun, lldict, lldmax
            call outvci ('llindx',100,llindx)
            call outvci ('nrecmx',100,nrecmx)
            call remarx ('openms: overflow of index space in /dictms/')
            CALL AbortPanair('openms-3')
         endif
      endif
      lliudx  =  llindx(lun)
!
 6004 format (' index space exceeded on unit:',i4,'  space reqd:',i12   &
     & ,'   space available:',i12                                       &
     & ,/,' to fix, change /dictms/ and lldmax init. in fee'            &
     &  )
      write (iunit,6001) lun
 6001 format (i2.2)
      fname   =  'rwmsxx'
      fname(5:6) = iunit
      inquire (file=fname,exist=fexist)
!
      if ( fexist ) then
          open (lun,file=fname,recl=2048/1                                &
     &         ,access='direct',status='old')
          read (lun,rec=1) buffms
          nindpv  =  buffms(1)
          ndirpv  =  buffms(2)
          lbkind  =  buffms(3)
          nbkind  =  buffms(4)
          if ( nindpv.ne.nind .or. rwmstr ) then
          write (6,6003) (buffms(k),k=1,4)
 6003     format (' openms: old file header ',4i6)
          endif
          if ( nindpv.ne.nind ) call exitms (lun                        &
     &       ,'cannot open existing ms file with smaller index array')
          ndirwr(lun) = ndirpv
          lliudx  =  llindx(lun)
          call pakims (lbkind,nbkind,indxms(1,lliudx+nind))
          call readms (lun,indxms(1,lliudx+1),2*nind,nind)
      else
          open (lun,file=fname,recl=2048/1                                &
     &         ,access='direct',status='new')
          buffms(1) = 0
          buffms(2) = 0
          buffms(3) = 0
          buffms(4) = 0
          write (lun,rec=1) buffms
          ndirwr(lun) = 1
          do 100 k = 1,nind
               index(k) = 0
               indxms(1,k+lliudx) = 0
               indxms(2,k+lliudx) = 0
  100     continue
      endif
!
      return
      END subroutine openms
! **deck oscale
      subroutine oscale
      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 scale the networks.
!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 inp3
      common /inp3/ ntsin,ntsout
!end  inp3
      read (ntsin,'( a )') qline
      read(qline,5000,err=9950)ak1,ak2
      k1=ak1
      k2=ak2
      read (ntsin,'( a )') qline
      read (qline,5000,err=9950)xk1,xk2,xk3
      if (xk1.eq.0.d0)xk1=1.d0
      if (xk2.eq.0.d0)xk2=1.d0
      if (xk3.eq.0.d0)xk3=1.d0
!
      do 20 kk=k1,k2
      n=nn(kk)
      m=nm(kk)
      l=nza(kk)
      do 15 i=1,n
      do 10 j=1,m
      ix=j+l
      zm(1,ix)=zm(1,ix)*xk1
      zm(2,ix)=zm(2,ix)*xk2
      zm(3,ix)=zm(3,ix)*xk3
   10 continue
      l=l+m
   15 continue
   20 continue
      return
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'scale', 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 ('scale',' program failure due to ill-formatted data')
      return
!
! *** format statements ***
 5000 format (6e10.0)
      END subroutine oscale
! **deck outmat
      subroutine outmat (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(f12.6)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      line  =  lnblnk
      write (sublin,6002) i,j1
      line(1:10) = sublin(1:10)
 6002 format (1x,i4,i4,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(i,j)
      ln2   =  ln1 + nch - 1
      if (       intgr ) write (sublin,iff) iaa
      if ( .not. intgr ) write (sublin,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   90 continue
  100 continue
!
      return
      END subroutine outmat
! **deck outmt
      subroutine outmt (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(f12.6)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      line  =  lnblnk
      write (sublin,6002) i,j1
      line(1:10) = sublin(1:10)
 6002 format (1x,i4,i4,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(i,j)
      ln2   =  ln1 + nch - 1
      if (       intgr ) write (sublin,iff) iaa
      if ( .not. intgr ) write (sublin,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   90 continue
  100 continue
!
      return
      END subroutine outmt
! **deck outmti
      subroutine outmti (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      character*10 outlab
!         print an integer matrix, a(m x n), in 20i5 format.
      integer a(na,1)
!
      outlab  =  label
      write (6,1) outlab, (j,j=1,n)
      do 20 i = 1,m
      do 20 jb = 1,n,20
          jf      =  min (n,jb+19)
          if (jb.eq.1) write (6,2) i,jb,(a(i,j),j=jb,jf)
          if (jb.ne.1) write (6,3)   jb,(a(i,j),j=jb,jf)
   20 continue
    1 format (1h0,4x,a10,20(i4,1h.),/,(15x,20(i4,1h.))   )
    2 format (5x,i4,1h.,i4,1h.,20i5)
    3 format (10x,i4,1h.,20i5)
      return
      END subroutine outmti
! **deck outmtx
      subroutine outmtx (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(1p,e12.4)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      line  =  lnblnk
      write (sublin    ,6002) i,j1
      line(1:10) = sublin(1:10)
 6002 format (1x,i4,i4,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(i,j)
      ln2   =  ln1 + nch - 1
      if (      intgr ) write (sublin       ,iff) iaa
      if ( .not.intgr ) write (sublin       ,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   90 continue
  100 continue
!
      return
      END subroutine outmtx
! **deck outmty
      subroutine outmty (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(1p,e24.16)'
      iff   = '(i24)'
      ml    =   5
      nch   =  24
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      line  =  lnblnk
      write (sublin,6002) i,j1
      line(1:10) = sublin(1:10)
 6002 format (1x,i4,i4,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(i,j)
      ln2   =  ln1 + nch - 1
      if (       intgr ) write (sublin,iff) iaa
      if ( .not. intgr ) write (sublin,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   90 continue
  100 continue
!
      return
      END subroutine outmty
! **deck outmtz
      subroutine outmtz (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(z24)'
      iff   = '(z24)'
      ml    =   5
      nch   =  24
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      line  =  lnblnk
      write (sublin,6002) i,j1
      line(1:10) = sublin(1:10)
 6002 format (1x,i4,i4,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(i,j)
      ln2   =  ln1 + nch - 1
      if (       intgr ) write (sublin,iff) iaa
      if ( .not. intgr ) write (sublin,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   90 continue
  100 continue
!
      return
      END subroutine outmtz
! **deck outmvc
      subroutine outmvc (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(3,na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix of vectors  a  using the appropriate format
!
      rff   = '(f12.6)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      do 80 k = 1,3
      line  =  lnblnk
      if ( k.eq.1 ) then
          write (sublin,6002) i,j1
          line(1:10) = sublin(1:10)
      endif
 6002 format (1x,i3,i4,1x,'x')
      if ( k.eq.2 ) line(10:10) = 'y'
      if ( k.eq.3 ) line(10:10) = 'z'
!
      ln1  =  11
      do 50 j = j1,j2
      aa    =  a(k,i,j)
      ln2   =  ln1 + nch - 1
! --- if (      intgr ) write (line(ln1:ln2),iff) iaa
      write (sublin,rff) aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   80 continue
   90 continue
  100 continue
!
      return
      END subroutine outmvc
! **deck outmvx
      subroutine outmvx (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(3,na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix of vectors  a  using the appropriate format
!
      rff   = '(1p,e12.4)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      do 80 k = 1,3
      line  =  lnblnk
      if ( k.eq.1 ) then
          write (sublin,6002) i,j1
          line(1:10) = sublin(1:10)
      endif
 6002 format (1x,i3,i4,1x,'x')
      if ( k.eq.2 ) line(10:10) = 'y'
      if ( k.eq.3 ) line(10:10) = 'z'
!
      ln1  =  11
      do 50 j = j1,j2
      aa    =  a(k,i,j)
      ln2   =  ln1 + nch - 1
! --- if (      intgr ) write (line(ln1:ln2),iff) iaa
      write (sublin,rff) aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   80 continue
   90 continue
  100 continue
!
      return
      END subroutine outmvx
! **deck outmvy
      subroutine outmvy (label,na,m,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(3,na,n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix of vectors  a  using the appropriate format
!
      rff   = '(1p,e24.16)'
      iff   = '(i24)'
      ml    =   5
      nch   =  24
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
      write (6,6001) label,m,n,na,j1,j2
 6001 format (1x,a10,2x,i4,' x ',i4, 2x,'(',i4,'),     columns ',i4     &
     &   ,' through',i4)
!
      do 90 i = 1,m
      do 80 k = 1,3
      line  =  lnblnk
      if ( k.eq.1 ) then
          write (sublin,6002) i,j1
          line(1:10) = sublin(1:10)
      endif
 6002 format (1x,i3,i4,1x,'x')
      if ( k.eq.2 ) line(10:10) = 'y'
      if ( k.eq.3 ) line(10:10) = 'z'
!
      ln1  =  11
      do 50 j = j1,j2
      aa    =  a(k,i,j)
      ln2   =  ln1 + nch - 1
! --- if (      intgr ) write (line(ln1:ln2),iff) iaa
      write (sublin,rff) aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
   80 continue
   90 continue
  100 continue
!
      return
      END subroutine outmvy
! **deck outpkv
      subroutine outpkv (label,n,v)
      implicit double precision (a-h,o-z)
      character*(*) label
      integer v(1)
      write (6,10) label, 4*n
   10 format ('  vector ',a8,'   size = ',i8)
      do 100 i = 1,n
  100 write (6,200) 4*i-3, (v(j),j=4*i-3,4*i)
  200 format (1x,i4,'. ',4i6)
      return
      END subroutine outpkv
! **deck output
      subroutine output (mxxpan,mxxdbl,mxxfg                            &
     &                  ,dvdfs,pres,za,s                                &
     &                  ,scase,smat,dmat,dblmat                         &
     &                  ,rv                                             &
     &                  )
!***created  on 78.060    w.o. no.   0   version        fee.01
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to compute and print physical flow quantities of interest    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the routine computes and prints physical flow quantities of  *
!     *  interest using the solution vector of singularity parameters.*
!     *  separate computations are performed for each angle of        *
!     *  attack/sideslip case. the first part of the routine (the loop*
!     *  terminating at statement label 299) is executed for          *
!     *  diagnostic purpose only.  it describes the singularity spline*
!     *  on each network by printing singularity strength and         *
!     *  derivatives at nine representative points on each panel.  the*
!     *  second part of the routine (the loop terminating at statement*
!     *  label 800) calculates the physical data for each network.    *
!     *  the loop terminating on statement label 600 cycles through   *
!     *  all panel center control points of a network and computes and*
!     *  prints average, upper and lower surface potentials and       *
!     *  velocities, singularity strength and gradient, and upper,    *
!     *  lower and difference pressure coefficients.  the pressure    *
!     *  coefficients are stored for use in computing network force   *
!     *  and moment coefficients by the routine fmcal.                *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   alpha     /acase/   input     angles of attack              *
!     *                                                               *
!     *   amach     /acase/   input     freestream mach number        *
!     *                                                               *
!     *   beta      /acase/   input     angles of sideslip            *
!     *                                                               *
!     *   betams    /comprs/  input     1.-(freestream mach number)**2*
!     *                                                               *
!     *   compd     /comprs/  input     compressibility direction     *
!     *                                 vector                        *
!     *                                                               *
!     *   cp        /pandq/   input     nine canonical panel points   *
!     *                                 (includes corner points,edge  *
!     *                                 midpoints and center)         *
!     *                                                               *
!     *   cpd       -local-   - - - -   difference pressure           *
!     *                                 coefficients                  *
!     *                                                               *
!     *   cpl       -local-   - - - -   lower surface pressure        *
!     *                                 coefficients                  *
!     *                                                               *
!     *   cpm       -local-   - - - -   alternate pressure            *
!     *                                 coefficients                  *
!     *                                                               *
!     *   cpu       -local-   - - - -   upper surface pressure        *
!     *                                 coefficients                  *
!     *                                                               *
!     *   cp9       -local-   - - - -   holding array for singularity *
!     *                                 strength and derivatives      *
!     *                                 at the nine representative    *
!     *                                 points                        *
!     *                                                               *
!     *   cutdat    /secprp/  output    data about the cut within     *
!     *                                 a group                       *
!     *                                                               *
!     *   dm        -local-   - - - -   normal vector to row direction*
!     *                                                               *
!     *   dn        -local-   - - - -   normal vector to column       *
!     *                                 direction           *
!     *                                                               *
!     *   ds        -local-   - - - -   directional derivatives of    *
!     *                                 doublet strength along and    *
!     *                                 normal to row and column      *
!     *                                 directions                    *
!     *                                                               *
!     *   dvdfs     /skrch1/  in/out    potential and velocity        *
!     *                                 influence coefficients        *
!     *                                                               *
!     *                                                               *
!     *   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        *
!     *                                                               *
!     *   fsv       /acase/   input     freestream velocity vectors   *
!     *                                                               *
!     *   fsvm      /acase/   input     magnitude of freestream       *
!     *                                 velocity                      *
!     *                                                               *
!     *   iacase    /acase/   -local-   index of loop over cases      *
!     *                                                               *
!     *   ic        -local-   - - - -   index of loop rangeing over   *
!     *                                 control points in network     *
!     *                                                               *
!     *   igrps     /secprp/  output    group number (often used as an*
!     *                                 index)                        *
!     *                                                               *
!     *   ihead     -local-   - - - -   logical variable used for     *
!     *                                 generating output in          *
!     *                                 paragraphs                    *
!     *                                                               *
!     *   im        -local-   - - - -   index of loop ranging         *
!     *                                 over representative columns   *
!     *                                                               *
!     *   ip        -local-   - - - -   overall panel index           *
!     *                                                               *
!     *   ipc       /cntrq/   input     index of panel on which       *
!     *                                 control point zc lies         *
!     *                                                               *
!     *   ipot      /index/   input     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              *
!     *                                                               *
!     *   isings    /prnt/    input     singularity print flag        *
!     *                                 =1 if singularity strength    *
!     *                                 on each panel is to be printed*
!     *                                                               *
!     *   jc        -local-   - - - -   overall control point index   *
!     *                                                               *
!     *   jn        -local-   - - - -   index of loop ranging         *
!     *                                 over representative rows      *
!     *                                                               *
!     *   k         -local-   - - - -   index of loop over networks   *
!     *                                                               *
!     *   l         -local-   - - - -   index of loop over degrees of *
!     *                                 freedom                       *
!     *                                                               *
!     *   m         -local-   - - - -   index of loop over panel rows *
!     *                                 in network                    *
!     *                                                               *
!     *   mmax      -local-   - - - -   number of rows in current     *
!     *                                 network                       *
!     *                                                               *
!     *   n         -local-   - - - -   index of loop over panel      *
!     *                                 columns in network            *
!     *                                                               *
!     *   nacase    /acase/   input     number of freestream cases    *
!     *                                 for simultaneous solution     *
!     *                                                               *
!     *   nc        /index/   input     array containing the number   *
!     *                                 of control points in each     *
!     *                                 network                       *
!     *                                                               *
!     *   nca       /index/   input     array containing cumulative   *
!     *                                 sum of array nc               *
!     *                                                               *
!     *   nctrt     /index/   input     total number of control points*
!     *                                                               *
!     *   netdat    /secprp/  output    data about the network's part *
!     *                                 in the group                  *
!     *                                                               *
!     *   netwrk    /secprp/  output    network number (an index)     *
!     *                                                               *
!     *   nexdgen   /exdign/  input     =1 for extra diagnostic print *
!     *                                                               *
!     *   nm        /index/   input     array containing the number   *
!     *                                 of spanwise panel points      *
!     *                                 in each network (columns)     *
!     *                                                               *
!     *   nmax      -local-   - - - -   number of columns in current  *
!     *                                 network                       *
!     *                                                               *
!     *   nn        /index/   input     array containing the number   *
!     *                                 of transverse cuts in         *
!     *                                 each network (rows)           *
!     *                                                               *
!     *   nnett     /index/   input     number of networks            *
!     *                                                               *
      implicit double precision (a-h,o-z)
!     *   npa       /index/   input     array containing cumulative   *
!     *                                 sum of array np               *
!     *                                                               *
!     *   nprcof    /fmcof/   input     pressure coefficient used for *
!                                       force calculations            *
!     *                                                               *
!     *   nsngt     /index/   input     number of total singularity   *
!     *                                 parameters                    *
!     *                                                               *
!     *   numcut    /secprp/  output    number of cuts in the group   *
!     *                                                               *
!     *   numgrp    /secprp/  output    number of groups of data      *
!     *                                                               *
!     *   numnet    /secprp/  output    number of networks in a group *
!     *                                                               *
!     *   numscd              output    number of pressure surface    *
!     *                                 conditions                    *
!     *                                                               *
!     *   nza       /index/   input     array containing running      *
!     *                                 sum of nz                     *
!     *                                                               *
!     *   ntd       /index/   input     array containing network      *
!     *                                 doublet types                 *
!     *                                                               *
!     *   nts       /index/   input     array containing network      *
!     *                                 source types                  *
!     *                                                               *
!     *   phel      -local-   - - - -   lower surface perturbation    *
!     *                                 potential                     *
!     *                                                               *
!     *   pheu      -local-   - - - -   upper surface perturbation    *
!     *                                 potential                     *
!     *                                                               *
!     *   phi       -local-   - - - -   average total potential       *
!     *                                                               *
!     *   phiai     -local-   - - - -   average total mass flux       *
!     *                                 potential                     *
!     *                                                               *
!     *   phil      -local-   - - - -   lower surface total potential *
!     *                                                               *
!     *   phili     -local-   - - - -   lower surface total mass flux *
!     *                                 potential                     *
!     *                                                               *
!     *   phiu      -local-   - - - -   upper surface total potential *
!     *                                                               *
!     *   phiui     -local-   - - - -   upper surface total mass flux *
!     *                                 potential                     *
!     *                                                               *
!     *   prcoef    /secprp/  output    pressure coefficients data for*
!     *                                 networks in a group           *
!     *                                                               *
!     *   pvl       -local-   - - - -   lower surface perturbation    *
!     *                                 velocity                      *
!     *                                                               *
!     *   pvu       -local-   - - - -   upper surface perturbation    *
!     *                                 velocity                      *
!     *                                                               *
!     *   pwd       -local-   - - - -   difference perturbation       *
!     *                                 mass flux                     *
!     *                                                               *
!     *   pwl       -local-   - - - -   lower surface perturbation    *
!     *                                 mass flux                     *
!     *                                                               *
!     *   pwm       -local-   - - - -   alternate perturbation        *
!     *                                 mass flux                     *
!     *                                                               *
!     *   pwnl      -local-   - - - -   normal component of lower     *
!     *                                 surface perturbation          *
!     *                                 mass flux                     *
!     *                                                               *
!     *   pwnu      -local-   - - - -   normal component of upper     *
!     *                                 surface perturbation          *
!     *                                 mass flux                     *
!     *                                                               *
!     *   pwu       -local-   - - - -   upper surface perturbation    *
!     *                                 mass flux                     *
!     *                                                               *
!     *   pres      /skrch1/  output    panel pressures               *
!     *                                                               *
!     *   s         /skrch1/  in/out    column from solution matrix   *
!     *                                                               *
!     *   tedsi     -local-   - - - -   integral of doublet strength  *
!     *                                 along wake leading edge       *
!     *                                                               *
!     *   tsc       -local-   - - - -   source strength and doublet   *
!     *                                 strength and gradient at given*
!     *                                 point.                        *
!     *                                 tsc(1)=source strength        *
!     *                                 tsc(2)=doublet strength       *
!     *                                 tsc(3-5)=doublet gradient in  *
!     *                                          global coordinates   *
!     *                                                               *
!     *   vl        -local-   - - - -   lower surface total velocity  *
!     *                                                               *
!     *   vnl       -local-   - - - -   normal component of lower     *
!     *                                 surface total velocity        *
!     *                                                               *
!     *   vnu       -local-   - - - -   normal component of upper     *
!     *                                 surface total velocity        *
!     *                                                               *
!     *   vu        -local-   - - - -   upper surface total velocity  *
!     *                                                               *
!     *   w         -local-   - - - -   average combined perturbation *
!     *                                 potential/mass flux vector    *
!     *                                                               *
!     *   wl        -local-   - - - -   lower surface total mass flux *
!     *                                                               *
!     *   wm        -local-   - - - -   alternate total mass flux     *
!     *                                                               *
!     *   wml       -local-   - - - -   magnitude of wl               *
!     *                                                               *
!     *   wmu       -local-   - - - -   magnitude of wu               *
!     *                                                               *
!     *   wnl       -local-   - - - -   normal component of lower     *
!     *                                 surface total mass flux       *
!     *                                                               *
!     *   wnu       -local-   - - - -   normal component of upper     *
!     *                                 surface total mass flux       *
!     *                                                               *
!     *   wtl       -local-   - - - -   magnitude of tangential       *
!     *                                 component of total lower      *
!     *                                 surface mass flux             *
!     *                                                               *
!     *   wtu       -local-   - - - -   magnitude of tangential       *
!     *                                 component of total upper      *
!     *                                 surface mass flux             *
!     *                                                               *
!     *   wu        -local-   - - - -   upper surface total mass flux *
!     *                                                               *
!     *   xyzlim    /secprp/  output    x,y,z minimum and maximum     *
!     *                                 values                        *
!     *                                                               *
!     *   z         -local-   - - - -   global coordinates of point   *
!     *                                                               *
!     *   za        -local-   - - - -   global coordinates of panel   *
!     *                                 control points for network    *
!     *                                                               *
!     *   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.                 *
!     *                                                               *
!     *   zm        /mspnts/  input     coordinates of grid points    *
!     *                                 of all networks in the        *
!     *                                 global coordinate system      *
!     *                                                               *
!     *   znc       /cntrq/   input     upper surface normal at       *
!     *                                 control point (in global      *
!     *                                 coordinates)                  *
!     *                                                               *
!     *   zncs      -local-   - - - -   upper surface co-normal at    *
!     *                                 control point (in global      *
!     *                                 coordinates)                  *
!     *                                                               *
!     *   z1        -local-   - - - -   row direction vector          *
!     *                                                               *
!     *   z2        -local-   - - - -   column direction vector       *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      logical prtsgd
!
!call trfanl
!                                                         /trfanl/
!         ptrffz    logical flag, set by inputa, used in output, indic-
!                   ating whether or not to perform trefftz analysis.
      common /trfanl/ ptrffz
      logical ptrffz
!end  trfanl
!
!call global
      common /global/ netall, netord(150)
!end  global
!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
      dimension span(5),dpan(9),itsd(150)
!call lamrwi
      common /lamrwi/ ntlam, nnlam, nilam(302)
!end  lamrwi
      integer iijj(3,3)
!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 PARAMETERS
!
!
! --- dimension dvdfs(4, nsngt), pres(3,mxxpan), za(3,mxxpan), s( nsngt)
      dimension dvdfs(4,mxsngt), pres(3,mxxpan), za(3,mxxpan), s(mxsngt)
      dimension af(3), am(3)
!call boundl
!                                                           /boundl/
      common /boundl/ itapbl, ivcorr
!end  boundl
!call titles
      common /titles/ title1(20),title2(20)
      character*4 title1, title2
!end  titles
      character*8 titch8(20)
      double precision      titrx8(20)
!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 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 fmcof
      common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof
!end  fmcof
!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 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
!call mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!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 solnt
      common/solnt/naic,nrhs,nans,nsc1,nsc2,nsc3,nsc4,iray(10),mtitle(5)
!end  solnt
!call tfmq
      common/tfmq/fc(3,3),fmc(3,3),tca
!end  tfmq
!call exdign
!                                                            /exdign/
      common/exdign/nexdgn
!end  exdign
!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 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 sortpar
!     maximum number of panels sorted
      common /sortpr/ sortmx
      integer sortmx
!     maximum number of traces per network
                                            parameter (indtrc = 100)
!end  sortpar
!
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
      common /skrch1/ ww(9000000)
!call secscr
      common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin  &
     &             , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2)
!end  secscr
      dimension rv(6,mxntpn), rvpnt(6)
      dimension scase(nsngt,4), dblmat(mxxdbl,4)
      dimension dmat(mxxfg), smat(mxxpan)
!call chkpnt
      common /chkpnt/  nckaic, nckusp
!end  chkpnt
!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
                                     ! added by RLC  16Nov96
      CHARACTER*5 rlcNames(mxnett)
      common /anwlst/ nnwlst
!end  nwlst
!call cvtrns
!                                               /cvtrns/
      common /cvtrns/ nejc
!end  cvtrns
      character*41 cvmsg
      character*3  cnw
      character*4  cerror
      dimension     cp9(3,3,3),dm(3),dn(3),ds(4),z1(3),z2(3),w(4),      &
     &wu(3),wl(3),pwu(3),pwl(3),z(3),tsc(6),zncs(3),zcs(3),fsvs(3),     &
     &zp(3),cpm(5),wm(3),pwm(3),cpu(5),cpl(5),cpd(5),pwd(3),            &
     &vu(3),vl(3),pvu(3),pvl(3),vm(3),pvm(3),tedsi(3)
      logical panctr, pctr, panerr
      dimension fsvn(3),ubl(3)
      dimension icntbl(4,150)
      dimension dval(9)
      character*10 sdval(4)
      dimension indpan(9), jndpan(9), sdchar(2)
      dimension cltrs(4), cdtrs(4), eftrs(4)
      character*80 trftit
      double precision  asprat, fsymm
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
!call ncons
      common /ncons/ pi,pi2,pi4i,twopi,pio2
!end  ncons
      dimension icard(33), isornt(150)
      dimension tmstat(12)
      double precision mxfac, myfac, mzfac
      character tempfn*6
      data sdval  /4*'          '/
      data indpan / 1,1,3,3,1,2,3,2,2 /, jndpan / 1,3,3,1,2,3,2,1,2 /
!
!
!
      data iijj /1, 8, 4, 5, 9, 7, 2, 6, 3/

  INTRINSIC:: CPU_TIME
!
      call setcor ('output')
      call getcor ('prcf',llprcf,15*npant)
      call getcor ('agpc',llagpc,12*npant)
!                                  zero out the agpspc array
      call zero (ww(llagpc),12*npant)
      call zero (tmstat,12)
      call CPU_TIME (tax)
!
      do 7000 k = 1,nnett
      netord(k) = k
 7000 continue
!     fill the network data array, netdat, with the total number of pane
!     if the network will be included in the sectional properties calcul
!
      do 5 i=1,nnett
      do 5 j=1,numgrp
        if( netdat(j,i,1) .eq. 0 ) go to 5
        netdat(j,i,1) = ( nm(i)-1 ) * ( nn(i)-1 )
        if( (ntd(i) .eq. 18 ) .or.                                      &
     &      (ntd(i) .eq. 20 )      ) netdat(j,i,1) = 0
    5 continue
!
!     diagnostic printout ***
!     do 6 j=1,numgrp
!     do 6 i=1,nnett
!     if(isecpr(igrps) .eq. 1)
!    1write(6,7) i,j,netdat(j,i,1)
!7    format(1h ,9hnetwork= ,i5,2x,7hgroup= ,i5,2x,8hnetdat= ,i9)
!6    continue
!     end diagnostic printout ***
!
!     get array sizes for sectional properties
!
      if(numgrp.gt.0)then
!
!       calculate network size limits for sectional properties
!          mxgrpn - maximum sum of panels of all networks in all groups
!          mxntp  - largest number of panels of any network in all
!                   sectional property groups
!          mxgrnt - maximum number of networks an any group
!
        mxgrpn = 0
        mxntp  = 0
        mxgrnt = 0
        do 9 i=1,numgrp
           ngrpn = 0
           nettot = 0
           do 8 j=1,nnett
              if (netdat(i,j,1) .ne. 0) then
                 numpan = npa(j+1) - npa(j)
                 numpts = nza(j+1) - nza(j)
                 ngrpn = ngrpn + numpan
                 mxntp = max0(numpan,mxntp)
                 nettot = nettot + 1
              endif
    8      continue
           mxgrpn = max0(mxgrpn,ngrpn)
           mxgrnt = max0(mxgrnt,nettot)
    9   continue
      endif
!
      ifsing  =  98
      rewind ifsing
      write (ifsing,3000) nacase,nnett
 3000 format (2i10,50x,'singparms')
      rewind nans
      do 10 iacase = 1,nacase
          read (nans) (scase(is,iacase),is=1,nsngt)
   10 continue
!
      call CPU_TIME (ta)
      do 90 k = 1,nnett
      npan    =  npa(k+1) - npa(k)
!
      do 70 ipk = 1,npan
      ip      =  ipk + npa(k)
      call mnmod (ipk,nm(k)-1,m,n)
      call strns (ip,cp)
      if ( mod(its,2).eq.0 ) go to 35
      do 30 iacase = 1,nacase
      sval    =  0.d0
      do 20 j = 1,ins
          sval    =  sval + asts(1+3*(j-1)) * scase(iis(j),iacase)
   20 continue
      call f10fmt (sval,sdval(iacase))
   30 continue
      nma     =  nm(k) - 1
      nna     =  nn(k) - 1
      if ( ipk .eq. 1 ) write (ifsing,3001) nma,nna,k
 3001 format (2i10,50x,i3,'src')
      write (ifsing,3003) sdval,m,n
 3003 format (4a10,30x,2i5)
   35 continue
      if ( its.le.1 ) go to 70
      do 60 iacase = 1,nacase
      call zero (dval,9)
      do 40 j = 1,ind
          call vadd (dval,scase(iid(j),iacase),astd(1+9*(j-1)),dval,9)
   40 continue
      do 50 kmn = 1,9
          ifine   =  2*(m-1) + indpan(kmn)
          jfine   =  2*(n-1) + jndpan(kmn)
          if (      ( mod(jfine,2).eq.1  .and.  jfine.ne.1              &
     &                                   .and.  jfine.ne.(2*nn(k)-1)   )&
     &         .or. ( mod(ifine,2).eq.1  .and.  ifine.ne.1              &
     &                                   .and.  ifine.ne.(2*nm(k)-1)   )&
     &       )  go to 50
          idub    =  (ifine+3)/2
          if ( ifine .eq. 1 ) idub = 1
          jdub    =  (jfine+3)/2
          if ( jfine .eq. 1 ) jdub = 1
          ijdub   =  idub + (jdub-1)*(nm(k)+1)
          dblmat(ijdub,iacase) = dval(kmn)
   50 continue
   60 continue
   70 continue
!
      if ( its .le. 1 ) go to 90
      mdub    =  nm(k) + 1
      ndub    =  nn(k) + 1
      write (ifsing,3002) mdub,ndub,k
 3002 format (2i10,50x,i3,'dbl')
      do 80 jdub = 1,ndub
      do 80 idub = 1,mdub
      ijdub   =  idub + (jdub-1)*mdub
      do 75 iacase = 1,nacase
      call f10fmt (dblmat(ijdub,iacase),sdval(iacase))
   75 continue
      write (ifsing,3003) sdval,idub,jdub
   80 continue
   90 continue
      call CPU_TIME (tb)
      tmstat(1) = tmstat(1) + tb - ta
!
      if( .not. (isignl .eq. 0) ) go to 91
      do 85 i=1, nnett
        if( icomtd(i) .ne. 1 ) iform(i,1) = 0
   85 continue
      go to 96
!
   91 do 92 i=1, nnett
        if( ( ntd(i) .eq. 18 ) .or.                                     &
     &      ( ntd(i) .eq. 20 )         ) iform(i,1) = 0
        if( (isignl .lt. 0 ) .and.                                      &
     &      (icomop .eq. 0 ) .and.                                      &
     &      (icomtd(i) .ne. 1)         ) iform(i,1) = 0
        if( (isignl .gt. 0 ) .and.                                      &
     &      (icomop .eq. 0 ) .and.                                      &
     &      (icomtd(i) .eq. 1 )        ) iform(i,1) = 1
   92 continue
   96 continue
!
      kvals = 0
      do 93 j=1, nnett
        if( iform(j,1) .eq. 0 ) go to 93
        kvals = kvals + 1
        isornt(kvals) = j
   93 continue
      open (unit=73,file='ffm' ,status='unknown')
      open (unit=74,file='ffmf',status='unknown')
      open (unit=75,file='fmgp',status='unknown')
      open (unit=76,file='agps',status='unknown')
      iflfm  = 73
      iflfmf = 74
      ifmggp = 75
      iagpsf = 76
!
      rewind iflfm
      rewind iflfmf
      rewind ifmggp
!
! --------------------------------------------------------
!     write headers for output files
! --------------------------------------------------------
! ** 1
!            summary of forces and moments for input configuration
!            -----------------------------------------------------
!
!         configuration is composed of the following selected networks:
!           ......................................................
!
!           sol-no  alpha  beta  cl  cd  cy  fx  fy  fz
!                                            mx  my  mz  area
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      write(iflfm,6004)
 6004 format(1h1,/,                                                     &
     &' **************************************************',            &
     &'***************************************************',            &
     &'*******************************',                                &
     &/)
      write(iflfm, 6000)
 6000 format( 30x,                                                      &
     &'    -----------------------------------------------------'       &
     &,/,30x,                                                           &
     &'       input configuration forces and moments summary    '       &
     &,/,30x,                                                           &
     &'    -----------------------------------------------------')
!
      write(iflfm, 6005)
 6005 format(/,                                                         &
     &' sol-no     alpha      beta            cl           cdi',        &
     &'            cy            fx            fy            fz',/,69x, &
     &'            mx            my            mz            area',/,   &
     &' ------   -------   -------       -------       -------',        &
     &'     ---------     ---------     ---------     ---------',       &
     &                                          '    ------------',     &
     &   /)
!
! --------------------------------------------------------
! ** 0
!            summary of forces and moments for full configuration
!            ----------------------------------------------------
!
!              symmetry conditions: misymm = ...   mjsymm = ...
!
!         configuration is composed of the following selected networks:
!           ......................................................
!
!           sol-no  alpha  beta  cl  cd  cy  fx  fy  fz
!                                            mx  my  mz  total-area
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      write(iflfmf,6003)
 6003 format(/,                                                         &
     &' **************************************************',            &
     &'***************************************************',            &
     &'*******************************',                                &
     &//)
      write(iflfmf, 6010) misym, mjsym
 6010 format( 1h0,/,30x,                                                &
     &'    -----------------------------------------------------'       &
     &,/,30x,                                                           &
     &'       full configuration forces and moments summary    '        &
     &,/,30x,                                                           &
     &'    -----------------------------------------------------'       &
     &,//,36x,                                                          &
     &'symmetry conditions: misymm = ',i3,'   mjsymm = ',i3,//,31x      &
     &)
!
      write(iflfmf,6005)
!
! --------------------------------------------------------
!     write headers for ggp file
! --------------------------------------------------------
!
! sol-no  alpha  beta  cl  cd        more
!            cy    fx  fy  fz        more
!            mx    my  mz  total-area
!
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      write (ifmggp,6020) (title1(i),i=1,18), (title2(i),i=1,18)
 6020 format ( '(f7.0,2f10.4,2f14.5,/,4f14.5,/,4f14.5)'                 &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$      ','force and moment summary'                      &
     &  ,/,   'formoms'     ,/,                                         &
     &' sol-no     alpha      beta            cl           cdi  more',/ &
     &,'            cy            fx            fy            fz  more' &
     &/,'            mx            my            mz            area')
!----x  ,/,   '*dupt'
!----x  ,/,   '*dup'
!
!
      iscrch=99
      rewind iscrch
!
      rewind nans
      rewind 13
      write(13,1007)nnett
 1007 format(/4x,7hnnett =,i5,/)
!c
!     *  loop ranges over the number of simultaneous solutions        *
!
      do 900 iacase=1,nacase
      actfx = 0.d0
      actfy = 0.d0
      actfz = 0.d0
      actmx = 0.d0
      actmy = 0.d0
      actmz = 0.d0
      actar = 0.d0
!
!     determine minimum and maximum x, y, z coordinate limits of network
      call CPU_TIME (ta)
      call getlim( nnett, nm, nn, nza, zm )
      call CPU_TIME (tb)
      tmstat(2) = tmstat(2) + tb - ta
!       initialize the pressure coefficient array, prcoef
      call zero (ww(llprcf),15*npant)
!
      write(6,1010)
 1010 format(1h1)
      call bmark('solution')
      write(6,1000) iacase
 1000 format(50x,28hsimultaneous solution number,i5,/)
      write(6,1001) amach,alpha(iacase),beta(iacase),fsvm(iacase),      &
     &betam,alpc,betc,fsv(1,iacase),fsv(2,iacase),fsv(3,iacase),compd
 1001 format(//1x,13hmach number =,f10.5,4x,17hangle of attack =,f10.5, &
     &4x,16hsideslip angle =,f10.5,4x,18hfreestream speed =,f10.5,/     &
     &1x,24hcompressibility factor =,f10.5,                             &
     &3x,33hcompressibility angle of attack =,f10.5,                    &
     &3x,35hcompressibility angle of sideslip =,f10.5,/                 &
     &1x,23hfreestream velocity = (,f10.5,1h,,f10.5,1h,,f10.5,1h),      &
     &4x,29hcompressibility direction = (,f10.5,1h,,f10.5,1h,,f10.5,1h))
      read(nans)(s(is),is=1,nsngt)
      write(13,1008)amach,alpha(iacase),beta(iacase)
 1008 format(//,4x,13hmach number =,                                    &
     &f15.5,4x,17hangle of attack =,f15.5,                              &
     &15x,16hsideslip angle =,f15.5)
!                                  isings:  value      function
!                                             0        no print
!                                             1        no print
!                                             2        ntdk=18,20 print
!                                             3        2 + (s)
!                                             4        3 + (matrix print
!                                             5        4 + old style sin
      if ( isings.lt.3 ) goto 101
      write (6,1003)
      do 100 jbeg = 1,nsngt,10
          jfin    =  min (jbeg+9,nsngt)
          write (6,1004) jbeg, (s(j),j=jbeg,jfin)
  100 continue
 1003 format (//65x,1hs)
 1004 format (1x,i5,1h.,2x, 1p,10e12.4 )
  101 continue
!
      if ( iacase.eq.1 ) call ixtrns (54,s,kklr2i*nsngt)
      call dcopy (3,  fsv(1,iacase),1,  fsvn,1)
!
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                * * * s e c t i o n   0 1 * * *                *
!     *                      - - - - - - - - - -                      *
!     *                                                               *
!     *  describe singularity spline on each network                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!c
!     *  loop ranges over the networks                                *
!
      call CPU_TIME (ta)
      do 299 k=1,nnett
      prtsgd  =  .false.
      if (  (ntd(k).eq.6 .or. ntd(k).eq.18 .or. ntd(k).eq.20)           &
     &      .and.  isings.ge.2 ) prtsgd = .true.
      if ( isings.ge.5 ) prtsgd =  .true.
      if( .not. prtsgd ) go to 115
!c
!     *  print header for this network                                *
!
      write(6,2002) k,nts(k),ntd(k)
 2002 format(////1x,14hnetwork no. = ,i3,5x,22hsource network type = ,  &
     &i3,5x,23hdoublet network type = ,i3,//)
      write(6,2000)
 2000 format(////58x,'singularity grid',///,1x,' ip ',' i',' j',        &
     &6x,1hx,9x,1hy,9x,1hz,9x,2hs0,8x,2hd0,8x,2hdx,8x,2hdy,             &
     &8x,2hdz,8x,2hdm,8x,2hdn,7x,3hdmp,7x,3hdnp,//)
  115 continue
      call zero(tedsi,3)
      npan=npa(k+1)-npa(k)
      mmax=nm(k)
!c
!     * loop ranges over the panels in the network to print           *
!     * information                                                   *
!
      do 289 ipk=1,npan
      ip=ipk+npa(k)
      call mnmod(ipk,nm(k)-1,m,n)
!c
!     * loop ranges over the nine representative points               *
!     * to store coordinates of the point                             *
!
      do 135 kmn=1,9
      call mnmod(kmn,3,im,jn)
      n1=max (n+jn-2,n)
      n2=min (n+jn-1,n+1)
      m1=max (m+im-2,m)
      m2=min (m+im-1,m+1)
      l1=m1+mmax*(n1-1)+nza(k)
      l2=m1+mmax*(n2-1)+nza(k)
      l3=m2+mmax*(n1-1)+nza(k)
      l4=m2+mmax*(n2-1)+nza(k)
!c
!     * loop ranges over the degrees of freedom (x,y,z)               *
!       to store coordinates
!
      do 120 l=1,3
  120 cp9(l,im,jn)=.25d0*(zm(l,l1)+zm(l,l2)+zm(l,l3)+zm(l,l4))
  135 continue
      if( prtsgd ) write(6,2020)
 2020 format(/)
!c
!     * retrieve singularity information                              *
!
      call strns(ip,cp)
      call psddqg
      knet = netord(k)
      irow    =  m
      jcol    =  n
      imax    =  nm(k) - 1
      jmax    =  nn(k) - 1
      call zero (span,3)
      if ( its.eq.2 ) go to 7101
      do 7100 l = 1,ins
 7100 call vadd (span,s(iis(l)),asts(1+3*(l-1)),span,3)
 7101 continue
      call zero (dpan,9)
      if ( its.eq.1 ) go to 7201
      do 7200 l = 1,ind
 7200 call vadd (dpan,s(iid(l)),astd(1+(l-1)*9),dpan,9)
 7201 continue
      do 7300 ii = 1,3
      do 7300 jj = 1,3
          ifine   =  ii + (irow-1)*2
          jfine   =  jj + (jcol-1)*2
          ij      =  iijj(ii,jj)
          ijfine    =  ifine + (jfine-1)*(2*imax+1)
          dmat(ijfine)= dpan(ij)
 7300 continue
      ijcrs   =  irow + (jcol-1)*imax
      smat(ijcrs) = span(1)
!c
!     * loop ranges over the nine representative points               *
!     * to compute and print information                              *
!
      do 200 kmn=1,9
!c
!     * determine row and column of representative within nine        *
!
      call mnmod(kmn,3,i,j)
      im=i+2*m-2
      jn=j+2*n-2
!c
!     * loop ranges over the degrees of freedom (x,y,z)               *
!
      do 140 l=1,3
      z1(l)=cp9(l,3,j)-cp9(l,1,j)
      z2(l)=cp9(l,i,3)-cp9(l,i,1)
  140 z(l)=cp9(l,i,j)
      call uvect(z1)
      z2mag = sqrt(z2(1)*z2(1)+z2(2)*z2(2)+z2(3)*z2(3))
      call uvect(z2)
      call surpro(z,zp,ic)
      ic=min (ic,5)
      call cross(en(1,ic),z1,dm)
      call cross(en(1,ic),z2,dn)
!c
!     * calculate singularity strength at z                           *
!
      call sngcal(z,s,tsc)
      call mxm (tsc(3),1,z1,3,ds(1),1)
      call mxm (tsc(3),1,z2,3,ds(2),1)
      call mxm (tsc(3),1,dm,3,ds(3),1)
      call mxm (tsc(3),1,dn,3,ds(4),1)
!c
!     * print singularity strengths at the representative point       *
!
      if( prtsgd )                                                      &
     &write(6,2001) ip,i,j,(z(iw),iw=1,3),(tsc(iw),iw=1,5),             &
     &(ds(iw),iw=1,4)
 2001 format (1x,i4,i2,i2,1x,12f10.5)
      aaafac = 4-3*mod(j,2)
      factor=-tsc(2)*z2mag*aaafac/(3.d0*fsvm(iacase)*sref)
      if((m.eq.1).and.(i.eq.1).and.((mod(ntd(k)-1,10)+1.eq.8).or.       &
     &(mod(ntd(k)-1,10)+1.eq.10)))                                      &
     &call vadd(tedsi,factor,z2,tedsi,3)
  200 continue
  289 continue
!  **  inpa  ** call outlin ("network/sd",2,k,knet)
!  **  inpa  ** call outmat ("smat",imax,imax,jmax,smat)
!  **  inpa  ** call outmat ("dmat",2*imax+1,2*imax+1,2*jmax+1,dmat)
      if ( isings.lt.4 ) goto 290
      write (6,'(1x,a10,1x, 2i12)')                                     &
     & 'network/sd',k,knet
      call outmat ('smat',imax,imax,jmax,smat)
      call outmat ('dmat',2*imax+1,2*imax+1,2*jmax+1,dmat)
  290 continue
      if ( iacase .gt. 1 ) go to 295
      irecs   =  2*knet-1
      irecd   =  2*knet
      nws     =  imax*jmax
      nwd     =  (2*imax+1)*(2*jmax+1)
!  **  inpa  ** call writms (ntlam,smat,nws,irecs,-1,0)
!  **  inpa  ** call writms (ntlam,dmat,nwd,irecd,-1,0)
      call writmd (ntlam,smat,nws,irecs,-1,0)
      call writmd (ntlam,dmat,nwd,irecd,-1,0)
  295 continue
      if( (prtsgd).and.((mod(ntd(k)-1,10)+1.eq.8).or.                   &
     &(mod(ntd(k)-1,10)+1.eq.10))) write(6,2005) tedsi
 2005 format(///4x,48hnon-dimensional integral of doublet strength = (, &
     &f15.7,1h,,f15.7,1h,,f15.7,1h),///)
  299 continue
      call CPU_TIME (tb)
      tmstat(3) = tmstat(3) + tb-ta
!                                   perform trefftz plane drag analysis
      call CPU_TIME (ta)
      if ( .not. ptrffz ) goto 500
      if (  nwtrf.le.0  ) goto 500
      call setcor ('trfftz')
      asprat  =  (bref*bref)/sref
      fsymm   =  0.d0
      if ( nsymm.gt.0 .and. misym.gt.0 ) fsymm = 1.d0
!                                   print bref, sref, asprat, fsymm
      write (6,6006) bref, sref, asprat, nsymm, misym, mjsym
 6006 format ('  Trefftz Plane Lift and Drag Analysis, '                &
     &       ,' engineering analysis performed by Gunter Brune '        &
     &,/,'  NOTE: Analysis modified 5/12/91 to treat flow antisymmetry '&
     &,/,'        Results for symmetric configurations will differ from'&
     &,/,'        earlier versions by factors of 2|4 for symmetic cases'&
     &,/,'   '                                                          &
     &  ,/,   '  Reference areas, aspect ratio and symmetry parameters' &
     & ,//, 1x,'      bref      sref       AR '                         &
     &        ,'     nsymm     misym     mjsym'                         &
     & ,/,  1x, 3f10.4, 3i10                                            &
     &  )
!
      do 310 k = 1,20
!                                   set title descriptor
         k2      =  4*k
         k1      =  k2-3
         trftit(k1:k2) = title1(k)
  310 continue
!                                   determine scratch memory requirement
      nkmax   =  0
      do 320 knw = 1,nwtrf
         knet    =  nwltrf(knw)
         nkmax   =  max(nkmax,nn(knet))
  320 continue
      nrpeat  =  1
      if ( misym.ne.0 ) nrpeat = 2
      if ( mjsym.ne.0 ) nrpeat = 2*nrpeat
      nwsymm  =  nrpeat*nwtrf
      nsctrf  =  nwtrf*nrpeat*nkmax
!                                   allocate scratch
      call igtcor ('npn', llnpn, nwtrf*nrpeat)
      call igtcor ('nwl', llnwl, nwtrf*nrpeat)
      call icopy (nwtrf,  nwltrf,1,  ww(llnwl),1)
      call getcor ('ylef',llylef,nsctrf)
      call getcor ('yrit',llyrit,nsctrf)
      call getcor ('zlef',llzlef,nsctrf)
      call getcor ('zrit',llzrit,nsctrf)
      call getcor ('dylf',lldylf,nsctrf)
      call getcor ('dyrt',lldyrt,nsctrf)
      call getcor ('dzlf',lldzlf,nsctrf)
      call getcor ('dzrt',lldzrt,nsctrf)
      call getcor ('psi', llpsi, nsctrf)
      call getcor ('dcd', lldcd, nsctrf)
      call getcor ('xil', llxil, nsctrf)
      call getcor ('xir', llxir, nsctrf)
!                                  do the analysis
      srefrp  =  sref*nrpeat
      call trfftz (nwtrf,nwsymm,ww(llnwl),s,misym,mjsym, cltr,cdtr,eftr &
     &            ,trftit,fsymm,sref,asprat,ww(llnpn)                   &
     &            ,ww(llylef),ww(llyrit),ww(llzlef),ww(llzrit)          &
     &            ,ww(lldylf),ww(lldyrt),ww(lldzlf),ww(lldzrt)          &
     &            ,ww(llpsi), ww(lldcd), ww(llxil), ww(llxir)           &
     &            )
      cltrs(iacase) = cltr
      cdtrs(iacase) = cdtr
      eftrs(iacase) = eftr
      call frecor ('trfftz')
  500 continue
      call CPU_TIME (tb)
      tmstat(4) = tmstat(4) + tb-ta
!
!
      write(iscrch)iacase
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                * * * s e c t i o n   0 2 * * *                *
!     *                      - - - - - - - - - -                      *
!     *                                                               *
!     *  calculate physical data for each network                     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      betmsi=1.d0/betams
      call zero(fc,19)
      ncver   =  0
!c
!     *  loop ranges over the number of networks to print physical    *
!     *  data                                                         *
!
      do 800 k=1,nnett
      call CPU_TIME (ta)
          netwrk = k
      nrow=nm(k)-1
      ncol=nn(k)-1
!
      write(iscrch)nrow,ncol
!
      icntbl(iacase,k)=0
!
!
!
      ipotm=ipot(k)
      if(ipotm.gt.2) ipotm=ipotm-2
      if(ipotm.lt.-2) ipotm=ipotm+2
      kmatl   =  matnet(2,k)
      kmatu   =  matnet(1,k)
      if ( ipotm.eq.1 ) kmatm = kmatu
      if ( ipotm.eq.-1) kmatm = kmatl
      nck=nca(k+1)-nca(k)
      call cmngrd (k,mcpnet,ncpnet)
      ncpold  =  0
      jhead  =  0
      ihead=0
      npcncp  =  0
      ncverk  =  0
!c
!     *  loop ranges over the number of control points in the network *
!     *  to calculate and print physical quantities                   *
!
      write (13,3300) nwname(k),k,nts(k),ntd(k),nrow,ncol
      do 600 ic=1,nck
      jc=ic+nca(k)
!c
!     *  retrieve control point information                           *
!
      call ctrns(jc,zc)
!c
!     *  if zc is edge control point skip flow properties calculation *
!
      panctr  =  .false.
      if ( zdc.eq.0.d0 ) panctr = .true.
      if (  panctr   ) npcncp = npcncp + 1
      if ( zdc.eq.0.d0 ) go to 502
      if ( zdc.lt.0.d0 .and. nexdgn.ne.0 ) go to 502
      if ( zdc.gt.0.d0 .and. nexdgn.ne.0 .and. iabs(ipotm).eq.2 )       &
     &    go to 502
!                                  no reason has been found to generate
!                                  flow data.  go to next control point
          go to 600
!
  502 continue
!c
!     *  if ten control points done, do page eject and retitle        *
!
 3300 format (1h1,/,4x,'network id:',a10,'  index:',i4,                 &
     &  4x,'source type =',i3,4x,'doublet type =',i3,                   &
     &  6x,'number rows =',i4,4x,'number columns =',i4,/)
 3400 format(2x,2hjc,3x,2hip,8x,1hx,10x,1hy,10x,1hz,10x,2hd0,9x,2hdx,   &
     &       9x,2hdy,9x,2hdz,9x,2hs0,8x,3hanx,8x,3hany,8x,3hanz)
 3401 format(2x,6hlmachu,8x,3hwxu,8x,3hwyu,8x,3hwzu,7x,4hpheu,7x,3hvxu, &
     &       8x,3hvyu,8x,3hvzu,7x,6hcplinu,5x,6hcpslnu,5x,6hcp2ndu,     &
     &       5x,6hcpisnu)
 3402 format(2x,6hlmachl,8x,3hwxl,8x,3hwyl,8x,3hwzl,7x,4hphel,          &
     &       7x,3hvxl,8x,3hvyl,8x,3hvzl,7x,6hcplinl,5x,6hcpslnl,        &
     &       5x,6hcp2ndl,5x,6hcpisnl)
 3403 format(5x,3hwnu,8x,3hwnl,8x,4hpwnu,7x,4hpwnl,6x,3hvtu,8x,3hvtl,   &
     &       8x,4hpvtu,7x,4hpvtl,6x,6hcplind,5x,6hcpslnd,5x,6hcp2ndd,   &
     &       5x,6hcpisnd)
!
!
      if(mod(ihead,10).ne.0)go to 301
!
      if (ioutpr.ne.1 ) go to 505
      write (6,3300) nwname(k),k,nts(k),ntd(k),nrow,ncol
      write(6,3400)
      write(6,3401)
      if(ipotm.eq.1)write(6,3401)
      write(6,3402)
      if(ipotm.eq.-1)write(6,3402)
      write(6,3403)
!
  505 continue
!
!
!        write identical headers on tape13.
!
!
      if(ihead.gt.0)write(13,3301)
 3301 format(1h1)
      write(13,4400)
 4400 format (/,2x,2hjc,3x,2hip,8x,1hx,10x,1hy,10x,1hz,10x,2hd0,9x,2hdx,&
     &9x,2hdy,9x,2hdz,9x,2hs0,8x,3hanx,8x,3hany,8x,3hanz)
      write(13,3401)
      if(ipotm.eq.1)write(13,3401)
      write(13,3402)
      if(ipotm.eq.-1)write(13,3402)
      write(13,4403)
 4403 format(5x,3hwnu,8x,3hwnl,8x,4hpwnu,7x,4hpwnl,8x,3hvtu,8x,3hvtl,   &
     &       8x,4hpvtu,7x,4hpvtl,6x,6hcplind,5x,6hcpslnd,5x,6hcp2ndd,   &
     &       5x,6hcpisnd/)
  301 continue
!
!                   generate short print header
!
      call mnmod (jzc,nm(k)+1,mcp,ncp)
      if ( ioutpr.ne.2 .or. mod(jhead,50).eq.0 .or. ncpold.eq.0 )       &
     &    go to 510
      if ( ncpold.eq.ncp ) go to 510
          write (6,5500)
          jhead  =  jhead + 1
  510 continue
      ncpold  =  ncp
      if ( ioutpr.ne.2  .or.  mod(jhead,50).ne.0 ) go to 512
      write (6,5300) nwname(k),k,nts(k),ntd(k),nrow,ncol
      write (6,5500)
      write (6,5400)
 5300 format (1h1  ,4x,'network id:',a10,'  index:',i4,                 &
     &  4x,'source type =',i3,4x,'doublet type =',i3,                   &
     &  6x,'number rows =',i4,4x,'number columns =',i4,/)
 5400 format (4x,2hjc,3x,2hip,9x,1hx,10x,1hy,10x,1hz,9x,2hwx,9x,2hwy    &
     &   ,9x,2hwz,6x,6hcp2ndu,5x,6hcpisnu,5x,6hlmachu,5x,6hsource,4x,   &
     &    7hdoublet )
      write (6,5500)
 5500 format (1h )
  512 continue
!
!
!
      ihead=ihead+1
      jhead  =  jhead + 1
      ip=ipc
      ipk=ip-npa(k)
      if ( .not. panctr ) go to 514
      call dcopy (3,zc,1,za(1,ipk),1)
  514 continue
!c
!     *  retrieve panel defining quantities                           *
!
      call strns(ip,cp)
!                                  if kabmtc.lt.0, znc was redefined. fi
      isubrg  =  min (icc,5)
      if ( kabmtc.lt.0 ) call xfera (en(1,isubrg),znc,3)
!                                  if kabmtc.lt.0, znc was redefined. fi
!c
!     *  calculate source strength and doublet strength and gradient  *
!     *  at control point                                             *
!
      call sngcal(zc,s,tsc)
!c
!     *  retrieve velocity/potential                                  *
!
      call dcopy (4*nsngt,  0.d0,0,  dvdfs,1)
      if(nckaic.eq.2)go to 530
      call vtrns(jc,dvdfs)
      instag  =  iabs(ipot(k))
      if ( ( instag.eq.0 .or. instag.eq.1 .or. instag.eq.3 )            &
     &     .and.  (nejc.ne.4) ) then
          ncverk  =  ncverk +  1
          if ( ncverk.ne.1 .or. iacase.ne.1 ) goto 515
!---------cvmsg  = '1234567890123456789012345678901234567890'
          cvmsg  = 'missing vic data, network xxx=1234567890'
          write (cnw,'(i3)') k
          cvmsg(27:29) = cnw
          cvmsg(31:40) = nwname(k)
          call remarx (cvmsg)
  515     continue
      endif
!
!     *  calculate average perturbation mass flux vector              *
!
      call mxm (dvdfs,4,s,nsngt,w,1)
      call cmpscl(betams,compd,w(2),w(2))
  530 continue
      if(nckaic.eq.2)w(1)=0.d0
!
!     *  calculate difference perturbation mass flux vector           *
!
      call cmpscl(betams,compd,znc,zncs)
      call mxm (zncs,1,znc,3,factor,1)
      call vadd(tsc(3),tsc(1)/factor,znc,pwd,3)
      call cmpscl(betams,compd,pwd,pwd)
      iapot=iabs(ipotm)
      instag  =  iabs(ipot(k))
!                                  define material index for u/l/m surfa
!                                  n.b.: m denotes the wetted surface wh
!                                  stagnation bc's are used.  note that
!                                  nation is always defined in terms of
!                                  the freestream of 'air', kmat = 0.
      kmatu   =  matnet(1,k)
      kmatl   =  matnet(2,k)
      kmatm   =  0
      if ( ipot(k).gt.0 ) kmatm = kmatu
      if ( ipot(k).lt.0 ) kmatm = kmatl
      rcu     =  rcnmat(kmatu)
      rcl     =  rcnmat(kmatl)
      rcm     =  rcnmat(kmatm)
!
      vfu     =  vfmat(kmatu)
      vfl     =  vfmat(kmatl)
      vfm     =  vfmat(kmatm)
!
      wfu     =  wfmat(kmatu)
      wfl     =  wfmat(kmatl)
      wfm     =  wfmat(kmatm)
!
!     *  compute upper and lower surface mass flux vectors            *
!
      amachm   =  0.d0
      call dcopy (5,  0.d0,0,  cpm,1)
      call dcopy (3,  0.d0,0,  wm,1)
      call dcopy (3,  0.d0,0,  vm,1)
      do 550 i=1,3
      if(ipot(k).eq.2) w(i+1)=.5d0*pwd(i)
      if(ipot(k).eq.-2) w(i+1)=-.5d0*pwd(i)
      if(ipot(k).eq.4) w(i+1)=.5d0*pwd(i)-fsv(i,iacase)
      if(ipot(k).eq.-4) w(i+1)=-.5d0*pwd(i)-fsv(i,iacase)
      pwl(i)=w(i+1)-.5d0*pwd(i)
      pwu(i)=w(i+1)+.5d0*pwd(i)
      wu(i)   =  fsv(i,iacase) + pwu(i)
      wl(i)   =  fsv(i,iacase) + pwl(i)
      wm(i)   =  0.d0
      pwm(i)  =  0.d0
      if ( iapot.ne.1 ) goto 550
          if ( ipotm.eq. 1 ) pwm(i) =  pwd(i)
          if ( ipotm.eq.-1 ) pwm(i) = -pwd(i)
          if ( instag.eq.3 ) pwm(i) = pwm(i) - fsv(i,iacase)
          wm(i)   =  fsv(i,iacase) + pwm(i)
  550 continue
      call cmpscl(betmsi,compd,pwu,pvu)
      call cmpscl(betmsi,compd,pwl,pvl)
      if ( iapot.eq.1 ) call cmpscl(betmsi,compd,pwm,pvm)
      do 560 i=1,3
      vu(i)   =  fsv(i,iacase) + pvu(i)
      vl(i)   =  fsv(i,iacase) + pvl(i)
      if ( iapot.eq.1 ) vm(i)   =  fsv(i,iacase) + pvm(i)
  560 continue
!
!     *  compute various components of mass flux vectors              *
!
      call mxm (znc,1,wu,3,wnu,1)
      call mxm (znc,1,wl,3,wnl,1)
      call mxm (znc,1,pwu,3,pwnu,1)
      call mxm (znc,1,pwl,3,pwnl,1)
      call cross(znc,pvu,z)
      pvtu = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call cross(znc,pvl,z)
      pvtl = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call cross(znc,vu,z)
      vtu = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call cross(znc,vl,z)
      vtl = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call mxm (znc,1,vl,3,vnl,1)
      call mxm (znc,1,vu,3,vnu,1)
!
!     *  compute upper and lower surface pressure coefficients        *
!
      call cpcal (kmatu,pvu,fsv(1,iacase),betams,compd,cpu)
      call cpcal (kmatl,pvl,fsv(1,iacase),betams,compd,cpl)
      if ( iapot.eq.1 )                                                 &
     &call cpcal (kmatm,pvm,fsv(1,iacase),betams,compd,cpm)
      do 575 i=1,5
!c
!     *  add momentum transfer terms to calculate effective           *
!     *  pressure coefficients                                        *
!
      if(ipotm.eq.1) cpm(i)=cpm(i)+2.d0*wnu*vnu/fsvm(iacase)**2
      if(ipotm.eq.-1) cpm(i)=cpm(i)+2.d0*wnl*vnl/fsvm(iacase)**2
  575 cpd(i)=cpu(i)-cpl(i)
      if ( .not. panctr ) go to 594
      pres(1,ipk)=cpu(nprcof)
      if(ipotm.eq.1) pres(1,ipk)=cpm(nprcof)
      pres(2,ipk)=cpl(nprcof)
      if(ipotm.eq.-1) pres(2,ipk)=cpm(nprcof)
      pres(3,ipk)=cpd(nprcof)
  594 continue
!                                  if required, perform velocity correct
      if ( ivcorr .le. 0 ) go to 595
      call velcor (ivcorr,fsv(1,iacase),fsvm(iacase),compd,amach,wu,vu)
      call velcor (ivcorr,fsv(1,iacase),fsvm(iacase),compd,amach,wl,vl)
      if ( iapot.eq.1 )                                                 &
     &call velcor (ivcorr,fsv(1,iacase),fsvm(iacase),compd,amach,wm,vm)
      call vadd (vu, -1.d0, fsv(1,iacase), pvu, 3)
      call vadd (vl, -1.d0, fsv(1,iacase), pvl, 3)
      if ( iapot.eq.1 )                                                 &
     &call vadd (vm, -1.d0, fsv(1,iacase), pvm, 3)
      call cpcal (kmatu,pvu,fsv(1,iacase),betams,compd,cpu)
      call cpcal (kmatl,pvl,fsv(1,iacase),betams,compd,cpl)
      if ( iapot.eq.1 )                                                 &
     &call cpcal (kmatm,pvm,fsv(1,iacase),betams,compd,cpm)
      call cross(znc,pvu,z)
      pvtu = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call cross(znc,pvl,z)
      pvtl = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call cross(znc,vu,z)
      vtu = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call cross(znc,vl,z)
      vtl = sqrt(z(1)*z(1)+z(2)*z(2)+z(3)*z(3))
      call mxm (znc,1,vl,3,vnl,1)
  595 continue
!
!     *  compute upper and lower surface potentials                   *
!
      pheu=w(1)+.5d0*tsc(2)
      phel=w(1)-.5d0*tsc(2)
      anx=znc(1)*aj(5)*c(1,1)/sref
      any=znc(2)*aj(5)*c(1,1)/sref
      anz=znc(3)*aj(5)*c(1,1)/sref
      call mxm (vu,1,wu,3,amachu,1)
      amachu=amach*sqrt(max(0.d0,amachu/fsvm(iacase)**2)/               &
     &max(1.d-06,1.d0+.7d0*amach*amach*cpu(nprcof)))
      amachu=min(1.d3,amachu)
      amachu  =  sqrt( cpfmat(kmatu) )*amachu
!---- call machvl (kmatu,pvu,amachu)
      call mxm (vl,1,wl,3,amachl,1)
      amachl=amach*sqrt(max(0.d0,amachl/fsvm(iacase)**2)/               &
     &max(1.d-06,1.d0+.7d0*amach*amach*cpl(nprcof)))
      amachl=min(1.d3,amachl)
      amachl  =  sqrt( cpfmat(kmatl) )*amachl
!---- call machvl (kmatl,pvl,amachl)
      if(iapot.ne.1) go to 596
      call mxm (vm,1,wm,3,amachm,1)
      amachm=amach*sqrt(max(0.d0,amachm/fsvm(iacase)**2)/               &
     &max(1.d-06,1.d0+.7d0*amach*amach*cpm(nprcof)))
      amachm=min(1.d3,amachm)
      amachm  =  sqrt( cpfmat(kmatm) )*amachm
!---- call machvl (kmatm,pvm,amachm)
  596 continue
!                                  apply material property factors to ve
!                                  and mass flux quantities (but leave p
!                                  alone as a phi(star) type quantity).
!                                  note that cp type quantities were tre
!                                  in cpcal.
      call dscal (3,  vfu,  vu,1)
      vtu     =  vfu*vtu
      pvtu    =  vfu*pvtu
      call dscal (3,  wfu,  wu,1)
      wnu     =  wfu*wnu
      pwnu    =  wfu*pwnu
!
      call dscal (3,  vfl,  vl,1)
      vtl     =  vfl*vtl
      pvtl    =  vfl*pvtl
      call dscal (3,  wfl,  wl,1)
      wnl     =  wfl*wnl
      pwnl    =  wfl*pwnl
!
      if ( iapot.eq.1 ) call dscal (3,  vfm,  vm,1)
      if ( iapot.eq.1 ) call dscal (3,  wfm,  wm,1)
!
!     *  print flow quantities of interest                            *
!
      if ( ioutpr.ne.1 ) go to 597
      write(6,3500) jc,ip,zc,(tsc(iw),iw=2,5),tsc(1),anx,any,anz
      if(ipotm.eq.1) write(6,3600) amachm,wm,pheu,vm,(cpm(i),i=1,4)
      write(6,3600) amachu,wu,pheu,vu,(cpu(i),i=1,4)
      write(6,3600) amachl,wl,phel,vl,(cpl(i),i=1,4)
      if (ipotm.eq.-1) write (6,3600) amachm,wm,phel,vm,(cpm(i),i=1,4)
      write(6,3600) wnu,wnl,pwnu,pwnl,vtu,vtl,pvtu,pvtl,(cpd(i),i=1,4)
  597 continue
      if ( ioutpr.ne.2 ) go to 598
      write (6,5600) jc,ip,zc,wu,cpu(3),cpu(4),amachu,tsc(1),tsc(2)
 5600 format (1x,i5,i5,11f11.4)
  598 continue
!
!
!        write the flow quantities on tape13.
!
!
      call wxtrct (ipotm,jc,ip  ,zc,tsc,anx,any,anz                     &
     &            ,amachm,wm,vm,cpm                                     &
     &            ,amachu,wu,vu,cpu,pheu  ,wnu,pwnu,vtu,pvtu            &
     &            ,amachl,wl,vl,cpl,phel  ,wnl,pwnl,vtl,pvtl            &
     &            ,cpd)
!
!
 3500 format(/,i5,i6,11f11.4)
 3600 format(12f11.4)
!
!                                  generate an output file to be used as
!                                  an input to the boundary layer progra
!
      if(itapbl.eq.0)go to 600
      if ( zdc .ne. 0.d0 ) go to 600
!
!                        determine row and column indices for
!                        the current control point
!
      call mnmod(ipk,nrow,ii,jj)
!
!              mclean correction to the velocity vector
!
!              date 4-23-80
!
      call zero (ubl,3)
      if ( ivcorr.eq.0 .and. ipotm.gt.0 ) call dcopy (3,wu,1,ubl,1)
      if ( ivcorr.eq.0 .and. ipotm.lt.0 ) call dcopy (3,wl,1,ubl,1)
      if ( ivcorr.ne.0 .and. ipotm.gt.0 ) call dcopy (3,vu,1,ubl,1)
      if ( ivcorr.ne.0 .and. ipotm.lt.0 ) call dcopy (3,vl,1,ubl,1)
      write(iscrch)ii,jj,zc,ubl
      icntbl(iacase,k)=icntbl(iacase,k)+1
  600 continue
      ncver   =  ncver + ncverk
      call CPU_TIME (tb)
      tmstat(5) = tmstat(5) + tb-ta
      if ( npcncp.eq.0 ) go to 800
!
!     *  compute forces and moments                                   *
!
      jacase = iacase
      call CPU_TIME (ta)
!
!                                  print panel center pressures for
!                                  design wake networks
      if ( ntd(k).ne.6 ) goto 650
      write (6,5200) nwname(k),k
 5200 format ('   panel center pressures, nw name: ',a10,'  index:',i5  &
     &       ,'  [cpu/cpl/cpd]   ')
      call outmvc ('      ',nrow,nrow,ncol,pres)
  650 continue
      call fmcal(pres,nrow,ncol,npa(k),za,npant,ww(llprcf),ww(llagpc))
      call CPU_TIME (tb)
      tmstat(6) = tmstat(6) + tb-ta
  800 continue
      if ( ncver.gt.0 ) then
!---------cvmsg  = '1234567890123456789012345678901234567890'
          cvmsg  = 'missing vic data for case x at xxxx cp-s'
          write (cnw,'(i3)') iacase
          cvmsg(27:27) = cnw(3:3)
          write (cerror,'(i4)') ncver
          cvmsg(32:35) = cerror
          call remarx (cvmsg)
      endif
      call CPU_TIME (ta)
      ra = pi/180.d0
      aarg = alpha(iacase) * ra
      barg = beta (iacase) * ra
      sina = sin( aarg )
      cosa = cos( aarg )
      sinb = sin( barg )
      cosb = cos( barg )
!
      actcl = - sina*cosb*actfx + sina*sinb*actfy + cosa*actfz
      actcd = + cosa*cosb*actfx - cosa*sinb*actfy + sina*actfz
      actcy =        sinb*actfx +      cosb*actfy
!
!     write to force and moment summary file - input configuration
      write(iflfm, 6030) iacase, alpha(iacase), beta(iacase),           &
     &                   actcl, actcd, actcy, actfx, actfy, actfz,      &
     &                   actmx, actmy, actmz, actar
 6030 format(i7,2f10.4,6f14.5,/,69x,3f14.5,f16.5,/)
!
      clfac = 1.d0
      cdfac = 1.d0
      cyfac = 1.d0
      fxfac = 1.d0
      fyfac = 1.d0
      fzfac = 1.d0
      mxfac = 1.d0
      myfac = 1.d0
      mzfac = 1.d0
      tcfac = 1.d0
!!                                                                          ! Removed by Martin Hegedus, 4/21/09
!!      if( .not.((misym .gt. 0) .or.  (mjsym .gt. 0))) go to 910           ! Removed by Martin Hegedus, 4/21/09
!!        clfac=clfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        cdfac=cdfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        cyfac=cyfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        fxfac=fxfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        fyfac=fyfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        fzfac=fzfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        mxfac=mxfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        myfac=myfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        mzfac=mzfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        tcfac=tcfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!  910 continue                                                            ! Removed by Martin Hegedus, 4/21/09
!!!                                                                         ! Removed by Martin Hegedus, 4/21/09
!!      if( .not.((misym .gt. 0) .and. (mjsym .gt. 0))) go to 920           ! Removed by Martin Hegedus, 4/21/09
!!        clfac=clfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        cdfac=cdfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        cyfac=cyfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        fxfac=fxfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        fyfac=fyfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        fzfac=fzfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        mxfac=mxfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        myfac=myfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        mzfac=mzfac*0.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!        tcfac=tcfac*2.d0                                                  ! Removed by Martin Hegedus, 4/21/09
!!  920 continue                                                            ! Removed by Martin Hegedus, 4/21/09
!                                                                         ! Added by Martin Hegedus, 4/21/09
      if( .not.(misym .gt. 0)) go to 910                                  ! Added by Martin Hegedus, 4/21/09
        clfac=clfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        cdfac=cdfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        cyfac=cyfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        fxfac=fxfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        fyfac=fyfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        fzfac=fzfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        mxfac=mxfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        myfac=myfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        mzfac=mzfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        tcfac=tcfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
  910 continue                                                            ! Added by Martin Hegedus, 4/21/09
!                                                                         ! Added by Martin Hegedus, 4/21/09
      if( .not.(mjsym .gt. 0)) go to 920                                  ! Added by Martin Hegedus, 4/21/09
        clfac=clfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        cdfac=cdfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        cyfac=cyfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        fxfac=fxfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        fyfac=fyfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        fzfac=fzfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        mxfac=mxfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        myfac=myfac*0.d0                                                  ! Added by Martin Hegedus, 4/21/09
        mzfac=mzfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
        tcfac=tcfac*2.d0                                                  ! Added by Martin Hegedus, 4/21/09
  920 continue                                                            ! Added by Martin Hegedus, 4/21/09
!
      actclf = actcl*clfac
      actcdf = actcd*cdfac
      actcyf = actcy*cyfac
      actfxf = actfx*fxfac
      actfyf = actfy*fyfac
      actfzf = actfz*fzfac
      actmxf = actmx*mxfac
      actmyf = actmy*myfac
      actmzf = actmz*mzfac
      tcaf   = actar*tcfac
!
!     write to force and moment summary file - full configuration
      write(iflfmf, 6030) iacase, alpha(iacase), beta(iacase),          &
     &                   actclf, actcdf, actcyf, actfxf, actfyf,        &
     &                   actfzf,actmxf, actmyf, actmzf, tcaf
      if ( ptrffz )                                                     &
     &  write (iflfmf, 6041) cltrs(iacase), cdtrs(iacase), eftrs(iacase)
 6041 format (' Trefftz plane analysis:     cl = ',e13.6,               &
     &  '  cdi = ',e13.6,'   eff = ',e13.6 )
!
! --------------------------------------------------------
!     write ggp file with force and moment summary data
! --------------------------------------------------------
!   ggp output-data format:
!
!   sol-no     alpha      beta            cl            cd  more
!              cy            fx            fy            fz
!              mx            my            mz    total-area
!  iiiiiii ffff.ffff ffff.ffff fffffff.fffff fffffff.fffff
!  ffffffff.fffff fffffff.fffff fffffff.fffff fffffff.fffff
!  ffffffff.fffff fffffff.fffff fffffff.fffff fffffff.fffff
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!
      write(ifmggp, 6040) iacase, alpha(iacase), beta(iacase),          &
     &                   actclf, actcdf, actcyf, actfxf, actfyf,        &
     &                   actfzf,actmxf, actmyf, actmzf, tcaf
 6040 format(i7,2f10.4,2f14.5,/,4f14.5,/,3f14.5,f16.5)
!--    write (ifmggp, 6041) cltrs(iacase), cdtrs(iacase), eftrs(iacase)
! --------------------------------------------------------
!
!
!     compute sectional properties
      if (numgrp .gt. 0) then
      call setcor ('sectnp')
         call igtcor ('ips',llips,mxgrpn)
         call igtcor ('ipvf',llipvf,2*mxntp)
         call igtcor ('itcsa',llitcs,mxgrnt*(indtrc+1))
         call igtcor ('ntrnet',llntrn,mxgrnt)
         call igtcor ('netind',llneti,2*indtrc*mxgrnt)
         call igtcor ('isrnt',llisrn,nnett)
         call igtcor ('isrsr',llisrs,3*nnett)
         call igtcor ('isinfo',llisin,4*mxgrnt*indtrc)
         call igtcor ('ntrstr',llntrs,mxgrnt*indtrc)
         call getcor ('arry',llarry,21*mxgrpn)
         call igtcor ('nmgp',llnmgp,mxgrnt)
         call igtcor ('nngp',llnngp,mxgrnt)
         call igtcor ('npagp',llnpag,mxgrnt+1)
         call igtcor ('itvf',llitvf,2*indtrc*mxgrnt)
!!!         call sectnp (zm,ww(llisrn),ww(llisrs),nwname
         call sectnp (zm,ww(llisrn),rlcNames,nwname                     &
     &               ,ww(llips),ww(llipvf),ww(llarry),ww(llprcf)        &
     &               ,mxgrpn,mxgrnt,mxntp,indtrc                        &
     &               ,ww(llitcs),ww(llntrn),ww(llisin),ww(llntrs)       &
     &                                                ,ww(llneti)       &
     &               ,ww(llnmgp),ww(llnngp),ww(llnpag),npant,ww(llitvf))
      call frecor ('sectnp')
      endif
      call CPU_TIME (tb)
      tmstat(7) = tmstat(7) + tb-ta
!
!     end loop on simultaneous solutions
  900 continue
!
!     open ggp file by writing format of ggp file
      nap3    =  nacase + 3
      write (iagpsf,7501) nap3, (title1(i),i=1,18), (title2(i),i=1,18)
 7501 format ('(f5.0,'  ,i1,   'f13.4)'                                 &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$      ','second order pressures at grid points'         &
     &  ,/,   '*dupt'                                                   &
     &  ,/,   '*dup'                                                    &
     &   )
!                                  put data to ggp file, 1 nw at a time
      call CPU_TIME (ta)
      do 960 k=1,nnett
        call setcor ('agpsfl')
        netwrk = k
        nmk    = nm(netwrk)
        nnk    = nn(netwrk)
        nzk    = nza(netwrk) + 1
        npak   = npa(netwrk)
        call getcor ('pndt',llpndt,16*nmk*nnk)
        call agpsfl (nacase,  zm(1,nzk),nmk,nnk,npak,netwrk             &
     &              ,npant,ww(llagpc),ww(llpndt))
        call frecor ('agpsfl')
  960 continue
      call CPU_TIME (tb)
      tmstat(8) = tmstat(8) + tb-ta
!
!
      write(iflfmf,6003)
!
      write(iflfmf,7400)                                                &
     & (isornt(j),iduser(isornt(j)),j=1,kvals)
 7400 format(1h1,//,1x,                                                 &
     &'configuration is composed of the following selected networks',/, &
     &   5(3x,i4,1x,a))
      if( (isignl .le. 0) .and. (icomop .eq. 0) ) write(iflfmf,6500)
      if( (isignl .gt. 0) .and. (icomop .eq. 0) ) write(iflfmf,6501)
      if( (isignl .lt. 0) .and. (icomop .eq. 1) ) write(iflfmf,6502)
      if( (isignl .gt. 0) .and. (icomop .eq. 1) ) write(iflfmf,6503)
 6500 format(/,' note: these networks are all   kt=1   types',/)
 6501 format(/,' note: networks were added to the   kt=1  types',/)
 6502 format(/,' note: networks were removed from all networks',/)
 6503 format(/,' note: these networks were specifically selected',/)
      write(iflfmf,7411) sref,xref,yref,zref,cref,bref,dref
 7411 format(/,' reference conditions are:',/,                          &
     &         ' sref = ',f20.5,' xref = ',f20.5,' yref = ',f20.5,      &
     &         ' zref = ',f20.5,/,                                      &
     &         '        ',20x,  ' cref = ',f20.5,' bref = ',f20.5,      &
     &         ' dref = ',f20.5)
      write(iflfmf,6003)
!
      if( (isignl .eq. 0) .and. (icomop .eq. 1) ) go to 705
!
      if( kvals .eq. 0 ) write(6,6600)
 6600 format(1h1,//,' ***************************************',/,       &
     &              ' *                                     *',/,       &
     &              ' * no force and moment summary appears *',/,       &
     &              ' * because no networks remained after  *',/,       &
     &              ' * networks were deleted, or else no   *',/,       &
     &              ' * composite networks were available   *',/,       &
     &              ' * for the default option              *',/,       &
     &              ' *                                     *',/,       &
     &              ' ***************************************',//)
      if( kvals .eq. 0 ) go to 705
!
      call CPU_TIME (ta)
      rewind iflfm
      rewind iflfmf
!
  930 read(iflfm, 8600, end=8700 ) icard
 8600 format(33a4)
      write(6,8600) icard
      go to 930
 8700 continue
!
  940 read(iflfmf,8600, end=8800 ) icard
      write(6,8600) icard
      go to 940
 8800 continue
!
      write(ifmggp, 6050)
 6050 format('*eof')
      call CPU_TIME (tb)
      tmstat(9) = tmstat(9) + tb-ta
  705 continue
!
!
!..... All the remaining code relating to creating an output file
! for the boundary layer program has been omitted.  RLC 16Nov96
!
!      call CPU_TIME (ta)
!      if(itapbl.ne.1) go to 790
!      rewind iscrch
!      open(unit=17,file='ft17',form='unformatted')
!c                                   put title1 into a real*8 array
!      do 781 i = 1,20
!         titch8(i) = title1(i)
!!!         call dcopy (1,  titch8(i),1,  titrx8(i),1)
!        titrx8(i)=titch8(i)  ! bad, but worked for years.   RLC 13Nov96
! 781  continue
!      do 785 iacase=1,nacase
!      read(iscrch)icas
!      do 783 k=1,nnett
!      read(iscrch)nrow,ncol
!      ncnt=icntbl(icas,k)
!      if(k.gt.1)      go to 710
!      write (17) (titrx8(i),i=1,8),amach,alpha(iacase),nnett
! 710  continue
!      write (6,3700)
!3700  format(1h1,5hchord,7x,1hi,10x,2hxp,13x,2hyp,13x,2hzp,
!     2                         13x,2hup,13x,2hvp,13x,2hwp)
!      call zero (rv,6*nrow*ncol)
!      write(17)ncol
!      do 776 j=1,ncnt
!      read (iscrch) ii,jj,(rvpnt(i),i=1,6)
!      ipk  =  ii + (jj-1)*nrow
!      call dcopy (6, rvpnt,1, rv(1,ipk),1)
!  776 continue
!      do 780 jcol = 1,ncol
!      l1 =  1 + (jcol-1)*nrow
!      l2 =  jcol*nrow
!      write(17)nrow
!      write (17) ((rv(i,l),i=1,6),l=l1,l2)
!      write (6,3800) jcol, (irow, (rv(i,irow+l1-1),i=1,6), irow=1,nrow)
! 3800 format (1h ,i5,5x,i5,6f15.5 ,/, (11x,i5,6f15.5) )
! 780  continue
!  783 continue
!  785 continue
  790 continue
      call CPU_TIME (tb)
      tmstat(10) = tmstat(10) + tb-ta
      tsum = 0.d0
      do 792 kk = 1,10
         tsum = tsum + tmstat(kk)
  792 continue
      tmstat(11) = tsum
      tmstat(12) = tmstat(12) + tb-tax
      write (6,6900) (tmstat(kk),kk=1,12)
 6900 format ( '  Timing Breakdown for Subroutine OUTPUT '              &
     & ,/,' singularity matrices   ',f12.6                              &
     & ,/,' get limits for sectnp  ',f12.6                              &
     & ,/,' singularity grid       ',f12.6                              &
     & ,/,' Trefftz analysis       ',f12.6                              &
     & ,/,' Standard printout      ',f12.6                              &
     & ,/,' Force and Moment calc  ',f12.6                              &
     & ,/,' Sectional Properties   ',f12.6                              &
     & ,/,' agps file (agpsfl)     ',f12.6                              &
     & ,/,' force/moment summary   ',f12.6                              &
     & ,/,' Boundary layer output  ',f12.6                              &
     & ,/,' Totals of Above        ',f12.6                              &
     & ,/,' Total for subroutine   ',f12.6  )
!
      call frecor ('output')
      return
      END subroutine output
! **deck outvc
      subroutine outvc  (label,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(f12.6)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      write (6,6001) label,n
 6001 format (1x,a10,8x,i5)
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
!
      line  =  lnblnk
      write (sublin    ,6002) j1
      line(1:10) = sublin(1:10)
 6002 format (3x,i6,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(j)
      ln2   =  ln1 + nch - 1
      if (      intgr ) write (sublin       ,iff) iaa
      if ( .not.intgr ) write (sublin       ,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
  100 continue
!
      return
      END subroutine outvc
! **deck outvci
      subroutine outvci (label,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      integer a(1:n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr
!
!         print a matrix a using the appropriate format
!
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      write (6,6001) label,n
 6001 format (1x,a10,8x,i5)
!
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
!
      line  =  lnblnk
      write (sublin,6002) j1
      line(1:10) = sublin(1:10)
 6002 format (3x,i6,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr  =  .true.
      ln2   =  ln1 + nch - 1
      if (       intgr ) write (sublin,iff) a(j)
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
  100 continue
!
      return
      END subroutine outvci
! **deck outvcx
      subroutine outvcx (label,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(1p,e12.4)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      write (6,6001) label,n
 6001 format (1x,a10,8x,i5)
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
!
      line  =  lnblnk
      write (sublin    ,6002) j1
      line(1:10) = sublin(1:10)
 6002 format (3x,i6,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(j)
      ln2   =  ln1 + nch - 1
      if (      intgr ) write (sublin       ,iff) iaa
      if ( .not.intgr ) write (sublin       ,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
  100 continue
!
      return
      END subroutine outvcx
! **deck outvcy
      subroutine outvcy (label,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(1p,e24.16)'
      iff   = '(i24)'
      ml    =   5
      nch   =  24
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      write (6,6001) label,n
 6001 format (1x,a10,8x,i5)
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
!
      line  =  lnblnk
      write (sublin    ,6002) j1
      line(1:10) = sublin(1:10)
 6002 format (3x,i6,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(j)
      ln2   =  ln1 + nch - 1
      if (      intgr ) write (sublin       ,iff) iaa
      if ( .not.intgr ) write (sublin       ,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
  100 continue
!
      return
      END subroutine outvcy
! **deck outvcz
      subroutine outvcz (label,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(z24)'
      iff   = '(z24)'
      ml    =   5
      nch   =  24
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      write (6,6001) label,n
 6001 format (1x,a10,8x,i5)
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
!
      line  =  lnblnk
      write (sublin    ,6002) j1
      line(1:10) = sublin(1:10)
 6002 format (3x,i6,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(j)
      ln2   =  ln1 + nch - 1
      if (      intgr ) write (sublin       ,iff) iaa
      if ( .not.intgr ) write (sublin       ,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
  100 continue
!
      return
      END subroutine outvcz
! **deck outvec
      subroutine outvec (label,n,a)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension a(n)
      character*132 line, lnblnk
      character*24 sublin
      character*11 rff, iff
      logical intgr, intchk
      equivalence (iaa,aa)
!
!         print a matrix a using the appropriate format
!
      rff   = '(f12.6)'
      iff   = '(i12)'
      ml    =  10
      nch   =  12
      do 2 i = 1,132
    2 lnblnk(i:i) = ' '
!
      write (6,6001) label,n
 6001 format (1x,a10,8x,i5)
!
      iicrit  =  2**16-1
      do 100 j1 = 1,n,ml
      j2   =  min(n,j1+ml-1)
!
      line  =  lnblnk
      write (sublin,6002) j1
      line(1:10) = sublin(1:10)
 6002 format (3x,i6,'.')
!
      ln1  =  11
      do 50 j = j1,j2
      intgr   =  .false.
      aa    =  a(j)
      ln2   =  ln1 + nch - 1
      if (       intgr ) write (sublin,iff) iaa
      if ( .not. intgr ) write (sublin,rff)  aa
      line(ln1:ln2) = sublin(1:nch)
      ln1   =  ln2 + 1
   50 continue
!
      write (6,6003) line
 6003 format (a132)
  100 continue
!
      return
      END subroutine outvec
! **deck pakims
      subroutine pakims (lblock,nbk,indx)
      integer indx(2)
!
!         build a packed index (indx) entry from a block
!         address (lblock) and a block count (nbk)
!
!---      if ( nbk.gt.4095 .or. nbk.lt.0 ) call exitms (lun                 &
!---     &    ,'default block limit is 31 at this time')
      indx(1)    =  lblock
      indx(2)    =  nbk
      return
      END subroutine pakims
! **deck pakpsp
      subroutine pakpsp (md,m,  npsp,kkpsp,iipsp,bpsp,  ns,s)
      implicit double precision (a-h,o-z)
      dimension npsp(md,2), kkpsp(md,2), iipsp(6,md,2), bpsp(6,md,2)
      dimension s(m,*)
!
!         pack up the /compsp/ data into the array  s  using the followi
!         layout:
!
!         npsp(*,1)        s(*,1)
!         npsp(*,2)        s(*,2)
!         kkpsp(*,1)       s(*,3)
!         kkpsp(*,2)       s(*,4)
!         iipsp(6,*,1)     s(*,5:10)
!         iipsp(6,*,2)     s(*,11:16)
!         bpsp(6,*,1)      s(*,17:22)
!         bpsp(6,*,2)      s(*,23:28)
!
!         md      i   int   number of data sets
!         m       i   int   row dimension of s, it is req'd that  m >= m
!         npsp    i   int   number of spline dependencies for each data
!         kkpsp   i   int
!         iipsp   i   int   singularity parameter indices for the spline
!         bpsp    i   int   spline data
!         ns      i   int   the number of memory cells provided by s
!         s       o   int   the packed up dataset, to be written by iytr
!
!         michael epton, 30 november 1988
!
!
      nw      =  m*28
      if ( nw.gt.ns ) call a502er ('pakpsp'                             &
     &                         ,'buffer overflow - psp data structure')
      do 100 jx = 1,2
      call icopy (m,       npsp(1,jx),1,  s(1,jx),1)
      call icopy (m,      kkpsp(1,jx),1,  s(1,jx+2),1)
      call icopy (6*m,  iipsp(1,1,jx),1,  s(1,6*jx-1) ,1)
      call dcopy (6*m,   bpsp(1,1,jx),1,  s(1,6*jx+11),1)
!+++  call outlin ('m,jx',2,m,jx)
!+++  call outvec ('npsp',m,npsp(1,jx))
!+++  call outvec ('kkpsp',m,kkpsp(1,jx))
!+++  call outmat ('iipsp',6,6,m,iipsp(1,1,jx))
!+++  call outmat ('bpsp',6,6,m,bpsp(1,1,jx))
  100 continue
      return
      END subroutine pakpsp
! **deck panmom
      subroutine panmom (nside,ics,p,n,c,np1,e,np2)
      implicit double precision (a-h,o-z)
      dimension  p(3,1), c(np1,1), e(np2,1)
      call zero (c,np1**2)
      do 100 ic = 1,nside
      if ( ic.eq.ics ) go to 100
      icp1    =  mod(ic,nside) + 1
      if ( icp1 .eq. ics ) icp1 = mod(ics,nside) + 1
      delx    =  p(1,icp1) - p(1,ic)
      dely    =  p(2,icp1) - p(2,ic)
      do 10 i = 1,np2
   10 e(i,1)  =  dely/i
      call lchvar (      e, p(2,ic), dely,   np1, np1)
      do 20 j = 1,np1
      call lchvar ( e(1,j), p(1,ic), delx, np2-j,   0)
   20 continue
      do 30 i = 1,np1
      aiinv   =  1.d0/i
      jmax    =  np2-i
      do 30 j = 1,jmax
   30 c(i,j)  =  c(i,j) + aiinv*e(i+1,j)
  100 continue
      return
      END subroutine panmom
! **deck pannum
      subroutine pannum( irow, maxrow, icol,   ipanel)
      implicit double precision (a-h,o-z)
!
!     purpose - given the row number, maximum number of rows,
!               column number, and accumulated index of panels,
!               return panel number.
!
      ipanel = irow + (maxrow-1)*(icol-1)
      return
      END subroutine pannum
! **deck panpwm
      subroutine panpwm (ics,cp  ,ens,as,ajs,ws                         &
     &                  ,wmc,wscc,almc,almscc                           &
     &                  ,qd)
      implicit double precision (a-h,o-z)
      dimension cp(3,9), ens(3,5), as(9,5), ajs(5)
      dimension ws(3,3,8)
      dimension wmc(3,6,  3,4),  wscc(18,  12,  8)
      dimension almc(3,   3,4), almscc(3,  12,  8)
      dimension qd(3,9)
!
      dimension wsm(3,3,6,4), almsm(3,3,4), cm(6,6), cpm(3,4)
      dimension wsx(3,3,6,4), almsx(3,3,4)
      dimension clin(3,3), cquad(6,6)
      dimension dlin(3,3), dquad(6,6), ss(6)
      dimension alin(3,3), aquad(6,6)
!
      dimension incg(6), jncg(6), facg(6)
      dimension almqd(3)
      logical palmqd
      save ncall
      data incg / 0,1,0,2,1,0 /
      data jncg / 0,0,1,0,1,2 /
      data facg / 1.d0,  1.d0,1.d0,  .5d0,1.d0,.5d0 /
      data ncall /0/
!
!
      ncall = ncall + 1
      palmqd  =  .false.
      palmqd  =  .false.
!
      do 50 j = 1,4
         call unipan (as(1,5),cp(1,9),  cp(1,j),cpm(1,j))
   50 continue
      call ccaln (cpm,ics,cm,  4,  6)
      do 70 j = 1,6
         do 60 i = 1,6
            ival    =  1 + incg(j) + incg(i)
            jval    =  1 + jncg(j) + jncg(i)
            cquad(i,j) = ajs(5)*facg(i)*facg(j)*cm(ival,jval)
   60    continue
   70 continue
      do 90 j = 1,3
         do 80 i = 1,3
            clin(i,j) = cquad(i,j)
   80    continue
   90 continue
      call dcopy (9,  clin,1,  alin,1)
      call dcopy (36, cquad,1, aquad,1)
      call chlfac (6,cquad, ss)
      call chlfac (3,clin,  ss)
      call dcopy (6*6,  0.d0,0,  dquad,1)
      call dcopy (3*3,  0.d0,0,  dlin,1)
      do 95 j = 1,6
         dquad(j,j) = 1.d0
         call chlslv (6,cquad,  dquad(1,j))
   95 continue
      do 96 j = 1,3
         dlin(j,j) = 1.d0
         call chlslv (3,clin,   dlin(1,j))
   96 continue
!                                  INVERT CLIN AND CQUAD INPLACE !!!!!!
!                                  invert clin and cquad inplace
      call dcopy (3*3*6*4,  0.d0,0,   wsm,1)
      call dcopy (  3*3*4,  0.d0,0, almsm,1)
      do 100 is = 1,8
         ic      =  min(is,5)
         call subpwm (ics,is,cp                                         &
     &               ,ens(1,ic),as(1,ic),ajs(ic),ws(1,1,is)             &
     &               ,ens(1,5), as(1,5)                                 &
     &               ,wsm,wscc(1,1,is),almsm,almscc(1,1,is)             &
     &               ,qd)
  100 continue
!
      call hsmmp1 (3,3,12,  dlin,1,3,  almsm,1,3,  almc,1,3)
      if ( palmqd  .and.  ncall.lt.28 ) then
         call hsmmp1 (3,12,1,  almsm,1,3,  qd,1,12,  almqd,1,3)
         call outvcy ('almsm*qd',3,almqd)
         call hsmmp1 (3,12,1,   almc,1,3,  qd,1,12,  almqd,1,3)
         call outvcy ('almc*qd',3,almqd)
      endif
      do 200 idlt = 1,4
         do 180 j = 1,3
            do 160 i = 1,3
               call hsmmp1 (6,6,1,  dquad,1,6,  wsm(i,j,1,idlt),9,54    &
     &                     ,wmc(i,1,j,idlt),3,18)
  160       continue
  180    continue
  200 continue
      return
      END subroutine panpwm
! **deck panuni
      subroutine panuni(art,r0,y,x)
      implicit double precision (a-h,o-z)
!***created  on 76.010    w.o. no.   0   version        ftj.00
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to transform the representation of a position vector         *
!     *  from panel to universal coordinates                          *
!     *  the vector representing the coordinate is multiplied         *
!     *  by the transformation matrix, and the origin of the panel    *
!     *  system is added to the resultant                             *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   art       argument  input     transformation matrix         *
!     *                                                               *
!     *   r0        argument  input     origin of the panel           *
!     *                                 coordinate system             *
!     *                                                               *
!     *   w         -local-   - - - -   coordinates in system         *
!     *                                 parallel to universal         *
!     *                                                               *
!     *   x         argument  output    coordinates in the            *
!     *                                 universal system              *
!     *                                                               *
!     *   y         argument  input     coordinates in the panel      *
!     *                                 system                        *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension art(3,3),r0(3),x(3),y(3),w(3)
!c
!     *  transformation to system parallel to universal               *
!     *  do multiply via cmab                                         *
!
      w(1)    =  art(1,1)*y(1) + art(1,2)*y(2) + art(1,3)*y(3)
      w(2)    =  art(2,1)*y(1) + art(2,2)*y(2) + art(2,3)*y(3)
      w(3)    =  art(3,1)*y(1) + art(3,2)*y(2) + art(3,3)*y(3)
!c
!     *  add on the origin of local system                            *
!
      x(1)    =  w(1) + r0(1)
      x(2)    =  w(2) + r0(2)
      x(3)    =  w(3) + r0(3)
      return
      END subroutine panuni
! **deck pcnews
      subroutine pcnews
      implicit double precision (a-h,o-z)
!
      character buf*80,news*4
      data news /'news'/
      open (unit=88,file='news',status='unknown')
      rewind 88
  100 continue
      read (88,5000,end=1000) buf
 5000 format (a80)
      write (6,6001) buf(1:1),buf(2:80)
 6001 format (a1,a79)
      go to 100
!
!
!
 1000 continue
      close (unit=88)
      return
      END subroutine pcnews
! **deck peaabo
      subroutine peaabo (nnett,nm,nn,nza,z,zorig,  ipea,movusr          &
     &                  ,ne,kfds,ksgn)
      implicit double precision (a-h,o-z)
      dimension nm(nnett), nn(nnett), nza(nnett)
      dimension z(3,*), zorig(3,*)
      dimension kfds(4*ne), ksgn(ne)
!
!         print the geometry of a $pea specification after the
!         geometry has been adjusted.
!
!
!         nnett   i   int   number of networks in the configuration
!         nm      i   int   for nw k, nm(k) = nmbr of mesh pt rows
!         nn      i   int   for nw k, nn(k) = nmbr of mesh pt cols
!         nza     i   int   nza(k)+1 = start pt loc for nw k mesh pts
!         z       i   r*8   z(1:3,1:nzmpt) = mesh pts in configuration
!         zorig   i   r*8   the array z before any $pea processing
!         ipea    i   int   the index of the pea spec. to be printed
!         movusr  i   int   print flag for pea processing.  0=default pr
!                           1=point motion print, >1 gives varied diagno
!         ne      i   int   number of edges is pea spec. nmbr ipea
!         kfds    i   int   kfds(4,ne) describe the fundamental segments
!                           in the current pea spec:
!                           [kokseg, kedseg, i1kseg, i2kseg]
!         ksgn    i   int   ksgn(ie), (ie=1:ne) is the orientation of th
!                           ie'th edge in the pea specification  kfds
!
!         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 nwlst
      common /cnwlst/ nwname(mxnett)
      character*10 nwname
      common /anwlst/ nnwlst
!end  nwlst
      dimension zedg(3,mxedmp)
!call indedg
!                                                            /indedg/
      common /indedg/ kokseg, kedseg, i1kseg, i2kseg                    &
     &              , lokseg, ledseg, i1lseg, i2lseg
!end  indedg
      write (6,6000) ipea
 6000 format (' adjusted geometry for partial edge abutment'            &
     & ,' specification #',i4)
      do 50 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)
!
      write (6,6001) ie,nwname(knet),knet,ksd,i1kseg,i2kseg
 6001 format (1x,i3,'.',2x,a10,'  nw.edge:',i4,'.',i1,4x,'start:',i4    &
     &                                               ,4x,'end:',i4)
      do 40 imp = i1kseg,i2kseg
      kz      =  kzedg + (imp-1)*kncedg
      l       =  imp - i1kseg + 1
      call dcopy (3,  z(1,kz),1,  zedg(1,l),1)
   40 continue
      npts    =  i2kseg - i1kseg + 1
      call outmat ('edge pts',3,3,npts,zedg)
   50 continue
      write (6,6002)
 6002 format (' ')
      return
      END subroutine peaabo
! **deck peadue
      subroutine peadue (nnett,nm,nn,nza,z,zorig  ,epspea,iopfor,movusr &
     &                  ,ne,kfds,ksgn ,nedmp,nedmpa,kempec,kptemp,dzcrit&
     &                  ,zpt,iept                                       &
     &                  )
      implicit double precision (a-h,o-z)
      dimension z(3,1:*), zorig(3,1:*)                                  &
     &        , nm(nnett), nn(nnett), nza(nnett), kfds(4*ne)            &
     &        , ksgn(ne), nedmpa(nnett+1), kempec(nedmp), kptemp(nedmp) &
     &                                                  , dzcrit(nedmp) &
     &        , zpt(3,*), iept(*)
! --- dimension zpt(3,mxnpec), iept(mxnpec)
!
!         define the universal edge appropriate to a user's specificatio
!         a partial edges abutment.  this process involves defining
!         all of the equivalence classes of points (consistent with
!         the input tolerance epspea) and then defining the universal
!         edge in terms of the full equivalence classes (those classes
!         that have one point from each edge).  each point in a full
!         class is merged into a representative point (iopfor controls
!         how this is done) and then all remaining points in the
!         specified segments are projected onto the universal edge, so
!         defined.
!
!         nnett   i   int   number of networks in the configuration
!         nm      i   int   for nw k, nm(k) = nmbr of mesh pt rows
!         nn      i   int   for nw k, nn(k) = nmbr of mesh pt cols
!         nza     i   int   nza(k)+1 = start pt loc for nw k mesh pts
!         z       i/o r*8   z(1:3,1:nzmpt) = mesh pts in configuration
!         zorig   i   r*8   the array z before any $pea processing
!         epspea  i   r*8   abutment tolerance for current pea specifica
!         iopfor  i   int   method for forcing points to match: 0=1-st e
!                           nonzero=average all point
!         movusr  i   int   print flag for pea processing.  0=default pr
!                           1=point motion print, >1 gives varied diagno
!         ne      i   int   number of edges is pea spec. nmbr ipea
!         kfds    i   int   kfds(4,ne) describe the fundamental segments
!                           in the current pea spec:
!                           [kokseg, kedseg, i1kseg, i2kseg]
!         ksgn    i   int   ksgn(ie), (ie=1:ne) is the orientation of th
!                           ie'th edge in the pea specification  kfds
!         nedmp   i   int   number of edge mesh pts in configuration
!         nedmpa  i   int   nedmpa(kedg) = cum nmbr of edge mesh pts for
!                           all edge indices  < kedg.  (nedmpa(1)=0)
!         kempec  s   int   scratch array, initialized to and reset to 1
!                           used to note which points have been processe
!         kptemp  i   int   std permutation array circular pointer data
!                           structure for the equivalence classes of mes
!                           points generated by the current pea spec.
!         dzcrit  i   int   for each edge mesh point in the configuratio
!                           dzcrit(kmp) is the maximum amount that point
!                           kmp should be moved
!
!
!
!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 zavg(3)
      dimension zcom(3,mxedmp), dzcom(mxedmp), dzsum(mxedmp)            &
     &        , tauval(mxedmp), kmpval(mxedmp), keyval(mxedmp)          &
     &        , impval(mxedmp),  dzval(mxedmp)
      character*5 cdzval(mxedmp), ch5blk, ch5bld
      character*8 temp
      character*28 movmsg, msgerr
      dimension kmplst(2*mxeiab), keylst(2*mxeiab), nptlst(2*mxeiab)    &
     &        ,  ielst(2*mxeiab)
      logical epsequ, badedg, excess
!call indedg
!                                                            /indedg/
      common /indedg/ kokseg, kedseg, i1kseg, i2kseg                    &
     &              , lokseg, ledseg, i1lseg, i2lseg
!end  indedg
!call symcnd
!                                                            /symcnd/
      common /symcnd/ isympa
!end  symcnd
!call nwlst
      common /cnwlst/ nwname(mxnett)
      character*10 nwname
      common /anwlst/ nnwlst
!end  nwlst
!                   123456789012345678901234567890
      data msgerr /'** fatal ** excessive motion'/
!
      nedgt   =  4*nnett
      ch5blk  =  '       '
!                                  generate a list of (initial meshpoint
!                                  on the edge segments given by the pea
      nex     =  0
      do 100 ie = 1,ne
          isgn    =  ksgn(ie)
          call icopy (4,  kfds(4*(ie)-3),1, kokseg,1)
          nex     =  nex + 1
          kedg    =  kedseg
          call mnmod (kedg,4,ksd,knet)
          kmp1    =  nedmpa(kedseg) + i1kseg
          kmp2    =  nedmpa(kedseg) + i2kseg
          kmplst(nex) = kmp1 - 1
          nptlst(nex) = i2kseg - i1kseg + 1
          ielst(nex)  = ie
!                                  last pt on edge 4 = 1st pt on edge 1,
!                                  fix if necessary
          if ( ksd.ne.4 ) goto 100
          if ( kmp2 .le. nedmpa(4*knet+1) ) goto 100
               nptlst(nex) = nptlst(nex) - 1
               nex     =  nex + 1
               kmplst(nex) = nedmpa(4*knet-3)
               nptlst(nex) = 1
               ielst(nex)  = ie
  100 continue
!                                  all of the edge mesh points in the pe
!                                  spec will be described by the lists:
!
!                                  kmplst( 1 )+1,...,kmplst( 1 ) + nptls
!                                  kmplst( 2 )+1,...,kmplst( 2 ) + nptls
!                                       ...               ..............
!                                  kmplst(nex)+1,...,kmplst(nex) + nptls
      call jshell (nex,kmplst,keylst)
      call keysrt (nex,nptlst,keylst)
      call keysrt (nex, ielst,keylst)
!                                  for each abutment, define the meshpoi
!                                  of the universal edge and adjust all
!                                  meshpoints of the abutment to lie on
      nzcom   =  0
      do 700 ie = 1,ne
          isgn    =  ksgn(ie)
          call icopy (4,  kfds(4*(ie)-3),1, kokseg,1)
          kedg    =  kedseg
          do 600 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
               nloop   =  0
!
  200          continue
                    nloop   =  nloop + 1
                    if ( nloop.gt.mxempt ) call abtend                  &
     &                   ('peadue: infinite loop trapped (1)')
!                                  determine if the point lies on a spec
!                                  edge in the 'kfds' list
                    call ibsrch (kmplst,nex,kmp,kptr)
                    if ( kptr.le.0 ) goto 220
                    if ( kmp .gt.kmplst(kptr)+nptlst(kptr) ) goto 220
!                                  good point, add it to the list and
!                                  remember the edge
                    npt     =  npt + 1
                    call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz)
                    iept(npt) = ielst(kptr)
                    call xfera (z(1,kz),zpt(1,npt),3)
!
  220               continue
                    if ( npt.gt.mxnpec )                                &
     &                   call abtend ('peadue: zpt buffer exceeded')
                    kmp     =  kptemp(kmp)
                    if ( kmp.ne.iedmp ) go to 200
!                                  counting and collecting done,
!                                  check for error conditions
               if ( ie.gt.1 ) go to 500
               if ( impx.ne.i1kseg .and. impx.ne.i2kseg )               &
     &                        go to 300
!                                  first edge, end points
                    if ( npt.lt.ne ) call abtend                        &
     &                   ('peadue: end point class not full ')
                    go to 400
!                                  first edge, interior
  300          continue
                    if ( npt.gt.ne ) call abtend                        &
     &                   ('peadue: interior equivalence class too big')
                    if (npt.lt.ne) go to 600
                    go to 400
!
!                                  first edge, merge points and save
  400          continue
               if ( iept(1).ne.ie ) then
                    call outvci ('iept',npt,iept)
               endif
!
               call dcopy (3,  zpt(1,1),1,  zavg,1)
               if ( iopfor.ne.0 ) call zmerge (npt,zpt,zavg)
               call peapos (npt,zpt,epspea,jsym)
               if ( mod(jsym,2).eq.1 ) zavg(2) = 0.d0
               if (   jsym.ge.2      ) zavg(3) = 0.d0
               nzcom   =  nzcom + 1
               kmpval(nzcom) = iedmp
               call xfera (zavg,zcom(1,nzcom),3)
               kmp     =  iedmp
!
               nloop   =  0
  450          continue
                    nloop   =  nloop + 1
                    if ( nloop .gt. mxempt ) call abtend                &
     &                   ('peadue: infinite loop trapped (2)')
                    call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz)
                    call xfera (zavg,z(1,kz),3)
                    kempec(kmp)  =  -iedmp
                    kmp     =  kptemp(kmp)
                    if ( kmp.ne.iedmp ) go to 450
                    goto 600
!
!                                  subsequent edges
  500          continue
               if ( impx.ne.i1kseg .and. impx.ne.i2kseg ) go to 550
!                                  subsequent edge, end points
                    if ( kempec(iedmp).gt.0 ) call abtend               &
     &                   ('peadue: end mesh pt not already processed')
                    go to 600
!                                  subsequent edge, interior point
  550          continue
                    if ( npt.gt.ne ) call abtend                        &
     &                   ('peadue: excessive eq. class detected ')
                    if ( npt.eq.ne .and. kempec(iedmp).gt.0 )call abtend&
     &                   ('peadue: unprocessed interior eq. class')
                    if ( npt.lt.ne .and. kempec(iedmp).lt.0 )call abtend&
     &                   ('peadue: badly processed interior point')
                    go to 600
  600     continue
  700 continue
!                                  compute individual and cumulative
!                                  segment lengths for the common edge
      dzsum(1)=  0.d0
      nzcseg  =  nzcom - 1
      do 710 izcom = 1,nzcseg
          call distnc (zcom(1,izcom),zcom(1,izcom+1),dzcom(izcom))
          dzsum(izcom+1) = dzsum(izcom) + dzcom(izcom)
  710 continue
!                                  compute tau values for the common edg
      do  720 izcom = 1,nzcom
          tauval(izcom) = dzsum(izcom)/dzsum(nzcom)
  720 continue
      ntau    =  nzcom
!                                  diagnostic print
      if ( movusr.lt.3 ) goto 730
      call outmat ('zcom',3,3,nzcom,zcom)
      call outvec ('dzcom',nzcom,dzcom)
      call outvec ('dzsum',nzcom,dzsum)
  730 continue
!                                  universal edge defined, adjust the
!                                  remaining points of the abutment
!                                  up to it.
      do 800 ie = 1,ne
          isgn    =  ksgn(ie)
          call icopy (4,  kfds(4*(ie)-3),1, kokseg,1)
          kedg    =  kedseg
          izcom   =  0
          call mnmod (kedg,4,ksd,knet)
!                                  project un-full equivalence classes o
!                                  points onto the universal edge
          do 780 impx = i1kseg,i2kseg
               imp     =  impx
               if ( isgn.lt.0 ) imp = i1kseg + i2kseg - impx
               call edgmpi (kedseg,imp,nedmpa,  iedmp)
!                                  count the size of this point's
!                                  equivalence class
               kmp     =  iedmp
               npt     =  0
               nloop   =  0
  740          continue
                    nloop   =  nloop + 1
                    if ( nloop .gt. mxempt ) call abtend                &
     &                 ('peadue: infinite loop trapped (3)')
                    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 740
!                                  keep a running count of the number of
!                                  points passed in full equiv. classes
               if ( npt.ge.ne ) izcom = izcom+1
!                                  full equiv classes already processed:
               if (  npt.ge.ne  ) go to 780
!                                  define  tau  values and adjust coordi
!                                  points that are not in full equiv. cl
               if ( kempec(iedmp).lt.0 ) go to 780
               call dcopy (3,  zpt(1,1),1,  zavg,1)
               if ( iopfor.ne.0 ) call zmerge (npt,zpt,zavg)
!                                  move points to p-o-s if needed
               call peapos (npt,zpt,epspea,jsym)
               if ( mod(jsym,2).eq.1 ) zavg(2) = 0.d0
               if (   jsym.ge.2      ) zavg(3) = 0.d0
!                                  project points down to the common edg
               if ( izcom.lt.1 .or. izcom.ge.nzcom ) call abtend        &
     &              ('peadue: izcom out of bounds    ')
               call zmproj (zcom(1,izcom),zcom(1,izcom+1),zavg          &
     &                                                   ,tauz)
               tauedg  =  ( dzsum(izcom) + tauz*dzcom(izcom) ) /        &
     &                                             dzsum(nzcom)
!                                  check that projection point lies in
!                                  the appropriate interval
               if ( (tauz.ge.0.d0) .and. (tauz.le.1.d0) ) goto 750
                    call abtmsg ('peadue: tauz out of range  ')
                    write (6,'(1x,a10,1x, 5f12.6)')                     &
     & 'tauz',tauz,izcom,dzsum(izcom)                                   &
     &                                   ,dzsum(nzcom),dzcom(izcom)
                    call outmat ('zcom',3,3,2,zcom(1,izcom))
                    call outvec ('zavg',3,zavg)
  750          continue
!                                  change points and mark kempec; save
!                                  the tau value and the principal
!                                  kmp value for this equivalence class
               kmp     =  iedmp
               ntau    =  ntau + 1
               tauval(ntau) = tauedg
               kmpval(ntau) = iedmp
               nloop   =  0
  760          continue
                    nloop   =  nloop + 1
                    if ( nloop .gt. mxempt ) call abtend                &
     &                 ('peadue: infinite loop trapped (4)')
                    call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz)
                    call xfera (zavg,z(1,kz),3)
                    kempec(kmp) =  -iedmp
                    kmp     =  kptemp(kmp)
                    if ( kmp.ne.iedmp ) go to 760
  780     continue
  800 continue
!                                  sort the tauval array and bring the l
!                                  of 'principal edge meshpoints', kmpva
!                                  into synch.
      call dshell (ntau,tauval,keyval)
      call keysrt (ntau,kmpval,keyval)
!                                  loop over the edges of the partial ed
!                                  abutment and write out a summary of p
!                                  motion
      if ( movusr.gt.0 ) write (6,6000)
      do 900 ie = 1,ne
          isgn    =  ksgn(ie)
          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)
!                                  generate a list of abutment point ind
          call icopy (ntau,  0,0,  impval,1)
          call dcopy (ntau, 0.d0,0,  dzval,1)
          do 810 itau = 1,ntau
               cdzval(itau) = '    :'
  810     continue
          excess  =  .false.
!                                  ipmove = 0 if motion is not to be pri
!                                         = 1 if motion is to be printed
!                                  movusr = the user's default for this
          ipmove  =  movusr
          dzmaxv  =  0.d0
          do 840 impx = i1kseg,i2kseg
               imp     =  impx
               if ( isgn.lt.0 ) imp = i1kseg + i2kseg - impx
               call edgmpi (kedseg,imp,nedmpa,  kmp)
               dzmax   =  dzcrit(kmp)
               iedmp   =  iabs( kempec(kmp) )
!                                  find iedmp in the kmpval list
               do 820 itau = 1,ntau
                    itausv  =  itau
                    if ( iedmp .eq. kmpval(itau) ) goto 830
  820          continue
               call abtend ('peadue: missing kmp value in -kmpval-')
  830          continue
               kz      =  kzedg + (imp-1)*kncedg
               call pident (z(1,kz),zorig(1,kz),epsequ)
               call distnc (z(1,kz),zorig(1,kz),dzchg)
               if ( dzchg.gt.dzmax ) excess = .true.
               itau    =  itausv
               if ( .not.epsequ ) imp = -imp
               impval(itau) = imp
!                                  build the string describing the
!                                  point motion
               dzmaxv  =   max ( dzchg, dzmaxv)
               if ( dzchg.le. (1.d-20) ) goto 840
               dzchg   =  max( 1.d-99, min( 1.d99, dzchg))
               write (temp,'(1pe8.0)') dzchg
               ch5bld(1:2) = temp(2:3)
               if ( temp(7:7) .eq. '0' ) then
                    ch5bld(3:4) = temp(5:6)
                    ch5bld(5:5) = temp(8:8)
               else
                    ch5bld(3:5) = temp(6:8)
               endif
               if ( dzchg.gt.dzmax ) ch5bld(1:1) = '*'
               cdzval(itau) = ch5bld
  840     continue
!                                  print information describing how each
!                                  of the current edge is related to the
!                                  equivalence classes of the abutment
!                   123456789012345678901234567890
          movmsg = '                            '
          if ( excess ) movmsg = msgerr
          if ( excess ) call abtmsg                                     &
     &                         ('peadue:excess motion, info follows')
          if ( excess ) ipmove = 1
          do 850 jtau1 = 1,ntau,20
               jtau2   =  min(ntau,jtau1+19)
               if ( movusr.le.0 ) goto 850
               if ( jtau1.ne.1 ) goto 845
!                                  first line
               write (6,6001) nwname(knet),knet,ksd,dzmaxv              &
     &                       ,(impval(i),i=jtau1,jtau2)
               if ( ipmove.ne.0 ) write (6,6002) movmsg                 &
     &                       ,(cdzval(i),i=jtau1,jtau2)
               goto 850
!                                  subsequent lines
  845          continue
               write (6,6003) nwname(knet),                             &
     &                        (impval(i),i=jtau1,jtau2)
               if ( ipmove.ne.0 ) write (6,6004)                        &
     &                        (cdzval(i),i=jtau1,jtau2)
               if ( jtau2.eq.ntau .and. ntau.gt.20 ) write (6,6005)
  850     continue
!
  900 continue
!                                  put out two blank lines at end of abm
      if ( movusr.gt.0 ) write (6,6006)
 6000 format (1x,'nw name   ',2x,  'nw.edge', 1x,'max chg',2x,          &
     &'corresponding edge points.  minus (-) ==> point moved by '       &
     & ,'$pea, (*) ==> exceeds .2 of a panel diameter')
 6001 format (1x,a10         ,2x,  i3,'.',i1,3x, 1p,e8.2,0p, 20i5)
 6002 format (1x,a28,20a5)
 6003 format (1x,a10,18x,20i5)
 6004 format (29x,20a5)
 6005 format (1x,' ')
 6006 format (1h )
!                                  restore the kempec array to all 1's
      do 950 ie = 1,ne
          isgn    =  ksgn(ie)
          call icopy (4,  kfds(4*(ie)-3),1, kokseg,1)
          kedg    =  kedseg
          call mnmod (kedg,4,ksd,knet)
!
          do 920 impx = i1kseg,i2kseg
               imp     =  impx
               if ( isgn.lt.0 ) imp = i1kseg + i2kseg - impx
               call edgmpi (kedseg,imp,nedmpa,  iedmp)
!
               kmp     =  iedmp
               nloop   =  0
  910          continue
                    nloop   =  nloop + 1
                    if ( nloop .gt. mxempt ) call abtend                &
     &                 ('peadue: infinite loop trapped (5)')
!------------------ call cmpied (kmp, nnett,nedmpa,nza,nm,nn, kz)
!------------------ call xfera (z(1,kz),zpt(1,npt),3)
                    kempec(kmp) = 1
                    kmp     =  kptemp (kmp)
                    if ( kmp .ne. iedmp ) go to 910
  920     continue
  950 continue
      return
      END subroutine peadue
! **deck peaidn
      subroutine peaidn (nnett,nm,nn,z,ntd, comprs,epsgeo,mthfrc,movusr &
     &                  ,npea,netpea,nedges,peatol,nza                  &
     &                  ,zorig,dzcrit,kptemp,kempec,kptpea              &
     &                  ,nedmpa,iedgtp)
      implicit double precision (a-h,o-z)
      dimension nm(nnett), nn(nnett), z(3,1:*), ntd(nnett)
      dimension comprs(3), nedges(*), peatol(*), nza(*)
      dimension mthfrc(*)
!--   dimension       zorig(3,maxpts), dzcrit(mxempt), kptemp(mxempt)
!--   x              , kempec(mxempt), kptpea(mxempt)
!--   x              , nedmpa(4*mxnett+1), iedgtp(4*mxnett)
!
!         process the partial edge abutment tables and enforce
!         geometric matching conditions specified by the user.
!         this routine is called from inputa (deck input/a).
!
!         nnett   i   int   number of networks in the configuration
!         nm      i   int   for nw k, nm(k) = nmbr of mesh pt rows
!         nn      i   int   for nw k, nn(k) = nmbr of mesh pt cols
!         z       i   r*8   z(1:3,1:nzmpt) = mesh pts in configuration
!         ntd     i   int   ntd(k)=dblt type for nw k.  6=dsgn wake,
!                           12=analysis, 18=standard wake, 20=const. wak
!         comprs  i   r*8   compressibility axis
!         epsgeo  i   r*8   global abutment tolerance (same as used by
!                           abtidn)
!         mthfrc  i   int   mthfrc(1:npea) is a list of processing flags
!                           (moved into iopfor) specifying the type of
!                           geometry forcing to be used: 0=1-st edge,
!                           nonzero=average all points.
!         movusr  i   int   print flag for pea processing.  0=default pr
!                           1=point motion print, >1 gives varied diagno
!         npea    i   int   the number partial edge abutment specificati
!         netpea  i   int   netpea(4,mxeiab,npea) gives the user specifi
!                           of the forced partial edge abutments.
!                           for ipea = 1,npea
!                               for kedg = 1,nedges(ipea)
!                                   netpea(1,kedg,ipea) = nw number
!                                   netpea(2,kedg,ipea) = edge number
!                                   netpea(3,kedg,ipea) = start pt index
!                                   netpea(4,kedg,ipea) = end   pt index
!         nedges  i   int   nedges(ipea) = nmbr of edges in pea spec. 'i
!         peatol  i   r*8   peatol(ipea) = user tolerance for pea spec.
!         nza     i   int   nza(k)+1 = start pt loc for nw k mesh pts
!
!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 netpea (4,mxeiab,*)
!
!call indedg
!                                                            /indedg/
      common /indedg/ kokseg, kedseg, i1kseg, i2kseg                    &
     &              , lokseg, ledseg, i1lseg, i2lseg
!end  indedg
!                                  f.p. arrays controlled by parameters
      dimension       zorig(3,maxpts), dzcrit(mxempt), kptemp(mxempt)   &
     &              , kempec(mxempt), kptpea(mxempt)                    &
     &              , nedmpa(4*mxnett+1), iedgtp(4*mxnett)
!call peatim
      common /peatim/ tpea(10)
!end  peatim
      dimension kfds(4*mxeiab), ksgn(mxeiab)
      logical epsequ, badedg
!
      call setcor ('peaidn')
      call getcor ('zpt', llzpt, 3*mxnpec)
      call igtcor ('iept',lliept,  mxnpec)
      if ( movusr.ge.3 ) call outvci ('nza',nnett+1,nza)
      call dcopy (10,  0.d0,0,  tpea,1)
      call CPU_TIME (ta)
!                                  copy input geometry to zorig
      npts    =  nza(nnett+1)
      call dcopy (3*npts,  z,1,  zorig,1)
!                                  define the cumulative count of nw edg
      nedmp   =  0
      nedgt   =  4*nnett
      do 100 kedg = 1,nedgt
          nedmpa(kedg) = nedmp
          call mnmod  (kedg,4,ksd,knet)
          call edgind (ksd,nm(knet),nn(knet)                            &
     &                ,kzedg,kncedg,kncint,knedg)
          kzedg   =  kzedg + nza(knet)
          nedmp   =  nedmp + knedg - 1
  100 continue
      nedmpa(nedgt+1) = nedmp
!                                  define the acceptable limits of point
      call pealim (nnett,nm,nn,z,nza,nedmpa   ,dzcrit)
!                                  characterize nw edges: 0=ok, 1=collap
      call icopy (nedgt,  0,0,  iedgtp,1)
      do 160 knet = 1,nnett
      do 150 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 ) goto 150
!                                  check for collapsed edge
          ncolps  =  0
          do 110 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
  110     continue
          badedg  =  .false.
          if ( ncolps.ne.0 .and. ncolps.ne.knedg-1 ) badedg = .true.
          if ( .not.badedg ) goto 130
               call abtmsg                                              &
     &             ('peaidn (fatal): partially collapsed edge found ')
               write (6,6001) knet,ksd
               do 120 ij = 2,knedg
                    kz1     =  kzedg + (ij-2)*kncedg
                    kz2     =  kz1 + kncedg
                    call idngeo (z(1,kz1),z(1,kz2),epsgeo,epsequ)
                    if ( .not. epsequ ) goto 120
                    write (6,6002) (ij-1),(z(i,kz1),i=1,3)              &
     &                               ,ij ,(z(i,kz2),i=1,3)
  120          continue
  130     continue
!                                  check that edge does not have
!                                  too many meshpoints
          if ( knedg .le. mxedmp ) goto 140
               call abtmsg                                              &
     &             ('peaidn (fatal): too many points in nw edge')
               write (6,'(1x,a10,1x, 2i12)')                            &
     & 'net,edge',knet,ksd
  140     continue
!                                  set edge type
          iedgtp(kedg) = 0
          if ( ncolps.eq.0 ) goto 150
          iedgtp(kedg) = 1
  150 continue
  160 continue
!                                  define the pointer data structure for
!                                  edge mesh point equivalence classes
      do 200 iedmp = 1,nedmp
          kptemp(iedmp) = iedmp
          kempec(iedmp) = 1
  200 continue
!                                  define all points lying along any
!                                  collapsed edge to be equivalent to
!                                  one another
      do 280 kedg = 1,nedgt
          if ( iedgtp(kedg).eq.0 ) goto 280
!                                  edge kedg is collapsed: enter equiv.
          call mnmod  (kedg,4,ksd,knet)
          call edgind (ksd,nm(knet),nn(knet)                            &
     &                ,kzedg,kncedg,kncint,knedg)
          kzedg   =  kzedg + nza(knet)
          call edgmpi (kedg,1,nedmpa,  iedmp1)
          do 250 imp = 2,knedg
               call edgmpi (kedg,imp,nedmpa,  iedmp2)
               call mpteqc (kptemp,nedmp,  iedmp1,iedmp2)
               iedmp1  =  iedmp2
  250     continue
  280 continue
!                                  optional diagnostic output
      if ( movusr.lt.3 ) goto 290
      call outvci ('nedmpa',4*nnett+1,nedmpa)
      call outvci ('nza',nnett+1,nza)
      call outvci ('kptemp',nedmp,kptemp)
  290 continue
      call CPU_TIME (tb)
      tpea(1) = tb-ta
!                                  loop over the list of user specified
!                                  partial edge abutments and adjust mes
!                                  points in accordance with those specs
      do 500 ipea = 1,npea
          call CPU_TIME (ta)
          call icopy (nedmp,  kptemp,1,  kptpea,1)
          epspea  =  peatol(ipea)
!                                  generate the std data structure
!                                  representation of the current specifi
          ne      =  nedges(ipea)
          do 300 ie = 1,ne
               knet    =  netpea(1,ie,ipea)
               ksd     =  netpea(2,ie,ipea)
               kedg    =  ksd + (knet-1)*4
               call edgind (ksd,nm(knet),nn(knet)                       &
     &                     ,kzedg,kncedg,kncint,knedg)
               kzedg   =  kzedg + nza(knet)
               kpt1    =  netpea(3,ie,ipea)
               kpt2    =  netpea(4,ie,ipea)
               if ( kpt1.eq.0 ) kpt1 = 1
               if ( kpt2.eq.0 ) kpt2 = knedg
               i1kseg  =  min(kpt1,kpt2)
               i2kseg  =  max(kpt1,kpt2)
               kedseg  =  kedg
               kokseg  =  0
               call icopy (4,  kokseg,1, kfds(4*(ie)-3),1)
  300     continue
!                                  calculate the relative signs of the e
!                                  involved using the (1/3, 2/3 rule)
          call peasgn (z,nza,nm,nn,nedmpa,nnett,epspea,iedgtp           &
     &                ,ier,ipea,movusr,  ne,kfds,ksgn)
          call CPU_TIME (tb)
          tpea(2) =  tpea(2) + tb - ta
          ta      =  tb
          if ( ier.ne.0 ) goto 500
!                                  determine the equivalence classes of
!                                  points for this pea specification
          call abtemp (ne,kfds,ksgn,  z,nza,nm,nn,nedmpa,  epspea       &
     &                ,kptpea,nedmp)
          call CPU_TIME (tb)
          tpea(3) =  tpea(3) + tb - ta
          ta      =  tb
          if ( movusr.ge.3 ) call outvci ('kptpea',nedmp,kptpea)
!                                  define a universal edge associated wi
!                                  this pea spec. and adjust points up t
!                                  generate an abtaip style report of pt
          iopfor  =  mthfrc(ipea)
          call peadue (nnett,nm,nn,nza,z,zorig  ,epspea,iopfor,movusr   &
     &                ,ne,kfds,ksgn ,nedmp,nedmpa ,kempec,kptpea,dzcrit &
     &                ,w(llzpt),w(lliept)                               &
     &                )
          call CPU_TIME (tb)
          tpea(4) =  tpea(4) + tb - ta
          ta      =  tb
          if ( movusr.ge.2 )                                            &
     &         call peaabo (nnett,nm,nn,nza,z,zorig,  ipea,movusr       &
     &                     ,ne,kfds,ksgn)
          if ( movusr.ge.2 ) write (6,6003)
  500 continue
!
      call frecor ('peaidn')
      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 )
 6003 format ( 1h , 78(1h-) )
      END subroutine peaidn
! **deck peainp
      subroutine peainp (ipea,nwname  ,movusr                           &
     &                  ,mthfrc,peatol,nedges,netpea)
      implicit double precision (a-h,o-z)
      character*10 nwname(*)
!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
      parameter (mxpeab=100)
      dimension netpea(4,mxeiab,*), peatol(*), mthfrc(*), nedges(*)
!
!         read a block of $pea input data, and update the [peatol/netpea
!         data structure accordingly.
!
!         ipea    i/o  current cumulative count of partial edeg abutment
!         nwname  i    current list of network names
!
!         movusr  o    print flag for peaidn (last value given is the on
!
!         mthfrc  o    method of forcing the abutment for each pea spec
!         peatol  o    tolerances for each pea spec
!         nedges  o    number of edges involved in each pea spec
!         netpea  o    for each edge in a pea spec, the following info i
!                      provided:
!                        netpea(1,ie,ipea) = nw number
!                        netpea(2,ie,ipea) = side number (1-4)
!                        netpea(3,ie,ipea) = initial pt on edge
!                        netpea(4,ie,ipea) = final pt on edge
!
!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 inp3
      common /inp3/ ntsin,ntsout
!end  inp3
!
      character*90  qline
      dimension dum(6)
!
      data stdtol / 1.d-4 /
!
      nza(1)  =  0
      do 5 k = 1,nnett
          nza(k+1) = nza(k) + nm(k)*nn(k)
    5 continue
!                                  read the following:
!                                  (1) # of $pea specs, this group
!                                  (2) method of forcing, this group (0,
!                                          (1, average in equiv. class)
!                                  (3) print flag 'movusr' for peaidn
      read (ntsin,'( a )') qline
      read (qline,6001,err=9950) (dum(i),i=1,3)
      ngrp    =  dum(1)
      iopfor  =  dum(2)
!         input value   pgm value (movusr)
!            -1             0       no summary at all
!             0             1       regular summary
!             1             2       z before and after
      movusr  =  1
      if ( dum(3).lt.0.d0 ) movusr = 0
      if ( dum(3).ge.1.d0 ) movusr = 2
      if ( ipea.gt.mxpeab ) goto 8000
!                                  read and enter into (peatol,nedges,ne
!                                  the $pea specs in this group
      do 500 igrp = 1,ngrp
      ipea  =  ipea + 1
      mthfrc(ipea) = iopfor
      read (ntsin,'( a )') qline
      read (qline,6001,err=9950) (dum(i),i=1,2)
      nedges(ipea) = dum(1)
      abttol       = dum(2)
      if ( nedges(ipea).gt.mxeiab ) goto 8000
      if ( abttol.gt.0.d0 ) goto 110
          abttol  =  stdtol
          if ( ipea.gt.1 ) abttol = peatol(ipea-1)
  110 continue
      peatol(ipea) = abttol
!
      ne      =  nedges(ipea)
      do 300 ie = 1,ne
          read (ntsin,'( a )') qline
          call dfnpea (nwname,nnett,qline,  knet,ksd,i1kseg,i2kseg)
          netpea(1,ie,ipea) = knet
          netpea(2,ie,ipea) = ksd
          netpea(3,ie,ipea) = i1kseg
          netpea(4,ie,ipea) = i2kseg
  300 continue
!
  500 continue
      return
!                                  error condition
 8000 continue
      write (ntsout,8001) ipea,nedges(ipea),mxeiab
 8001 format (' *** fatal *** '                                         &
     &  ,/, '               peainp: in $pea specification no.',i3,      &
     & ', the number of edges:',i6,' exceeds the program limit:',i6)
      stop
!
 6001 format (6f10.0)
 6002 format (a80)
!
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'peainp', 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('peainp',' program failure due to ill-formatted data')
      return
!
      END subroutine peainp
! **deck pealim
      subroutine pealim (nnett,nm,nn,z,nza,nedmpa   ,dzcrit)
      implicit double precision (a-h,o-z)
      dimension nm(nnett), nn(nnett), z(3,*), nza(nnett+1)
      dimension nedmpa(4*nnett+1), dzcrit(*)
!
!         set the maximum limit of point motion for the edge meshpoints
!         at  xpct  times the minimum of the two panel's diameter of whi
!         the mesh point is a corner
!
!         nnett   i   int   number of networks in the configuration
!         nm      i   int   for nw k, nm(k) = nmbr of mesh pt rows
!         nn      i   int   for nw k, nn(k) = nmbr of mesh pt cols
!         z       i   r*8   z(1:3,1:nzmpt) = mesh pts in configuration
!         nza     i   int   nza(k)+1 = start pt loc for nw k mesh pts
!         nedmpa  i   int   nedmpa(kedg) = cum nmbr of edge mesh pts for
!                           all edge indices  < kedg.  (nedmpa(1)=0)
!         dzcrit  o   r*8   for each edge mesh point in the configuratio
!                           the upper limit of allowable motion
!
!         michael epton, 30 november 1988
!
      data xpct /.2d0/
!
      do 500 knet = 1,nnett
      do 400 ksd = 1,4
          call edgind (ksd,nm(knet),nn(knet)                            &
     &                ,kzedg,kncedg,kncint,knedg)
          kzedg   =  kzedg + nza(knet)
          kedg    =  ksd + 4*(knet-1)
          kmpbas  =  nedmpa(kedg)
!                                  the critical distance is set at xpct
!                                  times the smaller of the two diameter
!                                  of the 2 panels that an edge mesh poi
!                                  is a part of.
          dprv    =  1.d38
          do 300 imp = 1,(knedg-1)
               kz1    =  kzedg + (imp-1)*kncedg
               kz2    =  kz1 + kncedg
               kz3    =  kz2 + kncint
               kz4    =  kz1 + kncint
               call distnc (z(1,kz1),z(1,kz3),d13)
               call distnc (z(1,kz2),z(1,kz4),d24)
               diam   =   max ( d13, d24)
               dmin   =   min (diam,dprv)
               dzcrit(kmpbas+imp) = xpct*dmin
               dprv   =  diam
  300     continue
  400 continue
  500 continue
      return
      END subroutine pealim
! **deck peapos
      subroutine peapos (npt,zpt,epspea,jsym)
      implicit double precision (a-h,o-z)
      dimension zpt(3,npt)
!
!         check a list of points about to be merged by subroutine peadue
!         for whatever planes of symmetry they might lie on.
!
!         jsym   =  1,  at least one pt lies on the first pos
!                =  2,  at least one pt lies on the second pos
!                =  3,  at least one pt on the 1st and one pt on the 2nd
!         rmk: if a plane of symmetry is not active, jsym will not refle
!              points lying on it.
!
!         npt     i   int   the number of points to be checked
!         zpt     i   r*8   zpt(3,npt) is the set of points to be checke
!         epspea  i   int   the geometry tolerance for the check
!         jsym    o   int    =  1,  at least one pt lies on the first po
!                            =  2,  at least one pt lies on the second p
!                            =  3,  at least one pt on 1st and one pt on
!
!         michael epton, 30 november 1988
!
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
      j1     =  0
      j2     =  0
      do 100 k = 1,npt
          if ( abs(zpt(2,k)).le.epspea ) j1 = 1
          if ( abs(zpt(3,k)).le.epspea ) j2 = 2
  100 continue
      jsym    =  0
!!      if ( nsymm.ge.1 ) jsym = jsym + j1                                  ! Removed by Martin Hegedus, 4/21/09
!!      if ( nsymm.ge.2 ) jsym = jsym + j2                                  ! Removed by Martin Hegedus, 4/21/09
      if ( nisym.ge.2 ) jsym = jsym + j1                                  ! Added by Martin Hegedus, 4/21/09
      if ( njsym.ge.2 ) jsym = jsym + j2                                  ! Added by Martin Hegedus, 4/21/09
!
      return
      END subroutine peapos
! **deck peasgn
      subroutine peasgn (z,nza,nm,nn,nedmpa,nnett,peatol,iedgtp         &
     &              ,ier,ipea,movusr,  ne,kfds,ksgn)
      implicit double precision (a-h,o-z)
      dimension z(3,1:*), nza(*), nm(*), nn(*), nedmpa(*), iedgtp(*)
      dimension kfds(4*ne), ksgn(ne)
!
!         define the sign of each edge in a partial edge abutment specif
!         relative to the first edge given in the kfds list.  in additio
!         check that the endpoints of the pea specification match up.
!
!         z       i   r*8   z(1:3,1:nzmpt) = mesh pts in configuration
!         nza     i   int   nza(k)+1 = start pt loc for nw k mesh pts
!         nm      i   int   for nw k, nm(k) = nmbr of mesh pt rows
!         nn      i   int   for nw k, nn(k) = nmbr of mesh pt cols
!         nedmpa  i   int   nedmpa(kedg) = cum nmbr of edge mesh pts for
!                           all edge indices  < kedg.  (nedmpa(1)=0)
!         nnett   i   int   number of networks in the configuration
!         peatol  i   r*8   tolerance for the current pea spec.
!         iedgtp  i   int   edge type array: 0=ok, 1=collapsed
!         ier     o   int   error count: 0=ok, >0 ==> trouble
!         ipea    i   int   the index of the pea spec. to be printed
!         movusr  i   int   print flag for pea processing.  0=default pr
!                           1=point motion print, >1 gives varied diagno
!         ne      i   int   number of edges is pea spec. nmbr ipea
!         kfds    i   int   kfds(4,ne) describe the fundamental segments
!                           in the current pea spec:
!                           [kokseg, kedseg, i1kseg, i2kseg]
!         ksgn    o   int   ksgn(ie), (ie=1:ne) is the orientation of th
!                           ie'th edge in the pea specification  kfds
!
!         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
      dimension dzsum(mxedmp), dzedg(mxedmp)
      dimension zedg(3,mxedmp)
!call nwlst
      common /cnwlst/ nwname(mxnett)
      character*10 nwname
      common /anwlst/ nnwlst
!end  nwlst
      dimension z33(3), z66(3), zx33(3), zx66(3), zx1(3), zx2(3)
      dimension ndef(2)
!call indedg
!                                                            /indedg/
      common /indedg/ kokseg, kedseg, i1kseg, i2kseg                    &
     &              , lokseg, ledseg, i1lseg, i2lseg
!end  indedg
!                                  put out a nice summary of the input d
!                                  if the user has requested it
      if ( movusr.lt.2 ) goto 51
      write (6,6000) ipea
 6000 format (' input geometry for partial edge abutment specification' &
     & ,' #',i4)
!                                  describe each edge in the pea spec
      do 50 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)
!
      write (6,6001) ie,nwname(knet),knet,ksd,i1kseg,i2kseg
 6001 format (1x,i3,'.',2x,a10,'  nw.edge:',i4,'.',i1,4x,'start:',i4    &
     &                                               ,4x,'end:',i4)
!                                  describe each referenced point on the
!                                  current edge
      do 40 imp = i1kseg,i2kseg
      kz      =  kzedg + (imp-1)*kncedg
      l       =  imp - i1kseg + 1
      call dcopy (3,  z(1,kz),1,  zedg(1,l),1)
   40 continue
      npts    =  i2kseg - i1kseg + 1
      call outmat ('edge pts',3,3,npts,zedg)
   50 continue
      write (6,6002)
 6002 format (' ')
   51 continue
!
      p33     =  1.d0/3.d0
      p66     =  2.d0/3.d0
      ier     =  0
!                                  define the 1/3 and 2/3 points on 1st
      call icopy (4,  kfds(4*(1)-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)
      ksgn(1) =  1
      dzsum(i1kseg) = 0.d0
      kmp1    =  kzedg + (i1kseg-1)*kncedg
      do 100 imp = i1kseg+1,i2kseg
          kmp2    =  kmp1 + kncedg
          call distnc (z(1,kmp1),z(1,kmp2),dz)
          dzedg(imp) = dz
          dzsum(imp) = dzsum(imp-1) + dz
          kmp1    =  kmp2
  100 continue
!
      ndef(1) = 0
      ndef(2) = 0
      call dcopy (3,  0.d0,0,  z33,1)
      call dcopy (3,  0.d0,0,  z66,1)
      taupv   =  0.d0
      do 150 imp = i1kseg+1,i2kseg
          tau     =  dzsum(imp)/dzsum(i2kseg)
          if ( taupv.le.p33 .and. p33.le.tau ) then
!                                  found the 1/3 point, evaluate and mar
               ndef(1)  =  1
               dtau    =  dzedg(imp)/dzsum(i2kseg)
               alf     =  (p33-taupv)/dtau
               kmp1    =  kzedg + (imp-2)*kncedg
               kmp2    =  kzedg + (imp-1)*kncedg
               do 120 i = 1,3
                    z33(i) = z(i,kmp1) + alf*( z(i,kmp2) - z(i,kmp1) )
  120          continue
          endif
!
          if ( taupv.le.p66 .and. p66.le.tau ) then
!                                  found the 2/3 point, evaluate and mar
               ndef(2)  =  1
               dtau    =  dzedg(imp)/dzsum(i2kseg)
               alf     =  (p66-taupv)/dtau
               kmp1    =  kzedg + (imp-2)*kncedg
               kmp2    =  kzedg + (imp-1)*kncedg
               do 130 i = 1,3
                    z66(i) = z(i,kmp1) + alf*( z(i,kmp2) - z(i,kmp1) )
  130          continue
          endif
          taupv   =  tau
  150 continue
      if ( ndef(1).eq.0 .or. ndef(2).eq.0 )                             &
     &   call abtend ('peasgn: either z33 or z66 failed to get defined')
!                                  examine the other edges of the pea sp
!                                  evaluating ksgn for each and doing so
!                                  error checking along the way
      kmp1    =  kzedg + (i1kseg-1)*kncedg
      kmp2    =  kzedg + (i2kseg-1)*kncedg
!
      do 900 ie = 2,ne
      ksgn(ie) = 0
      call icopy (4,  kfds(4*(ie)-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)
      lmpe    =  lzedg + (i1lseg-1)*lncedg
      npte    =  i2lseg - i1lseg + 1
!                                  evaluate the orientation of the oppos
!                                  edge using the 1/3, 2/3 method
      call nredge (z33, z(1,lmpe),lncedg,npte,  1,0.d0,  zx33,tx33,dx33)
      call nredge (z66, z(1,lmpe),lncedg,npte,  1,0.d0,  zx66,tx66,dx66)
      isgn    =  1
      if ( tx33.gt.tx66 ) isgn = -1
      lmp1    =  (i1lseg-1)*lncedg + lzedg
      lmp2    =  (i2lseg-1)*lncedg + lzedg
      if ( isgn.lt.0 ) then
          lsv     =  lmp1
          lmp1    =  lmp2
          lmp2    =  lsv
      endif
!                                  check the distance of the opposing ed
!                                  endpoints from the reference edge's
!                                  endpoints
      call distnc (z(1,kmp1),z(1,lmp1),d1)
      call distnc (z(1,kmp2),z(1,lmp2),d2)
      if ( movusr.lt.3 ) goto 210
      write (6,'(1x,a10,1x, 10i12)')                                    &
     & 'ie,sgn,k,l',ie,isgn,knet,ksd,i1kseg,i2kseg                      &
     &                                    ,lnet,lsd,i1lseg,i2lseg
      call outvec ('z33',3,z33)
      call outvec ('z66',3,z66)
      call outvec ('zx33',3,zx33)
      call outvec ('zx66',3,zx66)
      write (6,'(1x,a10,1x, 1p,4e12.4)')                                &
     & 'tx,dx',tx33,tx66,dx33,dx66
      write (6,'(1x,a10,1x, 1p,2e12.4)')                                &
     & 'd1,d2',d1,d2
  210 continue
      if ( d1.gt.peatol .or. d2.gt.peatol ) goto 500
      ksgn(ie) = isgn
      goto 900
!
!                                  the specified opposing edge is not cl
!                                  enough to the reference edge.  see if
!                                  you can figure out what is going on.
  500 continue
      ier     =  ier + 1
      lsdbas  =  lsd
      lsdmn   =  0
      dx12mn  =  1.d38
!                                  check all the edges on the object nw
      do 800 ind = 1,4
      if ( ind.eq.1 ) lsd = lsdbas
      if ( ind.eq.2 ) lsd = mod(lsdbas+2,4) + 1
      if ( ind.eq.3 ) lsd = mod(lsdbas  ,4) + 1
      if ( ind.eq.4 ) lsd = mod(lsdbas+1,4) + 1
!                                  don't examine collapsed edges
      ledg    =  lsd + (lnet-1)*4
      if ( iedgtp(ledg).eq.1 ) goto 800
!                                  an edge may not abut itself
      if ( lsd.eq.ksd .and. knet.eq.lnet ) goto 800
!
      call edgind (lsd,nm(lnet),nn(lnet)                                &
     &            ,lzedg,lncedg,lncint,lnedg)
      lzedg   =  lzedg + nza(lnet)
      lmpe    =  lzedg
      npte    =  lnedg
!
      call nredge (z33, z(1,lmpe),lncedg,npte,  1,0.d0,  zx33,tx33,dx33)
      call nredge (z66, z(1,lmpe),lncedg,npte,  1,0.d0,  zx66,tx66,dx66)
      isgn    =  1
      if ( tx33.gt.tx66 ) isgn = -1
!
      call nredge (z(1,kmp1), z(1,lmpe),lncedg,npte, -isgn,tx33         &
     &            ,zx1,tx1,dx1)
      call nredge (z(1,kmp2), z(1,lmpe),lncedg,npte,  isgn,tx66         &
     &            ,zx2,tx2,dx2)
!
      dx12    =   max ( dx1, dx2)
      if ( dx12.lt.dx12mn ) then
          tx1mn   =  tx1
          tx2mn   =  tx2
          dx12mn  =  dx12
          lsdmn   =  lsd
      endif
!
      if ( dx1.gt.peatol .or. dx2.gt.peatol ) goto 800
!                                  find integer nearest to tx1 and tx2
      ix1     =  tx1 + .5d0
      ix2     =  tx2 + .5d0
      i1lseg  =  max( 1, min( lnedg, ix1) )
      i2lseg  =  max( 1, min( lnedg, ix2) )
      lmp1    =  lncedg*(i1lseg-1) + lzedg
      lmp2    =  lncedg*(i2lseg-1) + lzedg
      call distnc (z(1,kmp1),z(1,lmp1),d1)
      call distnc (z(1,kmp2),z(1,lmp2),d2)
      d12     =   max ( d1, d2)
!                                  report out recommendation/info
      write (6,6003) ie,lnet,lsd,  tx1,tx2,dx12,  i1lseg,i2lseg,d12
 6003 format (' list position:',i3,'  nw.edge:',i3,'.',i1               &
     &    ,'   t values: begin',f7.3,' end',f7.3,' distance',e10.2      &
     &    ,'   i values: begin',i4  ,' end',i4  ,' distance',e10.2      &
     &    )
      goto 850
!
  800 continue
      write (6,6004) ie,lnet,lsdmn,  tx1mn,tx2mn,dx12mn
 6004 format (' list position:',i3,'  nw.edge:',i3,'.',i1               &
     &    ,'   t values: begin',f7.3,' end',f7.3,' distance',e10.2      &
     &    ,'   <<< best possible candidate (not acceptable) '           &
     &    )
!
  850 continue
!
  900 continue
!
      return
      END subroutine peasgn
! **deck pident
      subroutine pident (p,q,ident)
      implicit double precision (a-h,o-z)
      logical ident
      dimension p(3),q(3)
      delta  =  1.0d-12
      scale = sqrt(p(1)**2+p(2)**2+p(3)**2)+                            &
     &        sqrt(q(1)**2+q(2)**2+q(3)**2)
      ident = ((p(1)-q(1))**2+(p(2)-q(2))**2+(p(3)-q(3))**2).le.        &
     &        ((scale*delta)**2)
      if (scale.le.delta) ident = .true.
      return
      END subroutine pident
! **deck pifcal
      subroutine pifcal(z,ksymm,ne,dvs,dvd)
      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 near field panel influence coefficients           *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  pifcal cycles through all eight sub-panels of the given panel*
!     *  and accumulates their contributions to the singularity       *
!     *  induced potential (and possibly velocity) at the field point.*
!     *  the contribution of each sub-panel is calculated by the      *
!     *  subroutine nftpic, the output of this routine being post-    *
!     *  multiplied by the source and/or doublet sub-panel spline     *
!     *  matrices before accumulation.                                *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   dvd       argument  output    influence of nine canonical   *
!     *                                 panel doublet values on       *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvdp      /skrch3/  -local-   influence of sub-panel taylors*
!     *                                 series doublet coefficients on*
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvs       argument  output    influence of taylors series   *
!     *                                 source coefficients on        *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvsp      /skrch3/  -local-   influence of sub-panel taylors*
!     *                                 series source coefficients on *
!     *                                 potential (and possibly global*
!     *                                 coordinates of velocity) at   *
!     *                                 field point                   *
!     *                                                               *
!     *   ipn       /pandq/   input     overall panel index           *
!     *                                                               *
!     *   is        -local-   - - - -   index over four interior or   *
!     *                                 exterior sub-panels           *
!     *                                                               *
!     *   ksymm     argument  input     control point image indicator *
!     *                                 =1   zc is original control   *
!     *                                      point                    *
!     *                                 =2 thru 4  zc is reflection of*
!     *                                      original control point   *
!     *                                      across a plane of        *
!     *                                      symmetry                 *
!     *                                                               *
!     *                                                               *
!     *   ncd       /pandq/   input     number of parameters (i.e.    *
!     *                                 canonical values) defining    *
!     *                                 panel doublet distribution    *
!     *                                                               *
!     *                                                               *
!     *   ne        argument  input     number of components of       *
!     *                                 combined potential/velocity   *
!     *                                 coefficients desired          *
!     *                                                               *
!     *   nf        -local-   - - - -   number of taylors series      *
!     *                                 coefficients in sub-panel     *
!     *                                 doublet distribution          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call kstrns
      common /kstrns/ nstrns, mstrns
!end  kstrns
!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 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 norx
!                                                            /norx/
      common /norx/ sgnx, diamx
!end  norx
!call psdflg
      common /psdflg/ psdpan
      integer psdpan
!end  psdflg
!call dsnpic
      common /dsnicr/ phsdsn(6), vsdsn(3,6), phxdsn(3,4), phydsn(3,4)
      common /dsnicl/ dsnic
      logical dsnic
!end  dsnpic
!call 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
!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
      dimension  w(3), xx(3)
      dimension dvsp(24), dvdp(40)
! --- real*8 dvsp, dvdp
      dimension alcf(3)
!
      dimension z(3),dvs(ne,3),dvd(ne,9)
! --- real*8 dvs, dvd
      logical ponq
      data nf,icsp /6,4/
!
!                                  compute near field splines if necessa
      if ( psdpan.eq.ipn ) go to 10
          call psddq6
          psdpan  =  ipn
          mstrns  =  mstrns + 1
   10 continue
!c
!     *  initialize output arrays                                     *
!
      diamx   =  diam
      netp    =  ityprc*ne
      if (its.gt.1) call zero (dvd,netp*ncd)
      if (its.ne.2) call zero (dvs,netp*ncs)
!                                   define requests of nftpic calls
      nfx     =  nf
      nex     =  ne
      itsx    =  its
      if ( dsnic ) then
         call zero(phxdsn,12)
         call zero(phydsn,12)
         nfx     =  max(nf,6)
         nex     =  max(ne,1)
! ------ nfx     =  10               ; phxdsn
! ------ nex     =  4                ; phxdsn
         phstot  =  0.d0
         if ( mod(itsx,2).eq.0 ) itsx = itsx+1
      endif
      nextp   =  nex*ityprc
      ns      =  4
!c
!     *  cycle through panel corner points                            *
!
      do 400 is=1,4
      isp1=mod(is,4)+1
      isp2=mod(isp1,4)+1
      isp3=mod(isp2,4)+1
!c
!     *  compute contribution of outer sub-panel                      *
!
!c
!     *  if sub-panel is collapsed, ignore contribution               *
!
      if((ics.eq.is).or.(ics.eq.isp3)) go to 300
!c
!     *  compute orientation parameter for superinclined sub-panel    *
!     *  influence coefficient calculations                           *
!
      sgnx=sgx(is)
!c
!     *  transform coordinates of field (control) point from global to*
!     *  local sub-panel coordinates                                  *
!
      w(1)    =  z(1) - cp(1,is)
      w(2)    =  z(2) - cp(2,is)
      w(3)    =  z(3) - cp(3,is)
      xx(1)   =  ar(1,is)*w(1) + ar(4,is)*w(2) + ar(7,is)*w(3)
      xx(2)   =  ar(2,is)*w(1) + ar(5,is)*w(2) + ar(8,is)*w(3)
      xx(3)   =  ar(3,is)*w(1) + ar(6,is)*w(2) + ar(9,is)*w(3)
!c
!     *  if field point lies exactly on panel set 3d local coordinate *
!     *  to exact zero in conformity with convention in sub-panel     *
!     *  influence coefficient calculation routines                   *
!
      ponq    =  (ipn.eq.ipc).and.(icc.eq.is  ).and.(ksymm.eq.1)
      if ( ponq ) xx(3)=0.d0
!c
!     *  calculate contribution of sub-panel to panel influence       *
!     *  coefficients                                                 *
!
      call nftpic (amach,iin(is),aj(is),ar(1,is),pp(1,1,is)             &
     &            ,icsp,ns,itsx,xx,nex,nfx,dvsp,dvdp)
!c
!     *  if panel has doublet distribution post-multiply by sub-panel *
!     *  doublet spline matrix                                        *
!
      if (its.gt.1) call hsmmp2 (9,6,netp,    qq(1,1,is),6,1            &
     &                          ,dvdp,nextp,1,  dvd,netp,1 )
!c
!     *  if panel has source distribution post-multiply by sub-panel  *
!     *  source spline matrix                                         *
!
      if (its.ne.2) call hsmmp2 (3,3,netp,    rr(1,1,is),3,1            &
     &                          ,dvsp,nextp,1,  dvs,netp,1 )
      if ( dsnic ) then
! ------ call mcopy (3,6,  dvsp(2),1,4,  vsdsn,1,3)            ; phxdsn
! ------ call hsmmp2 (1,18,12,  vsdsn,1,1,  wcsdn(1,1,is),1,18 ; phxdsn
! ---x               ,phxdsn,1,1)                              ; phxdsn
         call hsmmp2 (1,3,12,  dvsp,1,nex,  acsdn(1,1,is),1,3           &
     &               ,phydsn,1,1)
         if ( jcn.eq.-5 ) then
            call hsmmp1 (3,12,1, acsdn(1,1,is),1,3, cp,1,12, alcf,1,3)
            psisub  =  ddot(3,  alcf,1,  dvsp,4)
            call dcopy (3,  dvsp,4,  phsdsn,1)
            phycum  =  ddot(12,  phydsn,1,  cp,1)
            phstot  =  phstot + dvsp(1)
            write (6,'('' pan, subp:'',2i6,''  part, cum psi:'',3f16.10 &
     &      ,'' alcf:'',3e12.4)' ) ipn,is,psisub,phycum,phstot,alcf
            call outvcx ('phsdsn-sub',3,phsdsn)
         endif
      endif
  300 continue
!c
!     *  compute contribution of inner sub-panel                      *
!
!c
!     *  compute orientation parameter for superinclined sub-panel    *
!     *  influence coefficient calculations                           *
!
      sgnx=sgx(5)
!c
!     *  transform coordinates of field (control) point from global to*
!     *  local sub-panel coordinates                                  *
!
      w(1)    =  z(1) - cp(1,9)
      w(2)    =  z(2) - cp(2,9)
      w(3)    =  z(3) - cp(3,9)
      xx(1)   =  ar(1,5)*w(1) + ar(4,5)*w(2) + ar(7,5)*w(3)
      xx(2)   =  ar(2,5)*w(1) + ar(5,5)*w(2) + ar(8,5)*w(3)
      xx(3)   =  ar(3,5)*w(1) + ar(6,5)*w(2) + ar(9,5)*w(3)
!c
!     *  if field point lies exactly on panel set 3d local coordinate *
!     *  to exact zero in conformity with convention in sub-panel     *
!     *  influence coefficient calculation routines                   *
!
      ponq    =  (ipn.eq.ipc).and.(icc.eq.is+4).and.(ksymm.eq.1)
      if ( ponq ) xx(3)=0.d0
!
!     *  calculate contribution of sub-panel to panel influence       *
!     *  coefficients                                                 *
!c
      call nftpic (amach,iin( 5),aj( 5),ar(1, 5),pp(1,1,is+4)           &
     &            ,icsp,ns,itsx,xx,nex,nfx,dvsp,dvdp)
!c
!     *  if panel has doublet distribution post-multiply by sub-panel *
!     *  doublet spline matrix                                        *
!
      if (its.gt.1) call hsmmp2 (9,6,netp,    qq(1,1,is+4),6,1          &
     &                          ,dvdp,nextp,1,  dvd,netp,1 )
!c
!     *  if panel has source distribution post-multiply by sub-panel  *
!     *  source spline matrix                                         *
!
      if (its.ne.2) call hsmmp2 (3,3,netp,    rr(1,1,is+4),3,1          &
     &                          ,dvsp,nextp,1,  dvs,netp,1 )
      if ( dsnic ) then
! ------ call mcopy (3,6,  dvsp(2),1,4,  vsdsn,1,3)            ; phxdsn
! ------ call hsmmp2 (1,18,12,  vsdsn,1,1,  wcsdn(1,1,is+4),1,18
! ---x               ,phxdsn,1,1)                              ; phxdsn
         call hsmmp2 (1,3,12,  dvsp,1,nex,  acsdn(1,1,is+4),1,3         &
     &               ,phydsn,1,1)
         if ( jcn.eq.-5 ) then
            call hsmmp1 (3,12,1, acsdn(1,1,is+4),1,3, cp,1,12, alcf,1,3)
            psisub  =  ddot(3,  alcf,1,  dvsp,4)
            call dcopy (3,  dvsp,4,  phsdsn,1)
            phycum  =  ddot(12,  phydsn,1,  cp,1)
            phstot  =  phstot + dvsp(1)
            write (6,'('' pan, subp:'',2i6,''  part, cum psi:'',3f16.10 &
     &      ,'' alcf:'',3e12.4)' ) ipn,is,psisub,phycum,phstot,alcf
            call outvcx ('phsdsn-sub',3,phsdsn)
         endif
      endif
  400 continue
  900 return
      END subroutine pifcal
! **deck pivc
      subroutine pivc (ne  ,nncp,phic  ,nnvcp,vic  ,npt,phix            &
     &                ,ifluar,iflumx,astcpx)
      implicit double precision (a-h,o-z)
!                                  /timing/
      dimension phic(nncp,1), vic(3,nnvcp,1)
! --- real*8 phic, vic
      dimension phix(3,npt)
      logical astcpx
!!      integer ifluar(2,2)                                                 ! Removed by Martin Hegedus, 4/21/09
      integer ifluar(4)                                                   ! Added by Martin Hegedus, 4/21/09
      integer ifluai                                                      ! Added by Martin Hegedus, 4/21/09
!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 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
!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
!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
      dimension lz(4)
!call piccnt
!                                                     /piccnt/
      common /piccnt/ npic(4,7), n56chg(0:3)
!end  piccnt
!call kstrns
      common /kstrns/ nstrns, mstrns
!end  kstrns
!call psdflg
      common /psdflg/ psdpan
      integer psdpan
!end  psdflg
      dimension z(3)
      dimension     dvs(24),dvd(40),dvds(24),dvdd(40),dv(240)
! --- real*8       dvs,dvd,dvds,dvdd,dv
      dimension cpsq(4), acqd(3)
      dimension almcof(3), almevl(3,8), almtru(3,8), isx(3)
      dimension dvs4(4,6), dvd4(4,10), dvds4(4,6), dvdd4(4,10),phvic(48)
! --- real*8 dvs4,     dvd4,       dvds4,      dvdd4,      phvic,one
      dimension awki(3,3), gen(3)
      dimension phvlin(20)
      logical lffld, dvset, ltewic
      equivalence (dvs,dvs4), (dvd,dvd4), (dvds,dvds4), (dvdd,dvdd4)
! --- dimension  dvsa(2,24), dvda(2,40)
! --- equivalence (dvsa,dvs), (dvda,dvd)
!
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!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 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 lndblx
!                                                           /lndblx/
      common /lndblx/ genwak(3,mxnett), slndbl(mxnett)                  &
     &              , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett)
!end  lndblx
!call dsnpic
      common /dsnicr/ phsdsn(6), vsdsn(3,6), phxdsn(3,4), phydsn(3,4)
      common /dsnicl/ dsnic
      logical dsnic
!end  dsnpic
!call gsqrwi
      parameter (npagpx=400)
      common /gsqrwi/ nsqg, npagp, npngrp(npagpx), nspgrp(npagpx)       &
     &              , ndsgrp, nptgrp(npagpx)
!end  gsqrwi

!---- COMPLEX*16 omgbar,omegb,omg                           ! added RLC 14Dec2004
      COMMON /FREQDT/ omgbar,omegb,omg,omgabs               ! added RLC 14Dec2004

      data isix/0/
      data ncall /0/
!
      ncall = ncall + 1
      dsnic   =  .false.
      if ( ndsgrp.ne.0 ) dsnic = .true.
!
      dvset   =  .false.
! ----      call dinflu (zc,ifluar,iflumx)
      if ( iflumx.eq.0 ) go to 950
      lffld   =  iflumx.le.4
!                                  determine if panel is in the last
!                                  row of a wake network for which
!                                  downstream ic's have been requested.
      call qtewic (ltewic)
      if ( ltewic ) lffld = .false.
      ncdp    =  9
      if ( lffld ) ncdp = 6
      nf      =  6
      ng      =  3
      netp    =  ne*ityprc
!
      if ( itsf.ne.1 ) call zero (dvdd,netp*ncdp)
      if ( itsf.ne.2 ) call zero (dvds,netp*ng)
!                                  include effects of infinite wake
      if ( ltewic ) then
          call vadd (cp(1,7), -1.d0, cp(1,5), gen, 3)
          call uvect (gen)
          call dcopy (3,  genwak(1,kpf),1,  gen,1)
          call ntewic (gen,  ne,zc,  indkgp,phvic,awki)
          call dcopy (ne*ncdp,  phvic,1,  dvdd,1)
!                                  include the effects of linear mu/x
!                                  coefficients
          if ( inmux.eq.0 ) goto 7515
          lphvic   =  ne*ncdp+1
          call hsmmp1 (ne,3,inmux,  phvic(lphvic),1,ne,  astmux,1,3     &
     &                ,phvlin,1,ne)
          if ( jcn.eq.ipraic ) then
           write (6,'('' wake integrals '',3i5,3d12.4)')ipn,ne,lphvic,zc
             call outmtx ('phvic',ne,ne,12,phvic)
             call outvci ('iimux',inmux,iimux)
             call outvci ('iimuxg',inmux,iimuxg)
             call outmtx ('phvlin',ne,ne,inmux,phvlin)
             call outmtx ('astmux',3,3,inmux,astmux)
          endif
          lphv    =  1
          do 7514 k = 1,inmux
             indkgp  =  iimuxg(k)
! ---------- call daxpy (ne, 1.d0, phvlin(lphv),1,  aic(indkgp,1),naic)
             phic(1,indkgp) = phic(1,indkgp) + phvlin(lphv)
             if (ne.gt.1) call daxpy (3  ,1.d0  ,phvlin(lphv+1),1       &
     &                               ,vic(1,1,indkgp),1)
             lphv    =  lphv + ne
 7514     continue
 7515     continue
      endif
!
!
      sgni    =  -1.d0
      do 200 isymm = 1,nisym
      sgni    =  -sgni
      sgnj    =  -1.d0
      do 175 jsymm = 1,njsym
      sgnj    =  -sgnj
      ksymm   =  isymm*jsymm
      sgnk =1.d0
      if(isymm*misym.eq.-2) sgnk=-sgnk
      if(jsymm*mjsym.eq.-2) sgnk=-sgnk
      z(1)=zc(1)
      z(2)=sgni*zc(2)
      z(3)=sgnj*zc(3)
!!      iflun   =  ifluar(isymm,jsymm)                                      ! Removed by Martin Hegedus, 4/21/09
      ifluai  = (jsymm-1)*nisym + isymm                                   ! Added by Martin Hegedus, 4/21/09
      iflun   =  ifluar(ifluai)                                           ! Added by Martin Hegedus, 4/21/09
      if ( iflun.eq.0 ) go to 160
!                                  timset/ii, ii=11,20
      if ( iflun - 4 ) 20,25,30
   20 continue
!                                  far field and quasi far field computa
      call ffpic (z,iflun,ne,nf,dvs,dvd)
      go to 27
!                                  quasi far field computation
   25 continue
      call qffcal (z,ne,nf,dvs,dvd)
!
   27 continue
      if ( itsf.eq.1  .or.  lffld ) go to 40
      call mxm (dvd,netp,qa,6,dv,9)
      call dcopy (9*netp,dv,1,dvd,1)
      go to 40
!                                  near field and quasi near field
!                                  computation
   30 continue
      iflinp  =  iflun
!-----      call qnfcal(z,iflun,ksymm,ne,dvs,dvd)
         call qnfcal(z,iflun,ksymm,ne,dvs,dvd)
      if(iflun.ge.6) call pifcal(z,ksymm,ne,dvs,dvd)
      if ( iflun.ne.iflinp ) n56chg(itsf) = n56chg(itsf) + 1
!
   40 continue
!                                  include contribution to dvds and dvdd
      if ( jcn.eq.ipraic ) then
       write(6,'('' pivc jc,ip,isym,jsym,iflu,isqn,f'',6i6,1p,3e12.4))')&
     &        jcn,ipnf,isymm,jsymm,iflun,isqn,omgbar,omegb,omg
       if ( mod(itsf,2).ne.0 ) call outmtx ('dvs',netp,netp,ng,dvs4)
       if ( itsf.ge.2 )        call outmtx ('dvd',netp,netp,ncdp,dvd4)
      endif
      dvset   =  .true.
      if ( ne.eq.1 ) go to 130
!                                  ne = 4
      if ( itsf.eq.2 ) go to 110
!                                  source
      do 105 j = 1,ng
          dvds4(1,j) = dvds4(1,j) + dvs4(1,j) * sgnk
          dvds4(2,j) = dvds4(2,j) + dvs4(2,j) * sgnk
          dvds4(3,j) = dvds4(3,j) + dvs4(3,j) * sgnk * sgni
          dvds4(4,j) = dvds4(4,j) + dvs4(4,j) * sgnk * sgnj
  105 continue
  110 continue
      if ( itsf.eq.1 ) go to 160
!                                  doublet
      do 115 j = 1,ncdp
          dvdd4(1,j) = dvdd4(1,j) + dvd4(1,j) * sgnk
          dvdd4(2,j) = dvdd4(2,j) + dvd4(2,j) * sgnk
          dvdd4(3,j) = dvdd4(3,j) + dvd4(3,j) * sgnk * sgni
          dvdd4(4,j) = dvdd4(4,j) + dvd4(4,j) * sgnk * sgnj
  115 continue
      go to 160
!
  130 continue
      if ( itsf.ne.2 ) call daxpy (ityprc*ng,    sgnk,  dvs,1,  dvds,1)
      if ( itsf.ge.2 ) call daxpy (ityprc*ncdp,  sgnk,  dvd,1,  dvdd,1)
  160 continue
!                                  timcum/ii, ii=11,20
  165 continue
! ---      if ( itsf.ne.2 ) npic(1,iflun+1)=npic(1,iflun+1) + 1
! ---      if ( itsf.ge.2 ) npic(2,iflun+1)=npic(2,iflun+1) + 1
  175 continue
  200 continue
!
!
      istcpx = 0
      if ( astcpx ) istcpx = 1
!
      if ( .not.dvset ) go to 950
!                                  timcum/9
!                                  timset/10
!
      if ( lffld ) go to 600
!                                  not a block and not a far field
      if ( itsf.eq.2 ) go to 550
      if ( .not. astcpx )                                               &
     & call hsmmp1 (insf,3,netp,  asts,3,1,  dvds,netp,1,  dv,netp,1)
      if ( astcpx )                                                     &
     & call hcmmp1 (insf,3,ne,    asts,3,1,  dvds,ne,1,    dv,ne,1)
      if ( jcn.eq.ipraic ) then
         write (6,'('' indadd: jc,ip,istcpx'',3i5)')                    &
     &         jcn,ipnf,istcpx
         call outmtx ('asts',3,3,ins,asts)
         call outvci ('iisf',insf,iisf)
         call outmtx ('dv-nf-src',netp,netp,insf,dv)
         call outmtx ('dvs',netp,netp,3,dvds)
      endif
      call indadd (ne,insf,iisf,dv  ,nncp,phic  ,nnvcp,vic)
  550 continue
      if ( itsf.eq.1 ) go to 700
      if ( .not. astcpx )                                               &
     & call hsmmp1 (indf,ncdp,netp, astd,ncdp,1, dvdd,netp,1, dv,netp,1)
      if ( astcpx )                                                     &
     & call hcmmp1 (indf,ncdp,ne,   astd,ncdp,1, dvdd,ne,1,   dv,ne,1)
      if ( jcn.eq.ipraic ) then
         write (6,'('' indadd: jc,ip,istcpx'',3i5)')                    &
     &         jcn,ipnf,istcpx
         call outmtx ('astd',9,9,ind,astd)
         call outvci ('iidf',indf,iidf)
         call outmtx ('dv-nf-dbl',netp,netp,indf,dv)
         call outmtx ('dvd',netp,netp,ncdp,dvdd)
      endif
      call indadd (ne,indf,iidf,dv  ,nncp,phic  ,nnvcp,vic)
      go to 700
!                                  far field accumulation
  600 continue
      if ( itsf.eq.2 ) go to 650
      if ( .not. astcpx )                                               &
     & call hsmmp1 (insf,ng,netp,  astsf,ng,1,  dvds,netp,1,  dv,netp,1)
      if ( astcpx )                                                     &
     & call hcmmp1 (insf,ng,ne,    astsf,ng,1,  dvds,ne,1,    dv,ne,1)
      if ( jcn.eq.ipraic ) then
         write (6,'('' indadd: jc,ip,istcpx'',3i5)')                    &
     &         jcn,ipnf,istcpx
         call outmtx ('astsf',3,3,insf,astsf)
         call outvci ('iisf',insf,iisf)
         call outmtx ('dv-ff-src',netp,netp,insf,dv)
         call outmtx ('dvs',netp,netp,ng,dvds)
      endif
      call indadd (ne,insf,iisf,dv  ,nncp,phic  ,nnvcp,vic)
  650 continue
      if ( itsf.eq.1 ) go to 700
      if ( .not. astcpx )                                               &
     & call hsmmp1(indf,ncdp,netp, astdf,ncdp,1, dvdd,netp,1, dv,netp,1)
      if ( astcpx )                                                     &
     & call hcmmp1 (indf,ncdp,ne,  astdf,ncdp,1, dvdd,ne,1,   dv,ne,1)
      if ( jcn.eq.ipraic ) then
         write (6,'('' indadd: jc,ip,istcpx'',3i5)')                    &
     &         jcn,ipnf,istcpx
         call outmtx ('astdf',6,6,indf,astdf)
         call outvci ('iidf',indf,iidf)
         call outmtx ('dv-ff-dbl',netp,netp,indf,dv)
         call outmtx ('dvd',netp,netp,ncdp,dvdd)
      endif
      call indadd (ne,indf,iidf,dv  ,nncp,phic  ,nnvcp,vic)
  700 continue
!                                  timcum/10
  950 continue
      return
      END subroutine pivc
! **deck pivv
      subroutine pivv (isol,ipc,zc,pv)
      implicit double precision (a-h,o-z)
      dimension pv(4,1)
      dimension zc(3)
!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
!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 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 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 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 symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call slstat
      common /slstat/ tpvcal, tpivv, npicsl(7), npvcal, nphvsl
!end  slstat
!call norx
!                                                            /norx/
      common /norx/ sgnx, diamx
!end  norx
!call nftphd
      common /nftphd/ phimuz
!end  nftphd
!ca lndblx
!                                                           /lndblx/
      common /lndblx/ genwak(3,mxnett), slndbl(mxnett)                  &
     &              , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett)
!end  lndblx
      logical ltewic, within
      dimension gen(3), phvic(4,12), awki(3,3)
      dimension enloc(3)
!!      dimension ifluar(2,2), z(3), x(3), pvsd(4,4), pvsdp(4,4)            ! Removed by Martin Hegedus, 4/21/09
      dimension dvs(4,6), dvd(4,10)
      dimension ifluar(4), z(3), x(3), pvsd(4,4), pvsdp(4,4)              ! Added by Martin Hegedus, 4/21/09
      integer ifluai                                                      ! Added by Martin Hegedus, 4/21/09
      data icsp /4/
      data ns /4/
      data enloc / 0.d0, 0.d0, 1.d0 /
      call dinflu (zc,ifluar,iflumx)
      iv     =  isol
      if ( isol.eq.0 ) iv = 1
      nv     =  1
      if ( isol.eq.0 ) nv = nacase
      sgni=-1.d0
      do 800 isymm=1,nisym
      sgni=-sgni
      sgnj=-1.d0
      do 775 jsymm=1,njsym
      sgnj = -sgnj
!!      iflun=ifluar(isymm,jsymm)                                           ! Removed by Martin Hegedus, 4/21/09
      ifluai = (jsymm-1)*nisym + isymm                                    ! Added by Martin Hegedus, 4/21/09
      iflun=ifluar(ifluai)                                                ! Added by Martin Hegedus, 4/21/09
      if ( iflun.eq.0 ) npicsl(1) = npicsl(1) + 1
      if(iflun.eq.0) go to 775
      sgnk =1.d0
      if(isymm*misym.eq.-2) sgnk=-sgnk
      if(jsymm*mjsym.eq.-2) sgnk=-sgnk
      z(1)=zc(1)
      z(2)=sgni*zc(2)
      z(3)=sgnj*zc(3)
      ksymm   =  isymm*jsymm
      go to (300, 300, 300, 400, 500, 500), iflun
  300 continue
!
!    *   far field influence calculation.
!
      nf=6
!                                  when only one solution is being proce
!                                  use ffpiv to optimize efficiency
      if ( nv.le.1 ) go to 350
!                                  use ffpiv for several solutions
      do 330 ix = 1,nv
         iiv = ix-1+iv
         call ffpiv (iiv,z,iflun,pvsd(1,ix))
  330 continue
      go to 390
!                                  ffpiv for a single solution
  350 continue
      call ffpiv (iv,z,iflun,pvsd)
      go to 390
!
  390 continue
      go to 750
  400 continue
!
!    *   one subpanel case, type 4, influence calculation.
!
      call unipan (ar(1,5),cp(1,9),z,x)
      nf=6
      call nftpiv(amach,iin(5),aj(5),ar(1,5),pf,ics,ns,its,x,nf,        &
     &         nv,sv1(1,iv),3,dv1(1,iv),6,pvsd)
      go to 750
  500 continue
!
!    *   two subpanel case, type 5, influence calculation.             *
!
!                                 if the off-body point is on the
!                                 panel, force a near field evaluation
      if ( ksymm.eq.1 .and. ipc.eq.ipnf ) goto 600
      if ( iflun.eq.5 ) go to 520
      call unipan (aq,cp(1,9),z,x)
      testm =  1.44d0*( (1.d0+abs(c1))**2                               &
     &                 +(1.d0+abs(c2))**2                               &
     &                 +(1.d0+abs(c3))**2  )
      test   =  x(1)**2 + x(2)**2 + x(3)**2
      if ( test.lt.testm ) go to 590
  520 continue
      test    =  0.d0
      call zero (pvsd,4*nv)
      is=isqn
      nf=10
      do 550 k=1,2
      if(k.eq.2) is=mod(is+1,4)+1
      sgnx=sgx(is)
      call unipan(ar(1,is),cp(1,is),z,x)
      call nftpiv(amach,iin(is),aj(is),ar(1,is),pk(1,1,k),icsp,ns,      &
     &         its,x,nf,nv,sv2(1,k,iv),6,dv2(1,k,iv),20,pvsdp)
      call daxpy (4*nv,  1.d0,  pvsdp,1,  pvsd,1)
      if ( its.gt.1 ) test = test + abs(phimuz)
      if ( ics.ne.0 ) go to 580
  550 continue
  580 continue
      iflun   =  5
      if ( amach.gt.(1.d0) .and. test.gt.(.01d0) ) iflun = 6
  590 continue
      if ( iflun.eq.5 ) go to 750
  600 continue
!
!    *   eight subpanel case, type 6, influence calculation.           *
!
      nf=6
      call zero (pvsd,4*nv)
      do 650 is=1,4
      isp1=mod(is,4)+1
      isp2=mod(isp1,4)+1
      isp3=mod(isp2,4)+1
      if((ics.eq.is).or.(ics.eq.isp3)) go to 625
      sgnx=sgx(is)
      call unipan(ar(1,is),cp(1,is),z,x)
 6201 format (' ===',5i5,3e16.8)
      if ( ksymm.eq.1 .and. ipc.eq.ipnf ) then
         call inside (pp(1,1,is),4,enloc,x,within)
         if ( within ) x(3) = 0.d0
!--         iwith   =  0
!--         if ( within ) iwith = 1
!--         write (6,6201) ksymm,ipc,ipnf,is,iwith,x
      endif
      call nftpiv(amach,iin(is),aj(is),ar(1,is),pp(1,1,is),icsp,ns,     &
     &         its,x,nf,nv,sv8(1,is  ,iv),24,dv8(1,is  ,iv),48,pvsdp)
      call daxpy (4*nv,  1.d0,  pvsdp,1,  pvsd,1)
  625 continue
      call unipan (ar(1,5),cp(1,9),z,x)
      if ( ksymm.eq.1 .and. ipc.eq.ipnf ) then
         call inside (pp(1,1,is+4),4,enloc,x,within)
         if ( within ) x(3) = 0.d0
!--         iwith   =  0
!--         if ( within ) iwith = 1
!--         write (6,6201) ksymm,ipc,ipnf,is+4,iwith,x
      endif
      call nftpiv(amach,iin(5),aj(5),ar(1,5),pp(1,1,is+4),icsp,ns,      &
     &         its,x,nf,nv,sv8(1,is+4,iv),24,dv8(1,is+4,iv),48,pvsdp)
      call daxpy (4*nv,  1.d0,  pvsdp,1,  pvsd,1)
  650 continue
  750 continue
      npicsl(iflun+1) = npicsl(iflun+1) + 1
      do 760 j = 1,nv
          pv(1,j) =  pv(1,j) + pvsd(1,j)*sgnk
          pv(2,j) =  pv(2,j) + pvsd(2,j)*sgnk
          pv(3,j) =  pv(3,j) + pvsd(3,j)*sgnk*sgni
          pv(4,j) =  pv(4,j) + pvsd(4,j)*sgnk*sgnj
  760 continue
  775 continue
  800 continue
  900 continue
      call qtewic (ltewic)
      if ( ltewic ) then
          call dcopy (3,  genwak(1,kpf),1,  gen,1)
          call ntewic (gen,  4,zc,  indkgp,phvic,awki)
          call hsmmp2 (4,9,nv,  phvic,1,4,  dvz(1,iv),1,9,  pv,1,4)
          call hsmmp2 (4,3,nv, phvic(1,10),1,4, amuxz(1,iv),1,3, pv,1,4)
      endif
      return
      END subroutine pivv
! **deck pplcnt
      integer function pplcnt (int)
!
!        count the number of bits (up to 16) turned on in the
!        (assumed to be positive) integer  int
!
      kint    =  iabs(int)
      nbit    =  0
      do 100 k = 1,16
          if ( mod(kint,2).ne.0 ) nbit = nbit + 1
          kint  =  kint/2
  100 continue
      pplcnt  =  nbit
      return
      END Function pplcnt
! **deck pppdq
      subroutine pppdq (nsngtp,sngv)
      implicit double precision (a-h,o-z)
      dimension sngv(nsngtp,4)
!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 rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!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 rtrnbk
      common /rtrnbk/ cpr(3,4), enr(3,5), diamr, itdm, itsr, icsr, isqnr&
     &              , ipr, kpr, pwr(3), pxr, rfminr, qdltr, rqffr(3,4)  &
     &              , c1r, c2r, c3r, aqr(9), encfr(3)                   &
     &              , sv1r1(3), dv1r1(6), dvzr1(9), amuxr1(3)           &
     &              , sv2r1(3,2), dv2r1(10,2)                           &
     &              , sv8r1(3,8), dv8r1(6,8)                            &
     &              , usvr1(6),  uvmvr1(4,6), amsvr1(3,3), amdvr1(3,3)  &
     &              , sv1r2(3), dv1r2(6), dvzr2(9), amuxr2(3)           &
     &              , sv2r2(3,2), dv2r2(10,2)                           &
     &              , sv8r2(3,8), dv8r2(6,8)                            &
     &              , usvr2(6),  uvmvr2(4,6), amsvr2(3,3), amdvr2(3,3)  &
     &              , sv1r3(3), dv1r3(6), dvzr3(9), amuxr3(3)           &
     &              , sv2r3(3,2), dv2r3(10,2)                           &
     &              , sv8r3(3,8), dv8r3(6,8)                            &
     &              , usvr3(6),  uvmvr3(4,6), amsvr3(3,3), amdvr3(3,3)  &
     &              , sv1r4(3), dv1r4(6), dvzr4(9), amuxr4(3)           &
     &              , sv2r4(3,2), dv2r4(10,2)                           &
     &              , sv8r4(3,8), dv8r4(6,8)                            &
     &              , usvr4(6),  uvmvr4(4,6), amsvr4(3,3), amdvr4(3,3)
      integer rtrnbf(435)
      equivalence (rtrnbf,cpr)
!
!end  rtrnbk
!call sngval
      common /sngval/ nsngv, nsolv
!end  sngval
!call solnt
      common/solnt/naic,nrhs,nans,nsc1,nsc2,nsc3,nsc4,iray(10),mtitle(5)
!end  solnt
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!call irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!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 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
!
!
!
      ntr     =  18
      nwsdv   =  locfcn(sv1r2) - locfcn(sv1r1)
      call dlocfx (nwsdv)
      nrdq    =  locfcn(sv1r1) - locfcn(cpr)
      call dlocfx (nrdq)
      nrdq    =  nrdq + nacase*nwsdv
      rewind nans
      nsolv   =  nacase
      nsngv   =  nsngt
      do 20 j = 1,nacase
          read (nans) (sngv(i,j),i=1,nsngv)
   20 continue
!
      npanr   =  0
      rewind ntr
      do 100 inwofb = 1,nnwofb
      knet    =  nwofb(inwofb)
      ip1     =  npa(knet) + 1
      ip2     =  npa(knet+1)
      npanr   =  npanr + npa(knet+1) - npa(knet)
      do 50 ip = ip1,ip2
          call strns (ip,cp)
          call psddq5
          call psddq6
          call ffdqg
          indff   =  0
          call ffdqgx (indff)
          call rtpack (nsngtp,sngv)
! *** call rtunpk
          write (ntr) (rtrnbf(i),i=1,nrdq)
!
   50 continue
  100 continue
!
      call cstprt ('pppdq   ')
      return
      END subroutine pppdq
! **deck price
      subroutine price (result)
      implicit double precision (a-h,o-z)
      dimension result(128)
      call dcopy (128,  0.d0,0,   result,1)
      return
      END subroutine price
! **deck proj
      subroutine proj(a,b,c)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  project first vector onto plane whose normal is second vector*
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  subtract multiple of second vector from first, where         *
!     *  multiple is determined by requirement that resultant vector  *
!     *  be orthogonal to second vector                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                  *
!     *                                                               *
!     *   alam      -local-   - - - -   scalar multiplier for second  *
!     *                                 vector                        *
!     *                                                               *
!     *   b         argument  input     second vector                 *
!     *                                                               *
!     *   c         argument  output    resultant vector              *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension a(3),b(3),c(3)
      call mxm(b,1,a,3,ab,1)
      call mxm(b,1,b,3,bb,1)
      alam=-ab/bb
      call vadd(a,alam,b,c,3)
      return
      END subroutine proj
! **deck psddq5
      subroutine psddq5
      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 sub-panel spline matrices, local coordinates of   *
!     *  sub-panel corner points, and matrices transforming the       *
!     *  combined potential/velocity vector from local to global      *
!     *  coordinates used for type 5 (quasi-near field) PIC calc'ns   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  construction of the sub-panel source and doublet spline      *
!     *  matrices is described in the engineering document. the  other*
!     *  tasks are straightforward. note that the value of lamda along*
!     *  an edge is defined as twice the value of doublet strength    *
!     *  at the mid-point minus one-half the sum of the two end point *
!     *  values                                                       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   alam      -local-   - - - -   alam(i,j)= value of lamda     *
!     *                                 along jth quarter panel       *
!     *                                 diagonal induced by unit value*
!     *                                 of ith full panel canonical   *
!     *                                 doublet parameter             *
!     *                                                               *
!     *   arp       /pandq/   output    matrices transforming the     *
!     *                                 combined potential/velocity   *
!     *                                 vector from local sub-panel to*
!     *                                 global coordinates            *
!     *                                                               *
!     *   c1        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 first near plane coordinate   *
!     *                                                               *
!     *   c2        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 second near plane coordinate  *
!     *                                                               *
!     *   c3        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 third near plane corrdinate   *
!     *                                                               *
!     *   e         -local-   - - - -   e(i,j)= value of source       *
!     *                                 strength at ith sub-panel     *
!     *                                 vertex induced by unit value  *
!     *                                 of jth taylors series         *
!     *                                 coefficient of full panel     *
!     *                                 source distribution           *
!     *                                                               *
!     *   f         -local-   - - - -   f(i,j),i=1,3 = value of       *
!     *                                 double strength at ith sub-   *
!     *                                 panel vertex induced by       *
!     *                                 unit value of jth full panel  *
!     *                                 canonical doublet parameter   *
!     *                                 f(i,j),i=4,6 =value of (i-3)th*
!     *                                 opposite edge lamda induced by*
!     *                                 unit value of jth full panel  *
!     *                                 canonical doublet parameter   *
!     *                                                               *
!     *   g         -local-   - - - -   g(i,j) = value of ith sub-    *
!     *                                 panel taylors series source   *
!     *                                 coefficient due to unit source*
!     *                                 at jth sub-panel vertex       *
!     *                                                               *
!     *   h         -local-   - - - -   h(i,j),j=1,3 = value of ith   *
!     *                                 sub-panel taylors series      *
!     *                                 doublet coefficient due to    *
!     *                                 unit doublet at jth sub-panel *
!     *                                 vertex                        *
!     *                                 h(i,j),j=4,6 = value of ith   *
!     *                                 sub-panel taylors series      *
!     *                                 doublet coefficient due to    *
!     *                                 (j-3)th opposite edge lamda   *
!     *   qa        /pandq/   output    dependence of coefficients of *
!     *                                 near plane approximate        *
!     *                                 quadratic doublet distribution*
!     *                                 on doublet value at nine      *
!     *                                 canonical panel points        *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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
      common/skrch4/d(10,7),e(3,3),f(6,9),g(3,3),h(6,6)
!
      call qcof(ar(1,5),cp,qa)
      do 940 k=1,2
      is=isqn
      if(k.eq.2) is=mod(is+1,4)+1
      ism1=mod(is+2,4)+1
      isp1=mod(is,4)+1
      isp4=is+4
      ism4=ism1+4
      isp2=mod(is+1,4)+1
      isp5=isp1+4
      ism5=isp2+4
      pk(1,1,k) = 0.d0
      pk(2,1,k) = 0.d0
      pk(3,1,k) = 0.d0
      call unipan (ar(1,is), cp(1,is), cp(1,isp1), pk(1,2,k))
      call unipan (ar(1,is), cp(1,is), cp(1,ism1), pk(1,3,k))
      call tcof(pk(1,1,k),g,h,d)
      e(1,1)  =  1.d0
      e(1,2)  =       p(1,is)
      e(1,3)  =            p(2,is)
!
      e(2,1)  =  1.d0
      e(2,2)  =       .5d0*(p(1,is)+p(1,isp1))
      e(2,3)  =       .5d0*(p(2,is)+p(2,isp1))
!
      e(3,1)  =  1.d0
      e(3,2)  =       .5d0*(p(1,is)+p(1,ism1))
      e(3,3)  =       .5d0*(p(2,is)+p(2,ism1))
      call mxm (g,3,e,3,rk(1,1,k),3)
      do 910 j = 1,3
      do 910 i = 2,3
  910 rk(i,j,k) = 2.d0*rk(i,j,k)
      do 930 i=1,10
      qk(i,is,k)=d(i,1)-.5d0*(d(i,5)+d(i,6))+d(i,4)*rc(is,3)            &
     &+d(i,7)*rc(is,k)
      qk(i,isp1,k) = d(i,2) - .5d0*d(i,6) + d(i,4)*rc(isp1,3)           &
     &                                    + d(i,7)*rc(isp1,k)
      qk(i,ism1,k) = d(i,3) - .5d0*d(i,5) + d(i,4)*rc(ism1,3)           &
     &                                    + d(i,7)*rc(ism1,k)
      qk(i,ism4,k)=2.d0*d(i,5)+d(i,4)*rc(ism4,3)+d(i,7)*rc(ism4,k)
      qk(i,isp4,k)=2.d0*d(i,6)+d(i,4)*rc(isp4,3)+d(i,7)*rc(isp4,k)
      qk(i,9,k)=d(i,4)*rc(9,3)+d(i,7)*rc(9,k)
      qk(i,isp2,k)=d(i,4)*rc(isp2,3)+d(i,7)*rc(isp2,k)
      qk(i,isp5,k)=d(i,4)*rc(isp5,3)+d(i,7)*rc(isp5,k)
      qk(i,ism5,k)=d(i,4)*rc(ism5,3)+d(i,7)*rc(ism5,k)
  930 continue
      if(ics.ne.0) return
  940 continue
      return
      END subroutine psddq5
! **deck psddq6
      subroutine psddq6
      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 sub-panel spline matrices, local coordinates of   *
!     *  sub-panel corner points, and matrices transforming the       *
!     *  combined potential/velocity vector from local to global      *
!     *  coordinates used for type 6 (true-near field) PIC calc'ns    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  construction of the sub-panel source and doublet spline      *
!     *  matrices is described in the engineering document. the  other*
!     *  tasks are straightforward. note that the value of lamda along*
!     *  an edge is defined as twice the value of doublet strength    *
!     *  at the mid-point minus one-half the sum of the two end point *
!     *  values                                                       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   alam      -local-   - - - -   alam(i,j)= value of lamda     *
!     *                                 along jth quarter panel       *
!     *                                 diagonal induced by unit value*
!     *                                 of ith full panel canonical   *
!     *                                 doublet parameter             *
!     *                                                               *
!     *   arp       /pandq/   output    matrices transforming the     *
!     *                                 combined potential/velocity   *
!     *                                 vector from local sub-panel to*
!     *                                 global coordinates            *
!     *                                                               *
!     *   c1        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 first near plane coordinate   *
!     *                                                               *
!     *   c2        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 second near plane coordinate  *
!     *                                                               *
!     *   c3        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 third near plane corrdinate   *
!     *                                                               *
!     *   e         -local-   - - - -   e(i,j)= value of source       *
!     *                                 strength at ith sub-panel     *
!     *                                 vertex induced by unit value  *
!     *                                 of jth taylors series         *
!     *                                 coefficient of full panel     *
!     *                                 source distribution           *
!     *                                                               *
!     *   f         -local-   - - - -   f(i,j),i=1,3 = value of       *
!     *                                 double strength at ith sub-   *
!     *                                 panel vertex induced by       *
!     *                                 unit value of jth full panel  *
!     *                                 canonical doublet parameter   *
!     *                                 f(i,j),i=4,6 =value of (i-3)th*
!     *                                 opposite edge lamda induced by*
!     *                                 unit value of jth full panel  *
!     *                                 canonical doublet parameter   *
!     *                                                               *
!     *   g         -local-   - - - -   g(i,j) = value of ith sub-    *
!     *                                 panel taylors series source   *
!     *                                 coefficient due to unit source*
!     *                                 at jth sub-panel vertex       *
!     *                                                               *
!     *   h         -local-   - - - -   h(i,j),j=1,3 = value of ith   *
!     *                                 sub-panel taylors series      *
!     *                                 doublet coefficient due to    *
!     *                                 unit doublet at jth sub-panel *
!     *                                 vertex                        *
!     *                                 h(i,j),j=4,6 = value of ith   *
!     *                                 sub-panel taylors series      *
!     *                                 doublet coefficient due to    *
!     *                                 (j-3)th opposite edge lamda   *
!     *   qa        /pandq/   output    dependence of coefficients of *
!     *                                 near plane approximate        *
!     *                                 quadratic doublet distribution*
!     *                                 on doublet value at nine      *
!     *                                 canonical panel points        *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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
      common/skrch4/d(10,7),e(3,3),f(6,9),g(3,3),h(6,6)
!
      do 400 ic=1,8
      icp0=mod(ic+3,4)+1
      icp3=mod(ic+2,4)+1
      if((ic.le.4).and.((icp0.eq.ics).or.(icp3.eq.ics))) go to 400
      icp=min (ic,5)
      call subpqr(cp,ar(1,icp),p,alam(1,icp0),pp(1,1,ic),qq(1,1,ic),    &
     &rr(1,1,ic),ic)
  400 continue
!
      return
      END subroutine psddq6
! **deck psddqg
      subroutine psddqg
      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 sub-panel spline matrices, local coordinates of   *
!     *  sub-panel corner points, and matrices transforming the       *
!     *  combined potential/velocity vector from local to global      *
!     *  coordinates                                                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  construction of the sub-panel source and doublet spline      *
!     *  matrices is described in the engineering document. the  other*
!     *  tasks are straightforward. note that the value of lamda along*
!     *  an edge is defined as twice the value of doublet strength    *
!     *  at the mid-point minus one-half the sum of the two end point *
!     *  values                                                       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   alam      -local-   - - - -   alam(i,j)= value of lamda     *
!     *                                 along jth quarter panel       *
!     *                                 diagonal induced by unit value*
!     *                                 of ith full panel canonical   *
!     *                                 doublet parameter             *
!     *                                                               *
!     *   arp       /pandq/   output    matrices transforming the     *
!     *                                 combined potential/velocity   *
!     *                                 vector from local sub-panel to*
!     *                                 global coordinates            *
!     *                                                               *
!     *   c1        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 first near plane coordinate   *
!     *                                                               *
!     *   c2        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 second near plane coordinate  *
!     *                                                               *
!     *   c3        /pandq/   output    quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 third near plane corrdinate   *
!     *                                                               *
!     *   e         -local-   - - - -   e(i,j)= value of source       *
!     *                                 strength at ith sub-panel     *
!     *                                 vertex induced by unit value  *
!     *                                 of jth taylors series         *
!     *                                 coefficient of full panel     *
!     *                                 source distribution           *
!     *                                                               *
!     *   f         -local-   - - - -   f(i,j),i=1,3 = value of       *
!     *                                 double strength at ith sub-   *
!     *                                 panel vertex induced by       *
!     *                                 unit value of jth full panel  *
!     *                                 canonical doublet parameter   *
!     *                                 f(i,j),i=4,6 =value of (i-3)th*
!     *                                 opposite edge lamda induced by*
!     *                                 unit value of jth full panel  *
!     *                                 canonical doublet parameter   *
!     *                                                               *
!     *   g         -local-   - - - -   g(i,j) = value of ith sub-    *
!     *                                 panel taylors series source   *
!     *                                 coefficient due to unit source*
!     *                                 at jth sub-panel vertex       *
!     *                                                               *
!     *   h         -local-   - - - -   h(i,j),j=1,3 = value of ith   *
!     *                                 sub-panel taylors series      *
!     *                                 doublet coefficient due to    *
!     *                                 unit doublet at jth sub-panel *
!     *                                 vertex                        *
!     *                                 h(i,j),j=4,6 = value of ith   *
!     *                                 sub-panel taylors series      *
!     *                                 doublet coefficient due to    *
!     *                                 (j-3)th opposite edge lamda   *
!     *   qa        /pandq/   output    dependence of coefficients of *
!     *                                 near plane approximate        *
!     *                                 quadratic doublet distribution*
!     *                                 on doublet value at nine      *
!     *                                 canonical panel points        *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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
      common/skrch4/d(10,7),e(3,3),f(6,9),g(3,3),h(6,6)
      logical allspl
!
!                                    get true near field data first
      call psddq6
!                                    get intermediate data second
      call psddq5
      return
      END subroutine psddqg
! **deck psintp
      subroutine psintp (nr,m,n,a,d,z,sa)
      implicit double precision (a-h,o-z)
      dimension sa(n)
      dimension a(nr,1),d(1), z(nr,1)
!         *** compute the transpose of the pseudo inverse, given the  **
!         ***  q-r factorization.  no allowance for pivotting is made he
      nm1     =  n-1
!                                  zero out z
      do 100 i = 1,m
      do 100 j = 1,n
  100 z(i,j)  =  0.d0
!              form  r**(-1) (t)  in the lower triangle of z*s upper par
!
!                                  get diagonals of r**(-1)
      do 200 j = 1,n
  200 z(j,j)  =  1.d0/d(j)
!              form  r**(-1) row by row. (its transpose, column by colum
      if ( n.le.1 ) go to 310
      do 300 i = 1,nm1
          ip1     =  i + 1
          do 250 j = ip1,n
!              for k = i,j-1;  sum  uinv(i,k)*u(k,j)
!                                     z(k,i) * a(k,j)
                 s=ddot(j-i,z(i,i),1,a(i,j),1)
               z(j,i)  =  -z(j,j)*s
  250     continue
  300 continue
  310 continue
!
!              apply  h(1) * h(2) * h(3) * ... * h(n)  to  z
      np1     =  n + 1
      do 1000 kbk = 1,n
      k       =  np1 - kbk
!     for k = n step -1 until 1, do
          gm      =  -1.d0/( a(k,k)*d(k) )
      call mxma (z(k,1),nr,1  ,a(k,k),1,m-k+1  ,sa,1,n  ,n,m-k+1,1)
          call vmul (sa,gm,sa,n)
          call hsmmp3 (m-k+1,1,n, a(k,k),1,m-k+1 ,sa,1,1 ,z(k,1),1,nr)
 1000 continue
      return
      END subroutine psintp
! **deck pvcal
      subroutine pvcal (ivzof,zof,pvof,nof,tpval)
      implicit double precision (a-h,o-z)
      dimension ivzof(1)
!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
!ca cinout
!                                                           /cinout/
      common /cinout/ ntsin, ntsout
!end  cinout
!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 rtrnbk
      common /rtrnbk/ cpr(3,4), enr(3,5), diamr, itdm, itsr, icsr, isqnr&
     &              , ipr, kpr, pwr(3), pxr, rfminr, qdltr, rqffr(3,4)  &
     &              , c1r, c2r, c3r, aqr(9), encfr(3)                   &
     &              , sv1r1(3), dv1r1(6), dvzr1(9), amuxr1(3)           &
     &              , sv2r1(3,2), dv2r1(10,2)                           &
     &              , sv8r1(3,8), dv8r1(6,8)                            &
     &              , usvr1(6),  uvmvr1(4,6), amsvr1(3,3), amdvr1(3,3)  &
     &              , sv1r2(3), dv1r2(6), dvzr2(9), amuxr2(3)           &
     &              , sv2r2(3,2), dv2r2(10,2)                           &
     &              , sv8r2(3,8), dv8r2(6,8)                            &
     &              , usvr2(6),  uvmvr2(4,6), amsvr2(3,3), amdvr2(3,3)  &
     &              , sv1r3(3), dv1r3(6), dvzr3(9), amuxr3(3)           &
     &              , sv2r3(3,2), dv2r3(10,2)                           &
     &              , sv8r3(3,8), dv8r3(6,8)                            &
     &              , usvr3(6),  uvmvr3(4,6), amsvr3(3,3), amdvr3(3,3)  &
     &              , sv1r4(3), dv1r4(6), dvzr4(9), amuxr4(3)           &
     &              , sv2r4(3,2), dv2r4(10,2)                           &
     &              , sv8r4(3,8), dv8r4(6,8)                            &
     &              , usvr4(6),  uvmvr4(4,6), amsvr4(3,3), amdvr4(3,3)
      integer rtrnbf(435)
      equivalence (rtrnbf,cpr)
!
!end  rtrnbk
!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 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 slstat
      common /slstat/ tpvcal, tpivv, npicsl(7), npvcal, nphvsl
!end  slstat
!
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!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 rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
      dimension zof(3,nof),pvof(4,nof)
      call zero(pvof,4*nof)
!
!
!
      rewind ntr
      do 800 ipx = 1,npanr
      read (ntr) (rtrnbf(i),i=1,nrdq)
      call rtunpk
      ip      =  ipn
!c
!          call pivv to compute perturbation velocities .
!
      call CPU_TIME (ta)
      do 400 iof=1,nof
          ipc     =  0
          call pivv (ivzof(iof),ipc,zof(1,iof),pvof(1,iof))
  400 continue
      call CPU_TIME (tb)
      tpivv   =  tpivv + tb-ta
  800 continue
      do 900 iof = 1,nof
      if (tpval.ne.0.d0) go to 500
!c
!          convert perterbation velocity to total mass flux or total
!          potential/velocity.
!
      ncon = 1
      call cscal2(betams,pvof(2,iof),ncon)
  500 continue
!c
!          add freestream velocity to get total velocities if tpsl .gt.
!          0, total mass flux if tpsl .le. 0.
!
      ia      =  ivzof(iof)
      do 450 i = 1,3
          pvof(i+1,iof) = pvof(i+1,iof) + fsv(i,ia)
  450 continue
  900 continue
      return
      END subroutine pvcal
! **deck pvinfc
      subroutine pvinfc
      implicit double precision (a-h,o-z)
!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
!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 pblprm
!                                                         /pblprm/
      common /pblprm/ mxcls
!                                                         /pblprm/
!end  pblprm
!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 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 gsqrwi
      parameter (npagpx=400)
      common /gsqrwi/ nsqg, npagp, npngrp(npagpx), nspgrp(npagpx)       &
     &              , ndsgrp, nptgrp(npagpx)
!end  gsqrwi
!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 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
!call bsqrwi
      common /bsqrwi/ nbsqdq, nsqb
!end  bsqrwi
!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 skrch1
      common /skrch1/ w(9000000)
!end  skrch1
      dimension strbuf(1024)
!                                                  ...  mxxcls = 512
      parameter (mxxcls=512)
      dimension indgrp(mxxcls), indsrt(mxxcls), indloc(mxxcls)
      dimension iptgrp(mxxcls), iptsrt(mxxcls), iptloc(mxxcls)
      dimension iipt(4), locpt(4)
      character*10 lunvfg
      logical vfgexs
      dimension iisd(35), locsd(35)
!
      call setcor ('pvinfc')
      lunvfg  =  'fort.45'
      lunvfg  =  'rwms45'
      ndsgrp  =  0
      vfgexs  =  .false.
      rewind nsqg
      rewind nsqb
      npagp   =  0
      npn     =  0
      nsp     =  0
      npt     =  0
      do 1000 knet = 1,nnett
      call setcor ('knetloop')
      ip1     =  npa(knet) + 1
      ip2     =  npa(knet+1)
      mk      =  nm(knet)
      nk      =  nn(knet)
      mfn     =  2*mk-1
      nfn     =  2*nk-1
      mnfn    =  mfn*nfn
      call getcor ('vfg',llvfg,3*mnfn*2)
      if ( ndsgrp.ne.0 ) then
         call readmd (ntvfg,w(llvfg),6*mnfn,knet)
      endif
      do 900 ip = ip1,ip2
          ijpan   =  ip - ip1 + 1
          call mnmod (ijpan,mk-1,ipan,jpan)
          iipt(1) =  nza(knet) + ipan + (jpan-1)*mk
          iipt(2) =  iipt(1) + mk
          iipt(3) =  iipt(2) + 1
          iipt(4) =  iipt(1) + 1
          call strns (ip,cp)
          call icopy (ins,  iis,1,  iisd,1)
          call icopy (ind,  iid,1,  iisd(ins+1),1)
          insd    =  ins + ind
          nspx    =  nsp
          do 100 j = 1,insd
               call srchol (indsrt,nsp,iisd(j),loc)
               if ( loc.eq.0 ) nspx = nspx + 1
  100     continue
          nptx    =  npt
          do 110 j = 1,4
              call srchol (iptsrt,npt,iipt(j),loc)
              if ( loc.eq.0 ) nptx = nptx + 1
  110     continue
          if ( nspx.le.mxcls .and. nptx.le.mxcls ) goto 200
!                                  new panel group
               if ( npagp.ge.npagpx ) CALL AbortPanair('pvinfc')
               npagp   =  npagp + 1
               write (nsqg) (indgrp(i),i=1,nsp)
               write (nsqg) (iptgrp(i),i=1,npt)
!--               call outvci ('indgrp',nsp,indgrp)
!--               call outvci ('indsrt',nsp,indsrt)
!--               call outvci ('indloc',nsp,indloc)
!--               call outvci ('iptgrp',npt,iptgrp)
!--               call outvci ('iptsrt',npt,iptsrt)
!--               call outvci ('iptloc',npt,iptloc)
               npngrp(npagp) = npn
               nspgrp(npagp) = nsp
               nptgrp(npagp) = npt
               npn     =  0
               nsp     =  0
               npt     =  0
  200     continue
          npn     =  npn + 1
          nspz   =  nsp
          do 300 j = 1,insd
               call srchol (indsrt,nspz,iisd(j),loc)
               if ( loc.eq.0 ) go to 250
                    locsd(j)=  indloc(loc)
                    go to 300
!
  250          continue
                    nsp     =  nsp + 1
                    locsd(j)=  nsp
                    indloc(nsp) = nsp
                    indgrp(nsp) = iisd(j)
                    indsrt(nsp) = iisd(j)
                    go to 300
  300     continue
          call sortak (nsp,indsrt,indloc)
          nptz    =  npt
          do 320 j = 1,4
               call srchol (iptsrt,nptz,iipt(j),loc)
               if ( loc.eq.0 ) goto 310
                    locpt(j) = iptloc(loc)
                    goto 320
  310          continue
                    npt     =  npt + 1
                    locpt(j)=  npt
                    iptloc(npt) = npt
                    iptgrp(npt) = iipt(j)
                    iptsrt(npt) = iipt(j)
                    goto 320
  320     continue
          call sortak (npt,iptsrt,iptloc)
          call jzero (iisgp,9)
          call jzero (iidgp,25)
          call jzero (iimuxg,5)
          do 400 j = 1,ins
             call srchol (indsrt,nsp,iis(j),loc)
             if ( loc.eq.0 ) then
                write (6,'('' ipn,kp = '',2i6)') ipn,ip
                call a502ms ('pvinfc','missing group parm (source)')
             endif
             iisf(j) = indloc(loc)
             iisgp(j)= indloc(loc)
  400     continue
          do 420 j = 1,ind
             call srchol (indsrt,nsp,iid(j),loc)
             if ( loc.eq.0 ) then
                write (6,'('' ipn,kp = '',2i6)') ipn,ip
                call a502ms ('pvinfc','missing group parm (doublet)')
             endif
             iidf(j) = indloc(loc)
             iidgp(j)= indloc(loc)
  420     continue
          do 430 j = 1,inmux
             call srchol (indsrt,nsp,iimux(j),loc)
             if ( loc.eq.0 ) then
                write (6,'('' ipn,kp = '',2i6)') ipn,ip
                call a502ms ('pvinfc','missing group parm (mu/x)')
             endif
             iimuxg(j)= indloc(loc)
  430     continue
          if ( inmux.gt.0 ) then
             write (6,'('' astmux info'',i5)') ipn
             call outvci ('iimux',inmux,iimux)
             call outvci ('iimuxg',inmux,iimuxg)
             call outmtx ('astmux',3,3,inmux,astmux)
          endif
          do 440 j = 1,4
               call srchol (iptsrt,npt,iipt(j),loc)
               if ( loc.eq.0 ) then
                  write (6,'(''  ipn,kp = '',2i6)') ipn,ip
                  call a502ms ('pvinfc','missing grp parms, iipt')
               endif
               iiptdn(j) = iipt(j)
               iipgdn(j) = iptloc(loc)
  440     continue
!                                  ======  think about the following ===
          call ffdqg
!                                  suppress the writmd call after c.o.
          if ( ndsgrp.ne.0 ) then
             call dsnpdt (mfn,nfn,w(llvfg),ip,ipan,jpan)
!---             call panpwm (ics,cp  ,en,ar,aj,wsdn
!---     x                   ,wcdn,wcsdn,acdn,acsdn
!---     x                   ,qd)
!---             call writmd (ntdsn,wsdn,ndqdsn,ip,  -1,0)
          endif
          call dcopy (nbsqdq,  cp,1,  strbuf,1)
          write (nsqb) (strbuf(i),i=1,nbsqdq)
          if ( ndsgrp.ne.0 ) then
             write (nsqb) wpdn, wsdn, iiptdn, iipgdn
             if ( ip.le.1 ) then
                write (6,'('' for panel ip:'',4i6)') ip,ipan,jpan,knet
                call outvci ('iiptdn',4,iiptdn)
                call outvci ('iipgdn',4,iipgdn)
                call outmvc ('wsdn',3,3,8,wsdn)
                call outmat ('wpdn',3,3,9,wpdn)
                call exwsdn (cp,wsdn)
                call outmvc ('wsdn-exact',3,3,8,wsdn)
             endif
          endif
  900 continue
      call frecor ('knetloop')
 1000 continue
!
      if ( npn.eq.0 ) go to 1100
      if ( nsp.eq.0 .and. npt.eq.0 ) goto 1100
          npagp   =  npagp + 1
          write (nsqg) (indgrp(i),i=1,nsp)
          write (nsqg) (iptgrp(i),i=1,npt)
!--          call outvci ('indgrp',nsp,indgrp)
!--          call outvci ('indsrt',nsp,indsrt)
!--          call outvci ('indloc',nsp,indloc)
!--          call outvci ('iptgrp',npt,iptgrp)
!--          call outvci ('iptsrt',npt,iptsrt)
!--          call outvci ('iptloc',npt,iptloc)
          npngrp(npagp) =  npn
          nspgrp(npagp) =  nsp
          nptgrp(npagp) =  npt
 1100 continue
      call outvci ('npngrp',npagp,npngrp)
      call outvci ('nspgrp',npagp,nspgrp)
      call outvci ('nptgrp',npagp,nptgrp)
      if ( ndsgrp.ne.0 ) then
         call remarx ('closing unit ntvfg')
         call closms (ntvfg)
!---         call remarx ('closing unit ntdsn')
!---         call closms (ntdsn)
      endif
      call frecor ('pvinfc')
      return
      END subroutine pvinfc
! **deck qcof
      subroutine qcof(ar,cp,q)
      implicit double precision (a-h,o-z)
      double precision kses,kset,ksest
      dimension z(3,3),c(6,6),ar(3,3),cp(3,9),q(6,9),pc(3,3)
      do 100 l=1,3
      pc(l,1)=.25d0*(cp(l,1)-cp(l,2)-cp(l,3)+cp(l,4))
      pc(l,2)=.25d0*(cp(l,1)+cp(l,2)-cp(l,3)-cp(l,4))
      pc(l,3)=.25d0*(cp(l,1)-cp(l,2)+cp(l,3)-cp(l,4))
  100 continue
      call mxm (ar,3,pc,3,z,3)
      call zero(c,36)
      kses=z(1,1)
      etas=z(2,1)
      kset=z(1,2)
      etat=z(2,2)
      ksest=z(1,3)
      etast=z(2,3)
      al0=1.d0/(kses*etat-kset*etas)
      al0s=al0*al0
      deta=al0*(2.d0*etas*etat*ksest-(etat*kses+etas*kset)*etast)
      dkse=-al0*(2.d0*kses*kset*etast-(etat*kses+etas*kset)*ksest)
      c(1,1)=1.d0
      c(2,2)=al0*etat
      c(2,3)=-al0*etas
      c(3,2)=-al0*kset
      c(3,3)=al0*kses
      c(4,2)=al0s*etat*(etast+deta)
      c(4,3)=al0s*etas*(etast-deta)
      c(4,4)=al0s*etat*etat
      c(4,5)=-2.d0*al0s*etas*etat
      c(4,6)=al0s*etas*etas
      c(5,2)=-al0s*(kset*etast+etat*dkse)
      c(5,3)=-al0s*(etas*ksest-kses*deta)
      c(5,4)=-al0s*kset*etat
      c(5,5)=al0s*(kset*etas+etat*kses)
      c(5,6)=-al0s*kses*etas
      c(6,2)=al0s*kset*(ksest+dkse)
      c(6,3)=al0s*kses*(ksest-dkse)
      c(6,4)=al0s*kset*kset
      c(6,5)=-2.d0*al0s*kses*kset
      c(6,6)=al0s*kses*kses
      do 700 k=1,6
      q(k,1)=.25d0*c(k,5)
      q(k,2)=-.25d0*c(k,5)
      q(k,3)=.25d0*c(k,5)
      q(k,4)=-.25d0*c(k,5)
      q(k,5)=.5d0*c(k,3)+c(k,6)
      q(k,6)=-.5d0*c(k,2)+c(k,4)
      q(k,7)=-.5d0*c(k,3)+c(k,6)
      q(k,8)=.5d0*c(k,2)+c(k,4)
      q(k,9)=c(k,1)-2.d0*c(k,4)-2.d0*c(k,6)
  700 continue
      return
      END subroutine qcof
! **deck qffcal
      subroutine qffcal (z,ne,nf,dvs,dvd)
      implicit double precision (a-h,o-z)
!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 norx
!                                                            /norx/
      common /norx/ sgnx, diamx
!end  norx
!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 dsnpic
      common /dsnicr/ phsdsn(6), vsdsn(3,6), phxdsn(3,4), phydsn(3,4)
      common /dsnicl/ dsnic
      logical dsnic
!end  dsnpic
!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
      dimension dvs(ne,3),dvd(ne,9)
! --- real*8    dvs,dvd
      dimension  w(3), xx(3), z(3)
      dimension dvsp(24), dvdp(40)
! --- real*8    dvsp, dvdp
      logical  ponq
!
!
!
      ponq    =  .false.
      netp    =  ne*ityprc
      irf=rf
      sgnx=sgxf
      diamx   =  diamf
!
      nex = ne
      nfx = nf
      itsx= itsf
      if ( dsnic ) then
         nex     =  max(ne,1)
         nfx     =  max(nf,6)
! ------ nex     =  4                ; phxdsn
! ------ nfx     =  10               ; phxdsn
         if ( mod(itsx,2).eq.0 ) itsx = itsx+1
      endif
!
      w(1)    =  z(1) - cpfz(1)
      w(2)    =  z(2) - cpfz(2)
      w(3)    =  z(3) - cpfz(3)
      xx(1)   =  af(1)*w(1) + af(4)*w(2) + af(7)*w(3)
      xx(2)   =  af(2)*w(1) + af(5)*w(2) + af(8)*w(3)
      xx(3)   =  af(3)*w(1) + af(6)*w(2) + af(9)*w(3)
      ajc     =  ajf
!
      call nftpic (amach,irf,ajc,af,pf,icsf,nsff,itsx,xx,nex,nfx        &
     &            ,dvsp,dvdp)
      ng      =  3
      if ( nf.ge.10 ) ng = 6
!
      if ( ne.eq.nex ) goto 200
      if ( .not. ( ne.eq.1 .and. nex.eq.4 ) ) call a502er ('qffcal'     &
     &  ,'ne and nex are all screwed up')
!                                   store source coefficients
      if ( itsf.ne.2 ) call dcopy (ng,  dvsp,nex,  dvs,ne)
!                                   store doublet coefficients
      if ( itsf.ge.2 ) call dcopy (nf,  dvdp,nex,  dvd,ne)
      goto 300
!                                   ne = nex, do block copy
  200 continue
      call dcopy (netp*ng,  dvsp,1,  dvs,1)
      call dcopy (netp*nf,  dvdp,1,  dvd,1)
!
  300 continue
      if ( .not.dsnic ) goto 950
!                                   dsnic set, save phsdsn, vsdsn
      call dcopy (3,  dvsp,nex,  phsdsn,1)
! --- call mcopy (3,6,  dvsp(2),1,4,  vsdsn,1,3)  ; phxdsn
!
  950 continue
      return
      END subroutine qffcal
! **deck qnfcal
      subroutine qnfcal(z,iflun,ksymm,ne,dvs,dvd)
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to calculate intermediate field panel influence coefficients *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the one sub-panel intermediate field caculations (employed   *
!     *  when the far field ratio is sufficiently small) are performed*
!     *  after statement 500. the two sub-panel intermediate field    *
!     *  calculations are performed between statement 75 and statement*
!     *  450. these calculations are employed when the far field ratio*
!     *  is sufficiently small, but somewhat larger than for the one  *
!     *  sub-panel case. they may also be empolyed when the far field *
!     *  ratio is so large that a near field calculation is apparently*
!     *  required, yet the control point lies a moderate distance     *
!     *  away from the panel surface. the code prior to statement 75  *
!     *  tests for such a possibility.                                *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   aj        argument  input     sub-panel  area jacobian      *
!     *                                 (ratio of area element in     *
!     *                                 global coordinates to area    *
!     *                                 element in local sub-panel    *
!     *                                 coordinates)                  *
!     *                                                               *
!     *   amach     /acase/   input     freestream mach number        *
!     *                                                               *
!     *   aq        /pandq/   input     transformation matrix from    *
!     *                                 global to near plane          *
!     *                                 coordinate system             *
!     *                                                               *
!     *   ar        /pandq/   input     transformation from global to *
!     *                                 local sub-panel coordinates   *
!     *                                                               *
!     *   arp       /pandq/   input     matrices transforming the     *
!     *                                 combined potential/velocity   *
!     *                                 vector from local sub-panel to*
!     *                                 global coordinates            *
!     *                                                               *
!     *   betams    /comprs/  input     1.-(freestream mach number)**2*
!     *                                                               *
!     *   compd     /comprs/  input     compressibility direction     *
!     *                                 vector                        *
!     *                                                               *
!     *   cp        /pandq/   input     nine canonical panel points   *
!     *                                 (includes corner points,edge  *
!     *                                 midpoints and center)         *
!     *                                                               *
!     *   c1        /pandq/   input     quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 first near plane coordinate   *
!     *                                                               *
!     *   c2        /pandq/   input     quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 second near plane coordinate  *
!     *                                                               *
!     *   c3        /pandq/   input     quadrilateral skewness param- *
!     *                                 eter corresponding to the     *
!     *                                 third near plane corrdinate   *
!     *                                                               *
!     *   dvd       argument  output    influence of nine canonical   *
!     *                                 panel doublet values on       *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvdp      /skrch3/  -local-   influence of sub-panel taylors*
!     *                                 series doublet coefficients on*
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvs       argument  output    influence of taylors series   *
!     *                                 source coefficients on        *
!     *                                 potential (and possibly global*
!     *                                 components of velocity) at    *
!     *                                 field point                   *
!     *                                                               *
!     *   dvsp      /skrch3/  -local-   influence of sub-panel taylors*
!     *                                 series source coefficients on *
!     *                                 potential (and possibly global*
!     *                                 coordinates of velocity) at   *
!     *                                 field point                   *
!     *                                                               *
!     *   ics       /pandq/   input     =0 - panel is quadrilateral   *
!     *                                 =1 thru 4 - panel is triangle *
!     *                                     because edge ics is       *
!     *                                    collapsed                  *
!     *                                                               *
!     *   iflun     argument  input     influence indicator           *
!     *                                 =0   no influence             *
!     *                                 =1   monopole far field       *
!     *                                 =2   dipole  far field        *
!     *                                 =3   quadrupole far field     *
!     *                                 =4   one sub-panel inter-     *
!     *                                      mediate field            *
!     *                                 =5   two sub-panel inter-     *
!     *                                      mediate field            *
!     *                                 =6   eight sub-panel near     *
!     *                                      field                    *
!     *                                                               *
!     *   iin       /pandq/   input     sub-panel inclination         *
!     *                                 flag                          *
!     *                                      =+1  subinclined         *
!     *                                      =-1  superinclined       *
!     *                                                               *
!     *   ipc       /cntrq/   input     index of panel on which       *
!     *                                 control point zc lies         *
!     *                                                               *
!     *   ipn       /pandq/   input     index of panel whose defining *
!     *                                 quantities are currently in   *
!     *                                 common block /pandq/          *
!     *                                                               *
!     *   its       /pandq/   input     panel singularity type        *
!     *                                 =1 source alone               *
!     *                                 =2 doublet alone              *
!     *                                 =3 source and doublet         *
!     *                                                               *
!     *   jcn       /cntrq/   input     overall index of control point*
!     *                                 whose defining quantities are *
!     *                                 currently in common block     *
!     *                                 /cntrq/                       *
!     *                                                               *
!     *   ksymm     argument  input     plane of symmetry parameter   *
!     *                                 =1   original control point   *
!     *                                 =1 thru 4  reflected control  *
!     *                                      point                    *
!     *                                                               *
!     *   ncd       /pandq/   input     number of parameters (i.e.    *
!     *                                 quadratic coefficients)       *
!     *                                 defining panel doublet        *
!     *                                 distribution                  *
!     *                                                               *
!     *   ncs       /pandq/   input     number of parameters (i.e.    *
!     *                                 linear coefficients) defining *
!     *                                 panel source distribution     *
!     *                                                               *
!     *   ne        argument  input     number of components of       *
!     *                                 combined potential/velocity   *
!     *                                 coefficients desired          *
!     *                                                               *
!     *   nf        -local-   - - - -   number of taylors series      *
!     *                                 coefficients in sub-panel     *
!     *                                 doublet distribution          *
!     *                                                               *
!     *   p         /pandq/   input     coordinates of four panel     *
!     *                                 corner points in local central*
!     *                                 sub-panel coordinate system   *
!     *                                                               *
!     *   pp        /pandq/   input     coordinates of sub-panel      *
!     *                                 vertices in repective sub-    *
!     *                                 panel coordinate systems      *
!     *                                                               *
!     *   ps        /skrch3/  -local-   sub-panel vertices in local   *
!     *                                 coordinates                   *
!     *                                                               *
!     *   qa        /pandq/   input     dependence of coefficients of *
!     *                                 near plane approximate        *
!     *                                 quadratic doublet distribution*
!     *                                 on doublet value at nine      *
!     *                                 canonical panel points        *
!     *                                                               *
!     *   qi        /qnfq/    input     dependence of coefficients of *
!     *                                 two sub-panel approximate     *
!     *                                 cubic doublet distribution    *
!     *                                 on doublet value at nine      *
!     *                                 canonical panel points        *
!     *                                                               *
!     *   qq        /pandq/   input     transformation from doublet   *
!     *                                 values at nine canonical panel*
!     *                                 points to quadratic taylor    *
!     *                                 coefficients in local         *
!     *                                 sub-panel coordinate systems  *
!     *                                                               *
!     *   rr        /pandq/   input     matrix describing the         *
!     *                                 dependence of each sub-panel  *
!     *                                 linear source coefficients    *
!     *                                 on the overall panel linear   *
!     *                                 linear source coefficients    *
!     *                                                               *
!     *   sgnx      /norx/    output    superinclined panel           *
      implicit double precision (a-h,o-z)
!     *                                 orientation parameter         *
!     *                                                               *
!     *   xx        /skrch3/  -local-   local coordinates of control  *
!     *                                 point                         *
!     *                                                               *
!     *   zc        /cntrq/   input     control point position in     *
!     *                                 global coordinates            *
!     *                                                               *
!     *   zp        /skrch3/  -local-   global coordinates of vector  *
!     *                                 from control point to panel   *
!     *                                 corner point                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 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 norx
!                                                            /norx/
      common /norx/ sgnx, diamx
!end  norx
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
      dimension w(3), xx(3), zp(3), ps(3,3)
      dimension dvsp(24), dvdp(40)
! --- real*8  dvsp, dvdp
      dimension z(3)
      dimension   dvs(ne,3),dvd(ne,9)
! --- real*8   dvs,dvd
      logical ponq
!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
      data delta /1.44d0/
      data icsp /4/
!c
!     *  an intermediate field calculation cannot be used when the    *
!     *  control point lies on the panel                              *
!
      if((ksymm.eq.1).and.(ipn.eq.ipc)) go to 950
      ponq    =  .false.
      diamx   =  diam
      netp    =  ne*ityprc
!c
!     *  employ one sub-panel intermediate field calculation if the   *
!     *  far field ratio is sufficiently small                        *
!     *                                                               *
!c
!     *  employ two sub-panel intermediate field calculation if the   *
!     *  far field ratio is sufficiently small                        *
!
      if(iflun.eq.5) go to 75
!c
!     *  test alternate criterion for using two sub-panel intermediate*
!     *  field instead of near field calculations                     *
!
      testm=delta*((1.d0+abs(c1))**2+(1.d0+abs(c2))**2+c3**2)
      w(1)    =  z(1) - cp(1,9)
      w(2)    =  z(2) - cp(2,9)
      w(3)    =  z(3) - cp(3,9)
      xx(1)   =  aq(1)*w(1) + aq(4)*w(2) + aq(7)*w(3)
      xx(2)   =  aq(2)*w(1) + aq(5)*w(2) + aq(8)*w(3)
      xx(3)   =  aq(3)*w(1) + aq(6)*w(2) + aq(9)*w(3)
      test=xx(1)**2+xx(2)**2+xx(3)**2
      if(test.lt.testm) go to 950
   75 continue
!c
!     *  two sub-panel intermediate field calculations                *
!
!c
!     *  initialize source and doublet panel influence coefficient    *
!     *  arrays                                                       *
!
      if (its.gt.1) call zero (dvd,netp*ncd)
      if (its.ne.2) call zero (dvs,netp*ncs)
!c
!     *  decide which pair of sub-panels to use for two sub-panel     *
!     *  intermediate field calculations                              *
!
!c
!     *  if panel is triangle choose appropriate sub-panel            *
!
      is=isqn
!c
!     *  cycle over pair of sub-panels to accumulate influences       *
!
      test=0.d0
      testm=.01d0
      do 400 k=1,2
      if(k.eq.2) is=mod(is+1,4)+1
!c
!     *  compute local coordinates of sub-panel vertices              *
!
!c
!     *  calculate local coordinates of control point                 *
!
      w(1)    =  z(1) - cp(1,is)
      w(2)    =  z(2) - cp(2,is)
      w(3)    =  z(3) - cp(3,is)
      xx(1)   =  ar(1,is)*w(1) + ar(4,is)*w(2) + ar(7,is)*w(3)
      xx(2)   =  ar(2,is)*w(1) + ar(5,is)*w(2) + ar(8,is)*w(3)
      xx(3)   =  ar(3,is)*w(1) + ar(6,is)*w(2) + ar(9,is)*w(3)
!c
!     *  calculate superinclined panel orientation parameter          *
!
      sgnx=sgx(is)
      nf=10
!c
!     *  call appropriate sub-panel influence coefficient calculation *
!     *  routine                                                      *
!
      ns      =  4
      call nftpic(amach,iin(is),aj(is),ar(1,is),pk(1,1,k)               &
     &              ,icsp,ns,its,xx,ne,nf,dvsp,dvdp)
      if(its.gt.1) test=test+abs(dvdp(1))
!c
!     *  post-multiply doublet coefficients by appropriate sub-panel  *
!     *  doublet spline matrix                                        *
!
      if ( its.gt.1 )                                                   &
     & call hsmmp2 (9,nf,netp, qk(1,1,k),nf,1, dvdp,netp,1, dvd,netp,1)
!c
!     *  post-multiply source coefficients by  appropriate sub-panel  *
!     *  source spline matrix                                         *
!
      if ( its.ne.2 )                                                   &
     & call hsmmp2 (3,3,netp,  rk(1,1,k),3,1,  dvsp,netp,1, dvs,netp,1)
      if(ics.ne.0) go to 450
  400 continue
  450 continue
!c
!     *  reset influence indicator to reflect calculation just        *
!     *  completed                                                    *
!
      iflun=5
      if((amach.gt.1.d0).and.(test.gt.testm)) iflun=6
  950 return
      END subroutine qnfcal
! **deck qtewic
      subroutine qtewic (ltewic)
      implicit double precision (a-h,o-z)
      logical ltewic
!
!         determine if the panel described by /pandf/ is a trailing edge
!         panel of a network for which downstream ic's have been request
!         to qualify, a network must be marked (cf. idsvfw(knet)) as hav
!         wake filaments, and the current panel (cf. ipf, /pandf/) must
!         lie on edge 3 of the network, the trailing edge.
!
!         ltewic  o   lgc   set equal to true if downstream wake influen
!                           coefficients are required, otherwise false.
!
!         other input:
!         idsvfw(knet) /lndblx/ int  nonzero if nw knet has wake filamen
!                                    attached
!
!         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 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
!                                  /lndblx/
!                                       idsvfw(knet) # 0 for wake nw's t
!                                       have very-far-wake filaments att
!                                       to edge 3.
!call lndblx
!                                                           /lndblx/
      common /lndblx/ genwak(3,mxnett), slndbl(mxnett)                  &
     &              , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett)
!end  lndblx
!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
!                                  check if very-far-wake downstream ic'
!                                  have been requested for this network
      ltewic  =  .false.
      if ( idsvfw(kpf).eq.0 ) goto 950
!                                  get panel row/column, ipan/jpan, and
!                                  check for last panel row (nm(kpf)-1)
      ipk     =  ipnf - npa(kpf)
      call mnmod (ipk,nm(kpf)-1,ipan,jpan)
      if ( ipan.eq.(nm(kpf)-1) ) ltewic = .true.
      if ( icsf.eq.3 ) ltewic = .false.
!
  950 continue
      return
      END subroutine qtewic
! **deck quadnt
      subroutine quadnt(kn,nrow,ncol)
      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 network of mesh points for a quadrilateral
!              with the given four corner points
!
!     input    calling sequence
!              kn - network no.
!              nrow - number of rows
!              ncol - number of columns
!              common block
!              /index/ - nza,
!
!     output   common block
!              /mspnts/ - zm
!
!     discussion  using the given four corner points and percent values
!              for divisions along row and column, the routine applies
!              a bilinear transformation from a square to a quadrilater-
!              al to generate the required network mesh points.  if the
!              z coordinate for any of the given four corner points is
!              not zero, a simple slant wing will be set up using linear
!              interpolation.
!******
!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 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 mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!
!                             obtain x and y coordinates of the given
!                             four corner points
      x1 = sc(1,1)
      x2 = sc(1,2)
      x3 = sc(1,3)
      x4 = sc(1,4)
      y1 = sc(2,1)
      y2 = sc(2,2)
      y3 = sc(2,3)
      y4 = sc(2,4)
!
!                             apply a bilinear transformation from a
!                             square to a quadrilateral to generate the
!                             required network mesh points using percent
!                             values xpc and ypc for divisions along row
!                             and column
      k = nza(kn) + 1
      nzm = 3*nrow*ncol
      call zero(zm(1,k),nzm)
      do 20 j=1,ncol
      eps = xpc(j)
      ceps = 1.d0 - eps
      do 10 i=1,nrow
      eta = ypc(i)
      ceta = 1.d0 - eta
      ea = ceps*ceta
      eb = eps*ceta
      ec = eps*eta
      ed = ceps*eta
      zm(1,k) = x1*ea + x2*eb + x3*ec + x4*ed
      zm(2,k) = y1*ea + y2*eb + y3*ec + y4*ed
   10 k = k + 1
   20 continue
!
!                             obtain z coordinates of the given four
!                             corner points and check if any of them is
!                             not zero
      z1 = sc(3,1)
      z2 = sc(3,2)
      z3 = sc(3,3)
      z4 = sc(3,4)
      do 25 j=1,4
      if(sc(3,j).ne.0.d0)  go to 27
   25 continue
      go to 50
!
!                             generate z coordinates for a slant wing
!                             network mesh points using linear interpola
!                             -tion
   27 continue
      zas = z2 - z1
      zbs = z3 - z4
      da = sqrt((x2-x1)**2 + (y2-y1)**2)
      db = sqrt((x3-x4)**2 + (y3-y4)**2)
      zda = 0.d0
      if(da.ne.0.d0)  zda = zas/da
      zdb = 0.d0
      if(db.ne.0.d0)  zdb = zbs/db
      nrm1 = nrow - 1
      k = nza(kn) + 1
      do 40 j=1,ncol
      xa = zm(1,k)
      ya = zm(2,k)
      dr = sqrt((xa-x1)**2 + (ya-y1)**2)
      za = z1 + dr*zda
      xb = zm(1,k+nrm1)
      yb = zm(2,k+nrm1)
      ds = sqrt((xb-x4)**2 + (yb-y4)**2)
      zb = z4 + ds*zdb
      dd = sqrt((xb-xa)**2 + (yb-ya)**2)
      zz = zb - za
      zd = 0.d0
      if(dd.ne.0.d0)  zd = zz/dd
      do 30 i=1,nrow
      xc = zm(1,k)
      yc = zm(2,k)
      dt = sqrt((xc-xa)**2 + (yc-ya)**2)
      zm(3,k) = za + dt*zd
   30 k = k + 1
   40 continue
   50 continue
      return
      END subroutine quadnt
! **deck qudlxl
      subroutine qudlxl (a,b, q)
      implicit double precision (a-h,o-z)
      dimension a(3), b(3), q(6)
!
!     given  A = [1, x, y] * a;  B = [1, x, y] * b; form q such that
!     Q = A*B =  [1, x, y, x*x/2, x*y, y*y/2] * q
!
      q(1)    =  a(1)*b(1)
      q(2)    =  a(1)*b(2) + a(2)*b(1)
      q(3)    =  a(1)*b(3) + a(3)*b(1)
      q(4)    =  2.d0*a(2)*b(2)
      q(5)    =  a(2)*b(3) + a(3)*b(2)
      q(6)    =  2.d0*a(3)*b(3)
!
      return
      END subroutine qudlxl
! **deck quikck
      subroutine quikck(p1,p2,p3,q1,q2,q3,   intf)
      implicit double precision (a-h,o-z)
!
!     purpose: do a quick check to eliminate impossible intersections
!
!     inputs:  p1,p2,p3 points of first triangle
!              q1,q2,q3 points of second triangle
!
!     outputs: intf     flag to indicate if intersection is possible
!
      dimension p1(3),p2(3),p3(3)
      dimension q1(3),q2(3),q3(3)
      dimension a(3) ,b(3)
      logical   intf
!
!     initialize the intersection flag, intf, to .false. where,
!       intf = .true.    means intersection can occur
!       intf = .false.   means no intersection can occur
!
      intf = .false.
!
!     compute the average point, a, of first triangle p
!
      a(1) = (   p1(1) + p2(1) + p3(1)   )/3.d0
      a(2) = (   p1(2) + p2(2) + p3(2)   )/3.d0
      a(3) = (   p1(3) + p2(3) + p3(3)   )/3.d0
!
!     compute the average point, b, of second triangle q
!
      b(1) = (   q1(1) + q2(1) + q3(1)   )/3.d0
      b(2) = (   q1(2) + q2(2) + q3(2)   )/3.d0
      b(3) = (   q1(3) + q2(3) + q3(3)   )/3.d0
!
!     compute the radius of a sphere around each triangle
!
      p1d = sqrt  ((p1(1)-a(1))**2 + (p1(2)-a(2))**2 + (p1(3)-a(3))**2)
      p2d = sqrt  ((p2(1)-a(1))**2 + (p2(2)-a(2))**2 + (p2(3)-a(3))**2)
      p3d = sqrt  ((p3(1)-a(1))**2 + (p3(2)-a(2))**2 + (p3(3)-a(3))**2)
      r1  =  max  ( p1d, p2d, p3d)
!
      q1d = sqrt  ((q1(1)-b(1))**2 + (q1(2)-b(2))**2 + (q1(3)-b(3))**2)
      q2d = sqrt  ((q2(1)-b(1))**2 + (q2(2)-b(2))**2 + (q2(3)-b(3))**2)
      q3d = sqrt  ((q3(1)-b(1))**2 + (q3(2)-b(2))**2 + (q3(3)-b(3))**2)
      r2  =  max  ( q1d, q2d, q3d)
!
!     compute the distance between the average points of each triangle
!
      avgd = sqrt ((b(1)-a(1))**2 + (b(2)-a(2))**2 + (b(3)-a(3))**2)
!
!     if 'r1' plus 'r2' is greater than or equal to 'avgd'
!     intersection is possible, so set intf to .true.
!
      if ( ( r1 + r2 ) .ge. avgd )  intf = .true.
!
      return
      END subroutine quikck
! **deck rcmmp1
      subroutine rcmmp1 (m,l,n,  a,ia,ja,  b,ib,jb,  c,ic,jc)
      implicit double precision (a-h,o-z)
      dimension a(1), b(2), c(2)
!
!         form the product:  a[real] x b[complex] = c[complex]
!         with the usual conventions for strides
!
!                                  form:  re.c = a * re.b
      call hsmmp1 (m,l,n,  a,ia,ja,  b(1),2*ib,2*jb,  c(1),2*ic,2*jc)
!                                  form:  im.c = a * im.b
      call hsmmp1 (m,l,n,  a,ia,ja,  b(2),2*ib,2*jb,  c(2),2*ic,2*jc)
!
      return
      END subroutine rcmmp1
! **deck readmd
      subroutine readmd (lun,ia,n,irec)
      dimension ia(n)
!ca locinf
!                                                         /locinf/
      common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i
      double precision rlocdm
!end  locinf
!
!         read a ms record of double words
!
      call readms (lun,ia,n*kklr2i,irec)
      return
      END subroutine readmd
! **deck readms
      subroutine readms (lun,a,na,irec)
      dimension a(na)
!
!         read a fake readms/writms record
!
!call dictms
      common /dictms/ nrecmx(100), llindx(100), ndirwr(100)             &
     &              , rwmstr                                            &
     &              , lldict, lldmax, indxms(2,800000)                   &
     &              , buffms(512)
      integer buffms
      logical  rwmstr
!end  dictms
!
      if ( na.le.0 ) return
      nbk     =  (na+511)/512
      lliudx  =  llindx(lun)
      if ( indxms(1,lliudx+irec).eq.0  .or.  rwmstr ) then
      write (6,6000) lun,irec,na,nbk,indxms(1,lliudx+irec)
 6000 format (' readms: lun,rec,lth',3i6,'  nbk,iudx',2i8)
      endif
      if ( indxms(1,lliudx+irec).eq.0 ) call exitms (lun                  &
     &    ,'record missing from readms/writms file')
      call upkims (lblock,nbkold,indxms(1,lliudx+irec))
      if ( nbk.gt.nbkold  .or.  rwmstr ) then
      write (6,6001) lun,irec,na,nbk,nbkold,lblock
 6001 format (' readms: unit,rec,lth:',3i6,'  nbk,nbkold,lblock',3i6)
      endif
      if ( nbk.gt.nbkold ) call exitms (lun                             &
     &   ,'readms: attempt to read more data than is there')
      do 100 k = 1,nbk
          jrec   =  k + lblock
          la     =  1 + (k-1)*512
          nw     =  512
          if ( k.eq.nbk ) nw = na - (nbk-1)*512
          read (lun,rec=jrec) buffms
          call icopy (nw,  buffms,1,  a(la),1)
  100 continue
      return
      END subroutine readms
! **deck refloc
      subroutine refloc  (en,sfac,gen,  a,jac,rpntyp,  ai)
      implicit double precision (a-h,o-z)
      dimension gen(3), gp(3)
      dimension  en(3), a(3,3)
      double precision jac
      dimension  ai(3,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
      dimension gg(3,3), ggit(3,3)
      equivalence (gg,ggcp), (ggit,ggcpit)
!
      dimension  enb(3), aa(3,3)
      dimension bz(3,3), ba(3,3), aba(3,3), aia(3,3), ag(3)
      data ncall /0/, nerr/0/
      ncall = ncall + 1
!
      enb(1)  =  ggit(1,1)*en(1) + ggit(1,2)*en(2) + ggit(1,3)*en(3)
      enb(2)  =  ggit(2,1)*en(1) + ggit(2,2)*en(2) + ggit(2,3)*en(3)
      enb(3)  =  ggit(3,1)*en(1) + ggit(3,2)*en(2) + ggit(3,3)*en(3)
!
      afsq    =  enb(2)**2 + enb(3)**2
      gmsq    =  sfac*enb(1)**2 + afsq
      rpntyp  =  sign(1.d0,gmsq)
      cosa    =  0.d0
      sina    =  1.d0
      gm      =  sqrt(abs(gmsq))
      af      =  sqrt(afsq)
      if ( gmsq.eq.0.d0 ) go to 1000
      if ( afsq.eq.0.d0 ) go to 10
!
          afi     =  1.d0/af
          cosa    =  afi * enb(3)
          sina    =  afi * enb(2)
!
   10 continue
      gmi     =  1.d0/gm
      afgmi   =  af*gmi
      en1gmi  =  enb(1)*gmi
!
      aa(1,1) =  afgmi
      aa(1,2) =         -sfac*en1gmi*sina
      aa(1,3) =                   -sfac*en1gmi*cosa
!
!     aa(2,1)   =  0.
      aa(2,2) =          rpntyp*cosa
      aa(2,3) =                   -rpntyp*sina
!
      aa(3,1) =  en1gmi
      aa(3,2) =          afgmi*sina
      aa(3,3) =                    afgmi*cosa
!
      jac     =  gmi*btsqi
!
      do 200 j = 1,3
          a(1,j)  =  aa(1,1)*gg(1,j) + aa(1,2)*gg(2,j) + aa(1,3)*gg(3,j)
          a(2,j)  =                    aa(2,2)*gg(2,j) + aa(2,3)*gg(3,j)
          a(3,j)  =  aa(3,1)*gg(1,j) + aa(3,2)*gg(2,j) + aa(3,3)*gg(3,j)
  200 continue
!                                  compute inverse
      rs      =  rpntyp*sfac
!
      aa(1,1) =  rpntyp * aa(1,1)
      aa(3,2) =  rpntyp * aa(3,2)
      aa(3,3) =  rpntyp * aa(3,3)
!
      aa(1,2) =  rs * aa(1,2)
      aa(1,3) =  rs * aa(1,3)
      aa(3,1) =  rs * aa(3,1)
!
      do 300 j = 1,3
          ai(j,1)=aa(1,1)*ggit(1,j)+aa(1,2)*ggit(2,j)+aa(1,3)*ggit(3,j)
          ai(j,2)=                  aa(2,2)*ggit(2,j)+aa(2,3)*ggit(3,j)
          ai(j,3)=aa(3,1)*ggit(1,j)+aa(3,2)*ggit(2,j)+aa(3,3)*ggit(3,j)
  300 continue
      if ( amach.gt.1.d0 ) goto 950
!                                  apply a final rotation so
!                                  that gen, expressed in local
!                                  coordinates, is parallel to
!                                  the x-axis
      gp(1)  =  a(1,1)*gen(1) + a(1,2)*gen(2) + a(1,3)*gen(3)
      gp(2)  =  a(2,1)*gen(1) + a(2,2)*gen(2) + a(2,3)*gen(3)
      gp(3)  =  a(3,1)*gen(1) + a(3,2)*gen(2) + a(3,3)*gen(3)
!                                  choose c,s such that
!                                  -s*gp(1)+c*gp(2) = 0
      gpi    =  1.d0/sqrt( gp(1)**2 + gp(2)**2 )
      cosr   =  gp(1)*gpi
      sinr   =  gp(2)*gpi
!
      do 400 j = 1,3
          t      =  cosr*a(1,j) + sinr*a(2,j)
          a(2,j) = -sinr*a(1,j) + cosr*a(2,j)
          a(1,j) =  t
!
!         ai(j,1) =  cosr*ai(j,1) + sinr*ai(j,2)
!
          w       =  cosr*ai(j,1) + sinr*ai(j,2)
          ai(j,2) = -sinr*ai(j,1) + cosr*ai(j,2)
          ai(j,1) =  w
  400 continue
!
!
!
  950 continue
      return
!
 1000 continue
      write (6,1100) en,enb,ggit
 1100 format ('  fatal error in refloc.  en, enb, ggit =',/(3e24.16))
      call uabend
      stop
      END subroutine refloc
! **deck remarx
      subroutine remarx(ch)
      character*(*) ch
!
! write a character string to standard error file, a502.err
! changed (27Sep96) to unit 7.   RLC
!
      write (7, '(1X,A)' ) ch
      write (6, '(1X,A)' ) ch
      return
      END subroutine remarx
! **deck remcor
      subroutine remcor (nrem)
!
!         report back amount of dynamic cm remaining
!
!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
      nwtot   =  maplev(2,levdyn) + maplev(1,levdyn) - maplev(1,1)
      nrem    =  maxdyn - nwtot
      return
      END subroutine remcor
! **deck rot1
      subroutine rot1
      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 rotate the networks about an axis
      dimension a(3,3),b(3,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 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,5000,err=9950)ak1,ak2
      k1=ak1
      k2=ak2
      read (ntsin,'( a )') qline
      read (qline,5000,err=9950)x1,y1,z1,x2,y2,z2
      read (ntsin,'( a )') qline
      read (qline,5000,err=9950)phi
!
      x = x2 - x1
      y = y2 - y1
      z = z2 - z1
!
      den = sqrt( x*x + y*y + z*z )
!
      c1  = x/den
      c2  = y/den
      c3  = z/den
!
      ph  = phi * ra
      sp  = sin( ph )
      cp  = cos( ph )
!
      a( 1,1 ) = cp + ( 1.d0 - cp )*c1*c1
      a( 1,2 ) =      ( 1.d0 - cp )*c1*c2 - sp*c3
      a( 1,3 ) =      ( 1.d0 - cp )*c1*c3 + sp*c2
!
      a( 2,1 ) =      ( 1.d0 - cp )*c2*c1 + sp*c3
      a( 2,2 ) = cp + ( 1.d0 - cp )*c2*c2
      a( 2,3 ) =      ( 1.d0 - cp )*c2*c3 - sp*c1
!
      a( 3,1 ) =      ( 1.d0 - cp )*c3*c1 - sp*c2
      a( 3,2 ) =      ( 1.d0 - cp )*c3*c2 + sp*c1
      a( 3,3 ) = cp + ( 1.d0 - cp )*c3*c3
!
      do 40 kk=k1,k2
      m=nm(kk)
      n=nn(kk)
      l=nza(kk)
      do 30 i=1,n
      do 20 j=1,m
      jpl=j+l
      xa=zm(1,jpl)
      ya=zm(2,jpl)
      za=zm(3,jpl)
!
      zm(1,jpl) = a(1,1)*xa + a(1,2)*ya + a(1,3)*za
      zm(2,jpl) = a(2,1)*xa + a(2,2)*ya + a(2,3)*za
      zm(3,jpl) = a(3,1)*xa + a(3,2)*ya + a(3,3)*za
   20 continue
      l=l+m
   30 continue
   40 continue
      return
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'rot1', 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 ('rot1',' program failure due to ill-formatted data')
      return
!
! *** format statements ***
 5000 format (6e10.0)
      END subroutine rot1
! **deck rot2
      subroutine rot2
      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 rotate the networks around a g1ven point in the three
!     coordinate directions
!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 d(27),a(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 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,5000,err=9950)ak1,ak2
      k1=ak1
      k2=ak2
      read (ntsin,'( a )') qline
      read (qline,5000,err=9950)ph1,ph2,ph3,a
      sp1 = sin (ra*ph1)
      cp1 = cos (ra*ph1)
      sp2 = sin (ra*ph2)
      cp2 = cos (ra*ph2)
      sp3 = sin (ra*ph3)
      cp3 = cos (ra*ph3)
      d(1) = 1.d0
      d(2) = 0.d0
      d(3) = 0.d0
      d(4) = 0.d0
      d(5) = cp1
      d(6) = -sp1
      d(7) = 0.d0
      d(8) = sp1
      d(9) = cp1
      d(10) = cp2
      d(11) = 0.d0
      d(12) = sp2
      d(13) = 0.d0
      d(14) = 1.d0
      d(15) = 0.d0
      d(16) = -sp2
      d(17) = 0.d0
      d(18) = cp2
      d(19) = cp3
      d(20) = -sp3
      d(21) = 0.d0
      d(22) = sp3
      d(23) = cp3
      d(24) = 0.d0
      d(25) = 0.d0
      d(26) = 0.d0
      d(27) = 1.d0
      a1 = a(1)
      a2 = a(2)
      a3 = a(3)
      a(1) = 9.d0* (a(1)-1.d0)
      a(2) = 9.d0* (a(2)-1.d0)
      a(3) = 9.d0* (a(3)-1.d0)
      read (ntsin,'( a )') qline
      read (qline,5000,err=9950) x1,y1,z1
!
      do 40 kk=k1,k2
      m=nm(kk)
      n=nn(kk)
      l=nza(kk)
      do 35 i=1,n
      do 30 j=1,m
      ix=j+l
      xa=zm(1,ix)
      ya=zm(2,ix)
      za=zm(3,ix)
      xa = xa - x1
      ya = ya - y1
      za = za - z1
      do 20 ii = 1,3
      jj = a(ii)
      xb = d(jj+1) * xa + d(jj+2) * ya + d(jj+3) * za
      yb = d(jj+4) * xa + d(jj+5) * ya + d(jj+6) * za
      zb = d(jj+7) * xa + d(jj+8) * ya + d(jj+9) * za
      xa = xb
      ya = yb
      za = zb
   20 continue
      xa = xa + x1
      ya = ya + y1
      za = za + z1
      zm(1,ix)= xa
      zm(2,ix)= ya
      zm(3,ix)=za
   30 continue
      l=l+m
   35 continue
   40 continue
      return
!
!                                  read error handling
!
 9950 continue
      write (6,9960) 'rot2', 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 ('rot2',' program failure due to ill-formatted data')
      return
!
! *** format statements ***
 5000 format (6e10.0)
      END subroutine rot2
! **deck rotate
      subroutine rotate(rot,alpha,beta)
      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 orthogonal matrix which transforms reference         *
!     *  coordinates into wind axis coordinates                       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   alpha     argument  input     freestream angle of attack    *
!     *                                 (radians)                     *
!     *                                 (sin(alpha)=dot product of    *
!     *                                 unit freestream and z axis)   *
!     *                                                               *
!     *   beta      argument  input     freestream angle of sideslip  *
!     *                                 (radians)                     *
!     *                                 (tan(beta)=-(y - component of *
!     *                                 freestream)//(x - component of*
!     *                                 freestream))                  *
!     *                                                               *
!     *   rot       argument  output    orthogonal matrix which trans-*
!     *                                 forms reference coordinates   *
!     *                                 into  wind axis coordinates   *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension rot(9)
      cosa  = cos(alpha)
      sina  = sin(alpha)
      cosb  = cos(beta )
      sinb  = sin(beta )
      rot(1) =  cosa*cosb
      rot(2)=sinb
      rot(3) = -sina*cosb
      rot(4)=-cosa*sinb
      rot(5) =  cosb
      rot(6)=sina*sinb
      rot(7) =  sina
      rot(8) =  0.d0
      rot(9) =  cosa
      return
      END subroutine rotate
! **deck rrsax
      subroutine rrsax (a,x,y,  m,n,  na,nx,ny)
      implicit double precision (a-h,o-z)
      dimension  a(na,1), x(nx,1), y(ny,1)
      if ( m.le.0  .or.  n.le.0 ) return
      do 100 i = 1,m
          do 50 j = 1,n
               y(1,i) = y(1,i) - a(i,j)*x(1,j)
   50     continue
  100 continue
      return
      END subroutine rrsax
! **deck rrzab
      subroutine rrzab (a,b,c,  m,l,n,  na,nb,nc)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
      call mxma (a,1,na,  b,1,nb,  c,1,nc,  m,l,n)
      return
      END subroutine rrzab
! **deck rrzatb
      subroutine rrzatb (a,b,c,  m,l,n,  na,nb,nc)
      implicit double precision (a-h,o-z)
      dimension a(1), b(1), c(1)
      call mxma (a,na,1,  b,1,nb,  c,1,nc,  m,l,n)
      return
      END subroutine rrzatb
! **deck rtpack
      subroutine rtpack (nsngtp,sngv)
      implicit double precision (a-h,o-z)
      dimension sngv(nsngtp,4)
!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 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 rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!ca acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!call sngval
      common /sngval/ nsngv, nsolv
!end  sngval
!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 rtrnbk
      common /rtrnbk/ cpr(3,4), enr(3,5), diamr, itdm, itsr, icsr, isqnr&
     &              , ipr, kpr, pwr(3), pxr, rfminr, qdltr, rqffr(3,4)  &
     &              , c1r, c2r, c3r, aqr(9), encfr(3)                   &
     &              , sv1r1(3), dv1r1(6), dvzr1(9), amuxr1(3)           &
     &              , sv2r1(3,2), dv2r1(10,2)                           &
     &              , sv8r1(3,8), dv8r1(6,8)                            &
     &              , usvr1(6),  uvmvr1(4,6), amsvr1(3,3), amdvr1(3,3)  &
     &              , sv1r2(3), dv1r2(6), dvzr2(9), amuxr2(3)           &
     &              , sv2r2(3,2), dv2r2(10,2)                           &
     &              , sv8r2(3,8), dv8r2(6,8)                            &
     &              , usvr2(6),  uvmvr2(4,6), amsvr2(3,3), amdvr2(3,3)  &
     &              , sv1r3(3), dv1r3(6), dvzr3(9), amuxr3(3)           &
     &              , sv2r3(3,2), dv2r3(10,2)                           &
     &              , sv8r3(3,8), dv8r3(6,8)                            &
     &              , usvr3(6),  uvmvr3(4,6), amsvr3(3,3), amdvr3(3,3)  &
     &              , sv1r4(3), dv1r4(6), dvzr4(9), amuxr4(3)           &
     &              , sv2r4(3,2), dv2r4(10,2)                           &
     &              , sv8r4(3,8), dv8r4(6,8)                            &
     &              , usvr4(6),  uvmvr4(4,6), amsvr4(3,3), amdvr4(3,3)
      integer rtrnbf(435)
      equivalence (rtrnbf,cpr)
!
!end  rtrnbk
!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
!
      dimension sval(10), dval(25), amuxvl(5)
!
      call jzero(cpr,nrdq)
      call xfera (cp,cpr,12)
      call xfera (en,enr,15)
      itsr    =  its
      icsr    =  ics
      isqnr   =  isqn
      diamr   =  diam
      ipr     =  ipn
      kpr     =  kp
!
      call xfera (pwf,pwr,3)
      pxr     =  pxf
      rfminr  =  rfmin
      qdltr   =  qdltf
      call xfera (rqff,rqffr,12)
      c1r     =  c1
      c2r     =  c2
      c3r     =  c3
      call xfera (aq,aqr,9)
      call xfera (encf,encfr,3)
!
      if ( its.ne.1  .and.  its.ne.3 ) ins = 0
      if ( its.ne.2  .and.  its.ne.3 ) ind = 0
      icsp    =  0
      if ( ics.ne.0 ) icsp = mod(ics,4) + 1
!
      do 500 isol = 1,nsolv
      if ( ins.le.0 ) go to 210
      do 100 j = 1,ins
          sval(j) =  sngv( iis(j), isol)
  100 continue
      call mxma (asts,1,3,  sval,1,ins,  sv1(1,isol),1,3,  3,ins,1)
      do 150 k = 1,2
      call mxma (rk(1,1,k),1,3,  sv1(1,isol),1,3,  sv2(1,k,isol),1,3    &
     &           ,3,3,1)
      if ( ics.ne.0 ) go to 160
  150 continue
  160 continue
!
      do 200 k = 1,8
      if ( k.eq.ics .or. k.eq.icsp ) go to 200
      call mxma (rr(1,1,k),1,3,  sv1(1,isol),1,3,  sv8(1,k,isol),1,3    &
     &           ,3,3,1)
  200 continue
!
  210 continue
      if ( ind.le.0 ) go to 410
      do 300 j = 1,ind
      dval(j) =  sngv( iid(j), isol)
  300 continue
      call mxma (astd,1,9,  dval,1,ind,  dvz(1,isol),1,9,  9,ind,1)
      call mxma (qa,1,6,  dvz(1,isol),1,9,  dv1(1,isol),1,6,  6,9,1)
      do 350 k = 1,2
      call mxma (qk(1,1,k),1,10,  dvz(1,isol),1,9,  dv2(1,k,isol),1,10  &
     &          ,10,9,1)
      if ( ics.ne.0 ) go to 360
  350 continue
  360 continue
      do 400 k = 1,8
      if ( k.eq.ics  .or.  k.eq.icsp ) go to 400
      call mxma (qq(1,1,k),1,6,  dvz(1,isol),1,9,  dv8(1,k,isol),1,6    &
     &          ,6,9,1)
  400 continue
!
  410 continue
      call dcopy (3,  0.d0,0,  amuxz(1,isol),1)
      if ( inmux.le.0 ) goto 460
      do 450 j = 1,inmux
           amuxvl(j) = sngv( iimux(j), isol)
  450 continue
      call hsmmp1 (3,inmux,1,  astmux,1,3,  amuxvl,1,inmux              &
     &            ,amuxz(1,isol),1,3)
  460 continue
!
  500 continue
!
!
!
      call ffdqgv
!
!
!
      if ( nacase.lt.1 ) goto 600
      isol    =  1
      call xfera  (sv1(  1,isol),  sv1r1,   3)
      call xfera  (dv1(  1,isol),  dv1r1,   6)
      call xfera (dvz(1,isol),  dvzr1,  9)
      call xfera (amuxz(1,isol),  amuxr1, 3)
      call xfera  (sv2(1,1,isol),  sv2r1,   6)
      call xfera  (dv2(1,1,isol),  dv2r1,  20)
      call xfera  (sv8(1,1,isol),  sv8r1,  24)
      call xfera  (dv8(1,1,isol),  dv8r1,  48)
      call xfera  (usv(  1,isol),  usvr1,   6)
      call xfera (uvmv(1,1,isol), uvmvr1,  24)
      call xfera (amsv(1,1,isol), amsvr1,   9)
      call xfera (amdv(1,1,isol), amdvr1,   9)
  600 continue
!
      if ( nacase.lt.2 ) goto 700
      isol    =  2
      call xfera  (sv1(  1,isol),  sv1r2,   3)
      call xfera  (dv1(  1,isol),  dv1r2,   6)
      call xfera (dvz(1,isol),  dvzr2,  9)
      call xfera (amuxz(1,isol),  amuxr2, 3)
      call xfera  (sv2(1,1,isol),  sv2r2,   6)
      call xfera  (dv2(1,1,isol),  dv2r2,  20)
      call xfera  (sv8(1,1,isol),  sv8r2,  24)
      call xfera  (dv8(1,1,isol),  dv8r2,  48)
      call xfera  (usv(  1,isol),  usvr2,   6)
      call xfera (uvmv(1,1,isol), uvmvr2,  24)
      call xfera (amsv(1,1,isol), amsvr2,   9)
      call xfera (amdv(1,1,isol), amdvr2,   9)
  700 continue
!
      if ( nacase.lt.3 ) goto 800
      isol    =  3
      call xfera  (sv1(  1,isol),  sv1r3,   3)
      call xfera  (dv1(  1,isol),  dv1r3,   6)
      call xfera (dvz(1,isol),  dvzr3,  9)
      call xfera (amuxz(1,isol),  amuxr3, 3)
      call xfera  (sv2(1,1,isol),  sv2r3,   6)
      call xfera  (dv2(1,1,isol),  dv2r3,  20)
      call xfera  (sv8(1,1,isol),  sv8r3,  24)
      call xfera  (dv8(1,1,isol),  dv8r3,  48)
      call xfera  (usv(  1,isol),  usvr3,   6)
      call xfera (uvmv(1,1,isol), uvmvr3,  24)
      call xfera (amsv(1,1,isol), amsvr3,   9)
      call xfera (amdv(1,1,isol), amdvr3,   9)
  800 continue
!
      if ( nacase.lt.4 ) goto 900
      isol    =  4
      call xfera  (sv1(  1,isol),  sv1r4,   3)
      call xfera  (dv1(  1,isol),  dv1r4,   6)
      call xfera (dvz(1,isol),  dvzr4,  9)
      call xfera (amuxz(1,isol),  amuxr4, 3)
      call xfera  (sv2(1,1,isol),  sv2r4,   6)
      call xfera  (dv2(1,1,isol),  dv2r4,  20)
      call xfera  (sv8(1,1,isol),  sv8r4,  24)
      call xfera  (dv8(1,1,isol),  dv8r4,  48)
      call xfera  (usv(  1,isol),  usvr4,   6)
      call xfera (uvmv(1,1,isol), uvmvr4,  24)
      call xfera (amsv(1,1,isol), amsvr4,   9)
      call xfera (amdv(1,1,isol), amdvr4,   9)
  900 continue
      return
      END subroutine rtpack
! **deck rtunpk
      subroutine rtunpk
      implicit double precision (a-h,o-z)
!call rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!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 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 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 rtrnbk
      common /rtrnbk/ cpr(3,4), enr(3,5), diamr, itdm, itsr, icsr, isqnr&
     &              , ipr, kpr, pwr(3), pxr, rfminr, qdltr, rqffr(3,4)  &
     &              , c1r, c2r, c3r, aqr(9), encfr(3)                   &
     &              , sv1r1(3), dv1r1(6), dvzr1(9), amuxr1(3)           &
     &              , sv2r1(3,2), dv2r1(10,2)                           &
     &              , sv8r1(3,8), dv8r1(6,8)                            &
     &              , usvr1(6),  uvmvr1(4,6), amsvr1(3,3), amdvr1(3,3)  &
     &              , sv1r2(3), dv1r2(6), dvzr2(9), amuxr2(3)           &
     &              , sv2r2(3,2), dv2r2(10,2)                           &
     &              , sv8r2(3,8), dv8r2(6,8)                            &
     &              , usvr2(6),  uvmvr2(4,6), amsvr2(3,3), amdvr2(3,3)  &
     &              , sv1r3(3), dv1r3(6), dvzr3(9), amuxr3(3)           &
     &              , sv2r3(3,2), dv2r3(10,2)                           &
     &              , sv8r3(3,8), dv8r3(6,8)                            &
     &              , usvr3(6),  uvmvr3(4,6), amsvr3(3,3), amdvr3(3,3)  &
     &              , sv1r4(3), dv1r4(6), dvzr4(9), amuxr4(3)           &
     &              , sv2r4(3,2), dv2r4(10,2)                           &
     &              , sv8r4(3,8), dv8r4(6,8)                            &
     &              , usvr4(6),  uvmvr4(4,6), amsvr4(3,3), amdvr4(3,3)
      integer rtrnbf(435)
      equivalence (rtrnbf,cpr)
!
!end  rtrnbk
!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
!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
!
!
      dimension z(3), enq(3), pft(3,3), prjen(3,3)
      dimension genref(3,3), kgen(5)
      save ncall
!
      data kgen / 1,3,3,1,2/
!
!
!
      data ncall /0/
!
      ncall = ncall + 1
!
      call xfera (cpr,cp,12)
      call xfera (enr,en,15)
      its     =  itsr
      itsf    =  itsr
      ics     =  icsr
      icsf    =  icsr
      isqn    =  isqnr
      diam    =  diamr
      ipn     =  ipr
      ipnf    =  ipr
      kp      =  kpr
!
      kpf     =  kpr
      call xfera (pwr,pwf,3)
      pxf     =  pxr
      rfmin   =  rfminr
      qdltf   =  qdltr
      call xfera (rqffr,rqff,12)
      c1      =  c1r
      c2      =  c2r
      c3      =  c3r
      call xfera (aqr,aq,9)
      call xfera (encfr,encf,3)
!
      icsp    =  0
      if ( ics.ne.0 ) icsp = mod(ics,4) + 1
!
      ncs    =  3
      ncd    =  9
!                                  extend corner point data
      do 100 j = 1,4
          jp1    =  mod(j,4) + 1
          cp(1,j+4) = .5d0*( cp(1,j) + cp(1,jp1) )
          cp(2,j+4) = .5d0*( cp(2,j) + cp(2,jp1) )
          cp(3,j+4) = .5d0*( cp(3,j) + cp(3,jp1) )
  100 continue
      cp(1,9)  =  .25d0*( cp(1,1) + cp(1,2) + cp(1,3) + cp(1,4) )
      cp(2,9)  =  .25d0*( cp(2,1) + cp(2,2) + cp(2,3) + cp(2,4) )
      cp(3,9)  =  .25d0*( cp(3,1) + cp(3,2) + cp(3,3) + cp(3,4) )
      call vadd (cp(1,4), -1.d0, cp(1,1), genref(1,1), 3)
      call vadd (cp(1,7), -1.d0, cp(1,5), genref(1,2), 3)
      call vadd (cp(1,3), -1.d0, cp(1,2), genref(1,3), 3)
!
!                                  compute transformations
      call jzero (iin,5)
      rqmin   =  1.d0
      do 200 is = 1,5
          isp3    =  mod(is+2,4) + 1
          if ( is.ne.5 .and. (is.eq.ics .or. isp3.eq.ics ) ) go to 200
          kg      =  kgen(is)
          call refloc (en(1,is),sbetam,genref(1,kg)                     &
     &                ,ar(1,is),aj(is),arpn,ari)
          iin(is) =  arpn
          rqmin   =   min ( rqmin, arpn)
          sgn     =  compd(1)*en(1,is)                                  &
     &             + compd(2)*en(2,is)                                  &
     &             + compd(3)*en(3,is)
          sgx(is) = sign( 1.d0, sgn)
  200 continue
!
      do 250 j = 1,4
          call unipan (ar(1,5),cp(1,9),cp(1,j),pf(1,j))
  250 continue
!
!
!
      diamf   =  diam
      rf      =  iin(5)
      sf      =  sbetam
      ajf     =  aj(5)
      nsff    =  4
      call xfera (cp(1,9),cpfz,3)
      call xfera (cp,cpf,12)
      call xfera (ar(1,5),af,9)
      call trans (af,aft,3,3)
!
!
!
!
! *** indff   =  0
! *** call ffdqgx (indff)
!
!
!
      do 700 k = 1,2
      is      =  isqn
      if ( k.eq.2 ) is = mod(is+1,4)+1
      ism1    =  mod(is+2,4) + 1
      isp1    =  mod(is,4) + 1
      call zero (pk(1,1,k),3)
      call unipan (ar(1,is),cp(1,is),cp(1,isp1),pk(1,2,k))
      call unipan (ar(1,is),cp(1,is),cp(1,ism1),pk(1,3,k))
      if ( ics.ne.0 ) go to 710
  700 continue
  710 continue
!
      do 800 k = 1,4
      ic1     =  k
      ic2     =  k + 4
      ic3     =  mod(k+2,4)+5
      if ( k.eq.ics .or. k.eq.icsp ) go to 750
      call zero (pp(1,1,k),3)
      call unipan (ar(1,k),cp(1,ic1),cp(1,ic2),pp(1,2,k))
      call unipan (ar(1,k),cp(1,ic1),cp(1,ic3),pp(1,3,k))
  750 continue
!
      ic1     =  9
      ic2     =  ic3
      ic3     =  k+4
      call zero (pp(1,1,k+4),3)
      call unipan (ar(1,5),cp(1,ic1),cp(1,ic2),pp(1,2,k+4))
      call unipan (ar(1,5),cp(1,ic1),cp(1,ic3),pp(1,3,k+4))
  800 continue
!
!
!
      if ( nacase.lt.1 ) goto 1100
      isol    =  1
      call xfera ( sv1r1,   sv1(  1,isol),  3)
      call xfera ( dv1r1,   dv1(  1,isol),  6)
      call xfera (dvzr1,  dvz(1,isol),  9)
      call xfera (amuxr1,   amuxz(1,isol),  3)
      call xfera ( sv2r1,   sv2(1,1,isol),  6)
      call xfera ( dv2r1,   dv2(1,1,isol), 20)
      call xfera ( sv8r1,   sv8(1,1,isol), 24)
      call xfera ( dv8r1,   dv8(1,1,isol), 48)
      call xfera ( usvr1,   usv(  1,isol),  6)
      call xfera (uvmvr1,  uvmv(1,1,isol), 24)
      call xfera (amsvr1,  amsv(1,1,isol),  9)
      call xfera (amdvr1,  amdv(1,1,isol),  9)
 1100 continue
!
      if ( nacase.lt.2 ) goto 1200
      isol    =  2
      call xfera ( sv1r2,   sv1(  1,isol),  3)
      call xfera ( dv1r2,   dv1(  1,isol),  6)
      call xfera (dvzr2,  dvz(1,isol),  9)
      call xfera (amuxr2,   amuxz(1,isol),  3)
      call xfera ( sv2r2,   sv2(1,1,isol),  6)
      call xfera ( dv2r2,   dv2(1,1,isol), 20)
      call xfera ( sv8r2,   sv8(1,1,isol), 24)
      call xfera ( dv8r2,   dv8(1,1,isol), 48)
      call xfera ( usvr2,   usv(  1,isol),  6)
      call xfera (uvmvr2,  uvmv(1,1,isol), 24)
      call xfera (amsvr2,  amsv(1,1,isol),  9)
      call xfera (amdvr2,  amdv(1,1,isol),  9)
 1200 continue
!
      if ( nacase.lt.3 ) goto 1300
      isol    =  3
      call xfera ( sv1r3,   sv1(  1,isol),  3)
      call xfera ( dv1r3,   dv1(  1,isol),  6)
      call xfera (dvzr3,  dvz(1,isol),  9)
      call xfera (amuxr3,   amuxz(1,isol),  3)
      call xfera ( sv2r3,   sv2(1,1,isol),  6)
      call xfera ( dv2r3,   dv2(1,1,isol), 20)
      call xfera ( sv8r3,   sv8(1,1,isol), 24)
      call xfera ( dv8r3,   dv8(1,1,isol), 48)
      call xfera ( usvr3,   usv(  1,isol),  6)
      call xfera (uvmvr3,  uvmv(1,1,isol), 24)
      call xfera (amsvr3,  amsv(1,1,isol),  9)
      call xfera (amdvr3,  amdv(1,1,isol),  9)
 1300 continue
!
      if ( nacase.lt.4 ) goto 1400
      isol    =  4
      call xfera ( sv1r4,   sv1(  1,isol),  3)
      call xfera ( dv1r4,   dv1(  1,isol),  6)
      call xfera (dvzr4,  dvz(1,isol),  9)
      call xfera (amuxr4,   amuxz(1,isol),  3)
      call xfera ( sv2r4,   sv2(1,1,isol),  6)
      call xfera ( dv2r4,   dv2(1,1,isol), 20)
      call xfera ( sv8r4,   sv8(1,1,isol), 24)
      call xfera ( dv8r4,   dv8(1,1,isol), 48)
      call xfera ( usvr4,   usv(  1,isol),  6)
      call xfera (uvmvr4,  uvmv(1,1,isol), 24)
      call xfera (amsvr4,  amsv(1,1,isol),  9)
      call xfera (amdvr4,  amdv(1,1,isol),  9)
 1400 continue
      if ( ncall.gt.0 ) return
      if ( ncall.gt.3 ) return
      write (6,'(1x,a10,1x, 6i12)')                                     &
     & '==rtunpk',ncall,ipn,kp,npandq,npandf,npandv
      call dpdqfv
      call outmat ('hm',10,10,6,hm)
      return
      END subroutine rtunpk
! **deck saical
      subroutine saical (scr,dvdfs,s,jcnbu,bbeta,brhs)
      implicit double precision (a-h,o-z)
      dimension scr(1:*), dvdfs(4,1:*), s(1:*), jcnbu(1:*)
! --- dimension bbeta(nsngt), brhs(nsngt)
      dimension bbeta(1:*),   brhs(1:*)
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to compute boundary value problem left hand side influence   *
!     *  coefficient and right hand side matrices                     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   arhs      -local-   - - - -   array containing right hand   *
!     *                                 component of row              *
!     *                                                               *
!     *   iacase    /acase/   -local-   index of loop over right hand *
!     *                                 side cases                    *
!     *                                                               *
!     *   is        -local-   - - - -   index of loop over known or   *
!     *                                 unknown singularity parameters*
!     *                                                               *
!     *   jc        -local-   - - - -   control point index           *
!     *                                                               *
!     *   jcnbu     argument  -local-   index information for nsngu   *
!     *                                 rhs entries                   *
!     *                                                               *
!     *   mtitle    /solnt/   -local-   title of solution matrix      *
!     *                                                               *
!     *   nacase    /acase/   input     number of freestream cases    *
!     *                                 for simultaneous solution     *
!     *                                                               *
!     *   mtitle    /solnt/   -local-   scratch array for whead       *
!     *                                                               *
!     *   naic      /solnt/   input     i/o unit on which aic matrix  *
!     *                                 resides                       *
!     *                                                               *
!     *   nctrt     /index/   input     total number of control points*
!     *                                                               *
!     *   nrhs      /solnt/   input     i/o unit on which right hand  *
!     *                                 side matrix resides           *
!     *                                                               *
!     *   nsngk     /index/   input     total number of known         *
!     *                                 singularity parameters        *
!     *                                                               *
!     *   nsngu     /index/   input     total number of unknown       *
!     *                                 singularity parameters        *
!     *                                                               *
!     *   nwrit     -local-   - - - -   flag indicating whether       *
!     *                                 boundary condition yields     *
!     *                                 essential equation            *
!     *                                 =1   essential                *
!     *                                 =0   not essential            *
!     *                                                               *
!     *   s         /skrch1/  -local-   scratch array for holding left*
!     *                                 hand component of row         *
!     *                                                               *
!     *   scrp      /skrch1/  input     known singularity parameters  *
!     *                                 for each right hand side      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 solnt
      common/solnt/naic,nrhs,nans,nsc1,nsc2,nsc3,nsc4,iray(10),mtitle(5)
!end  solnt
!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 vrwi
      common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp)
!end  vrwi
!call singq
      common /singq/ insq, indq, sgq(16), amuq(25)
!end  singq
!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 bcond
      common /bcond/                                                    &
     &  cu,cl,tu(3),tl(3),du,dl,bet(4),nct,nlopt,nropt,necpt            &
     & ,klopt,kldum,betin(4)                                            &
     & ,nbin
!end  bcond
!ca 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 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
      dimension arhs(6)
!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
!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 prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!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 rhsuv(maxcp2)
      character*8 fname
      logical fexist, rlse20
      logical tape89
!
!
!
      call setcor ('saical')
      call getcor ('rows',llrows,nsngt)
      tape89  =  .false.
      open (88,file='fort.88',form='unformatted')
      rlse20  =  .true.
      ipraic  =  iabs( ipraic )
!----      nta     =  iray(2)
      nta     =  0
      nna     =  mxsngu + 1
      call openms (ntv,niv,nnv,0)
      call readms (ntv,nwv,nctrt,nctrt+1)
      if ( nta.ne.0 ) call openms (nta,nia,nna,0)
!                                  set blocking parms, open lint & llu
      llu     =  iray(6)
      lint    =  iray(7)
!
      npp     =  nppblk
      nqq     =  nqqblk
      np      =  npblk
      nq      =  nqblk
      nwic    =  nwwblk
!                                  open lint & llu
      kint    =  kinblk
      call igtcor ('int',llint,kint)
      call openms (lint,w(llint),kint,0)
!
      klu     =  klublk
      call igtcor ('ilu',llilu,klu)
      call openms (llu,w(llilu),klu,0)
!
      call getcor ('wic',llwic,nwic)
!
      nbccp2  =  0
      nra     =  0
      if(nsngk.eq.0) go to 650
      rewind 93
      do 600 is=1,nsngk
      kmax=is+nsngk*(nacase-1)
      read(93) (scr(k),k=is,kmax,nsngk)
!                                  put known lambda's in bbeta, brhs
      bbeta(is+nsngu) = scr(is)
      brhs(is+nsngu)  = scr(is)
  600 continue
  650 continue
!                                  read data for multi-nw matching
      call xtrns (20,ncp2ab,nx20)
      if ( ncp2ab.ne.0 ) call icopy (ncp2ab,  idcp2,3,  ablcp2,1)
      if ( ncp2ab.ne.0 ) call jshell (ncp2ab, ablcp2, keycp2)
      if ( iexcp2.lt.1 ) go to 655
      call outvci ('ablcp2',ncp2ab,ablcp2)
      call outvci ('keycp2',ncp2ab,keycp2)
  655 continue
      rewind nrhs
!c
!     *  loop ranges over control points                              *
!
      nzero =  0
      do 700 jc=1,nctrt
      call vtrns(jc,dvdfs)
      call ctrns (jc,zc)
      knet    =  kc
      call mnmod (ijfgc,2*nm(kc)-1,ifn,jfn)
!c
!     *  read in boundary condition left hand side                    *
!     *  coefficients and right hand side values                      *
!
      do 675 ibin = 1,2
      call btrnsf(jc,ibin)
!c
!     *  calculate row of system corresponding to                     *
!     *  first boundary condition at control point                    *
!
      call aical (s,w(llrows),arhs,jc,nwrit,nra,dvdfs,nrhtyp)
!c
!     *  if first boundary condition is essential store right and     *
!     *  left hand side components of row                             *
!
      if(nwrit.eq.0) go to 675
      nra     =  nra + 1
      jcnbu(nra) = ibin + 4*( nrhtyp + 16*jc )
      if ( nta.ne.0 ) call writmd (nta,s,ityprc*nsngt,nra,-1,0)
      irowra  =  nra - 1
      if ( ifact.eq.0 )                                                 &
     &     call blkaic (irowra,s,w(llwic),nwic,  ityprc,nsngu,npp,nqq   &
     &                 ,lint,w(llint),llu,w(llilu))
      if ( tape89 ) then
      write (89) jc,nbin,knet,ifn,jfn
      write (89) (s(i),i=1,nsngt)
      endif
 7001 format (3i10,'  rowindex, nsngt, nsngu')
 7002 format (5e24.16)
      bbeta(nra) = arhs(1)
      if (nsngk.ne.0) call hsmmp3 (1,nsngk,nacase,  s(nsngu+1),1,1      &
     &                            ,scr,1,nsngk,  arhs,1,1)
      brhs(nra)  = arhs(1)
      sum     =  0.d0
      do 670 is = 1,nsngu
  670 sum     =  sum + s(is)
      nap1    =  nacase + 1
      arhs(nap1)  =  sum
      write (nrhs) (arhs(i),i=1,nap1)
      write (88) jc,nbin,knet,ifn,jfn,nap1,(arhs(i),i=1,nap1)
! ---      write (6,6421) nra,(arhs(i),i=1,nap1)
 6421 format (1x,'rhs',i4,10f12.7)
      call vip (s,1,s,1,ityprc*nsngu,asqr)
      if ( asqr .eq. 0.d0 ) call aicerr (nzero,nra,jc,dvdfs)
  675 continue
!
  700 continue
!
      if ( nra.ne.nsngu ) call a502er ('saical'                         &
     &     ,'mismatch between aic rows and unknown sp-s')
!                                  close the intermediate blocking file
      call closms (lint)
      if ( rlse20 ) then
         fname  =  'rwms20'
         inquire (file=fname,exist=fexist)
         if ( fexist ) then
           open (lint,file=fname,recl=2048/1,access='direct',status='old')
           close (lint,status='delete')
         endif
      endif
!                                  close the blocked AIC/LU file
      call closms (llu)
!
      if ( nbccp2.le.0 ) go to 950
      write (6,9001) nbccp2
 9001 format (1h0,'  ******************************** '                 &
     &   ,/,  1h ,'  *                              * '                 &
     &   ,/,  1h ,'  *   nonliner bc count  ',i6,'  * '                 &
     &   ,/,  1h ,'  *                              * '                 &
     &   ,/,  1h ,'  ******************************** '                 &
     &    )
      nrow    =  nra
      rewind nrhs
      nap1    =  nacase + 1
      do 800 irow = 1,nrow
      read (nrhs) (dvdfs(i,irow),i=1,nacase), s(irow)
  800 continue
!
!
      ibccp2  =  1
      irowcp  =  irwcp2(ibccp2)
      rewind nrhs
      call dcopy (ityprc*nbccp2,  0.d0,0,  rhsuv,1)
      do 900 irow = 1,nrow
      if ( irow.eq.irowcp ) rhsuv(ibccp2) = 1.d0
      write (nrhs) (dvdfs(i,irow),i=1,nacase), s(irow)                  &
     &           , (rhsuv(i),i=1,nbccp2)
      if ( irow.ne.irowcp ) go to 900
          rhsuv(ibccp2) = 0.d0
          if ( ibccp2.ge.nbccp2 ) go to 900
          ibccp2  =  ibccp2 + 1
          irowcp  =  irwcp2(ibccp2)
  900 continue
!
!
!
  950 continue
!---      call outvcx ('aic-bbeta',nsngt,bbeta)
!---      call outvcx ('aic-brhs', nsngt,brhs)
      call closms (ntv)
      if ( nzero.gt.0 ) call labort (nzero,0                            &
     &        ,'number of zero aic rows in the matrix            ')
!c
!     *  print out job status and cost for step just completed        *
!
      call ixtrns (21,nbccp2,3*maxcp2+1)
      call ixtrns (40,jcnbu,nsngu)
      if ( nta.ne.0 ) call closms (nta)
      call cstprt ('aic cost')
      call frecor ('saical')
      return
      END subroutine saical
! **deck samep
      subroutine samep(p1,p2,p3,cp,q1,q2,q3,cq,   insidf)
      implicit double precision (a-h,o-z)
!
!     purpose: compute intersection when triangles planar
!
!     inputs:  p1,p2,p3 points of first triangle
!              q1,q2,q3 points of second triangle
!              cp,cq    coefficients of two planes
!
!     outputs: insidf   flag indicating intersection
!
      dimension p1(3), p2(3), p3(3)
      dimension q1(3), q2(3), q3(3)
      dimension cp(4), cq(4)
      logical   insidf, intf, iedgef
!
!     initialize flags
!
      insidf = .false.
      intf   = .false.
      iedgef = .false.
!
!
      call quikck(p1,p2,p3,q1,q2,q3,   intf)
      if( .not. intf ) go to 999
!
      n=0
      call isitin(p1,p2,p3,cp,q1,   iedgef,insidf)
      if( iedgef ) n = n + 1
      if( insidf ) go to 888
      call isitin(p1,p2,p3,cp,q2,   iedgef,insidf)
      if( iedgef ) n = n + 1
      if( insidf ) go to 888
      call isitin(p1,p2,p3,cp,q3,   iedgef,insidf)
      if( iedgef ) n = n + 1
      if( insidf ) go to 888
      if ( n .eq. 3 ) go to 888
!
      n = 0
      call isitin(q1,q2,q3,cq,p1,   iedgef,insidf)
      if( iedgef ) n = n + 1
      if( insidf ) go to 888
      call isitin(q1,q2,q3,cq,p2,   iedgef,insidf)
      if( iedgef ) n = n + 1
      if( insidf ) go to 888
      call isitin(q1,q2,q3,cq,p3,   iedgef,insidf)
      if( iedgef ) n = n + 1
      if( insidf ) go to 888
      if ( n .eq. 3 ) go to 888
!
      call twopts(p1,p2,p3,cp,q1,q2,   insidf)
      if( insidf) go to 888
      call twopts(p1,p2,p3,cp,q2,q3,   insidf)
      if( insidf) go to 888
      call twopts(p1,p2,p3,cp,q3,q1,   insidf)
      if( insidf) go to 888
!
      call twopts(q1,q2,q3,cq,p1,p2,   insidf)
      if( insidf ) go to 888
      call twopts(q1,q2,q3,cq,p2,p3,   insidf)
      if( insidf ) go to 888
      call twopts(q1,q2,q3,cq,p3,p1,   insidf)
      if( insidf ) go to 888
      go to 999
!
  888 insidf = .true.
!
  999 return
      END subroutine samep
! **deck sbcncl
      subroutine sbcncl
      implicit double precision (a-h,o-z)
!call irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!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 mspntz
      common /mspntz/ zmzero (3,maxpts)
!end  mspntz
!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 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 skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
!
      call setcor ('sbcncl')
      nsngn   =  nssa(nnett+1)
      nctrn   =  nbca(nnett+1)
      nctrnx  =  nmapca(nnett+1)
      mxmnfg  =  0
      mxmn    =  0
      do 100 k = 1,nnett
         mxmnfg  =  max( mxmnfg, (2*nm(k)-1)*(2*nn(k)-1) )
         mxmn    =  max( mxmn,  nm(k)*nn(k) )
  100 continue
      write (6,'( '' nsngn  nctrn nctrnx   mxmn mxmnfg   nabt nfdseg''  &
     &   ,/,7i7)')   nsngn, nctrn,nctrnx,  mxmn,mxmnfg,  nabt,nfdseg
!
      call igtcor ('mbc', llmbc,   nctrn)
      call igtcor ('lsrt',lllsrt,4*nsngn)
      call igtcor ('keyl',llkeyl,  nsngn)
      call igtcor ('maps',llmaps,  nsngn)
!
      call igtcor ('locs',lllocs,4*nsngn)
      call igtcor ('mapb',llmapb,  nsngn)
      call igtcor ('fgsp',llfgsp,  nsngn)
      call igtcor ('neda',llneda,  nabt+1)
!
      call igtcor ('kfds',llkfds,4*nfdseg)
      call igtcor ('kkey',llkkey,  nfdseg)
      call igtcor ('ksgn',llksgn,  nfdseg)
      call igtcor ('ietp',llietp,4*nnett)
!
      call igtcor ('mtch',llmtch,4*nabt)
      call igtcor ('kplm',llkplm,  nsngn)
      call igtcor ('kslm',llkslm,  nsngn)
      call igtcor ('ispk',llispk,4*nsngn)
!
      call igtcor ('map1',llmap1,  mxmnfg)
      call igtcor ('map2',llmap2,  mxmnfg)
      call igtcor ('map3',llmap3,  mxmnfg)
      call igtcor ('jcnb',lljcnb,  nsngn)
      call igtcor ('ijfn',llijfn,nsngn)
!
      call getcor ('almv',llalmv,4*mxmn)
      call getcor ('vsfg',llvsfg,6*mxmnfg)
      call getcor ('amu', llamu,   mxmnfg)
      call getcor ('dcpn',lldcpn,2*mxmn)
!
      call readmd (nti,zmzero,nidq(19),19)
      call bconcl ( w(llmbc),  w(lllsrt), w(llkeyl), w(llmaps)          &
     &            , w(lllocs), w(llmapb), w(llfgsp), w(llneda)          &
     &            , w(llkfds), w(llkkey), w(llksgn), w(llietp)          &
     &            , w(llmtch), w(llkplm), w(llkslm), w(llispk)          &
     &            , w(llmap1), w(llmap2), w(llmap3), w(lljcnb),w(llijfn)&
     &            , w(llalmv), w(llvsfg), w(llamu),  w(lldcpn)          &
     &            , nctrn, nsngn, nabt, nfdseg, mxmn,  mxmnfg)
!
      call frecor ('sbcncl')
      return
      END subroutine sbcncl
! **deck sbcond
      subroutine sbcond
      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 analyze boundary conditions                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call xcntrl
      common /xcntrl/ icntrl,jcntrl
!end  xcntrl
!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
!c
!     *  reformat boundary conditions and execute user specified      *
!     *  options                                                      *
!call cumabc
!                                                            /cumabc/
!         cumulative bc count, used in bconcl
      common /cumabc/ nabca(151)
!end  cumabc
!call irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call indxsp
      common /indxsp/ nxsptt, nxspa(151), locxsp(1200)                  &
     &              , ngsptt, ngspa(151), locgsp(1200)
!end  indxsp
!call cvxerr
      common /cvxerr/ ncvxer
!end  cvxerr
!call a502cn
      common /a502cn/ i502er
!end  a502cn
!
      ncvxer  =  0
      call sbcncl
      call cstprt ('bndy cnd')
      call sffgen
      call cstprt ('ffgen   ')
!c
!     *  print problem and network indices for data check             *
!
          write(6,6000)
 6000 format(1h1)
      call bmark('problem ')
      write(6,7000)
 7000 format(///50x,27hproblem and network indices,///)
      write(6,7001) nnett,nzmpt,npant,nsngt,nsngu,nsngk,nctrt,nbcot
 7001 format(/,3x,7hnnett =,i5,3x,7hnzmpt =,i5,3x,7hnpant =,i5,         &
     &3x,7hnsngt =,i5,3x,7hnsngu =,i5,3x,7hnsngk =,i5,3x,7hnctrt =,i5,  &
     &3x,7hnbcot =,i5,///)
      write (6,7013) nsymm,nisym,njsym,misym,mjsym
 7013 format (' symmetry data,  nsymm =',i5,'  nisym =',i5,'  njsym =', &
     &i5,'  misym = ',i5,'  mjsym =',i5)
      write (6,6999) (k,k=1,nnett)
 6999 format (1h0,4x,5hnw  =,20i5,/,(10x,20i5))
      write(6,7002) (nts(k),k=1,nnett)
 7002 format (5x,5hnts =,20i5,/,(10x,20i5))
      write(6,7003) (ntd(k),k=1,nnett)
 7003 format (5x,5hntd =,20i5,/,(10x,20i5))
      write(6,7004) (nm(k),k=1,nnett)
 7004 format (5x,5hnm  =,20i5,/,(10x,20i5))
      write(6,7005) (nn(k),k=1,nnett)
 7005 format (5x,5hnn  =,20i5,/,(10x,20i5))
      write(6,7006) (nza(k+1)-nza(k),k=1,nnett)
 7006 format (5x,5hnz  =,20i5,/,(10x,20i5))
      write(6,7007) (npa(k+1)-npa(k),k=1,nnett)
 7007 format (5x,5hnp  =,20i5,/,(10x,20i5))
      write(6,7008) (nsda(k)-nssa(k),k=1,nnett)
 7008 format (5x,5hnss =,20i5,/,(10x,20i5))
      write(6,7009) (nssa(k+1)-nsda(k),k=1,nnett)
 7009 format (5x,5hnsd =,20i5,/,(10x,20i5))
      write(6,7010) (nca(k+1)-nca(k),k=1,nnett)
 7010 format (5x,5hnc  =,20i5,/,(10x,20i5))
      write (6,7011) (nabca(k+1)-nabca(k),k=1,nnett)
 7011 format (5x,5hnabc=,20i5,/,(10x,20i5))
      write(6,7012) (ipot(k),k=1,nnett)
 7012 format (5x,5hipot=,20i5,/,(10x,20i5))
!c
!     *  print out job status and cost for step just completed        *
      write (6,7014) (nwofb(i),i=1,nnwofb)
 7014 format (5x,5hnwofb,20i5,/,(10x,20i5))
      write (6,7015) (nca(k),k=1,nnett+1)
 7015 format (5x,5hnca =,20i5,/,(10x,20i5))
      write (6,7016) (nbca(k),k=1,nnett+1)
 7016 format (5x,5hnbca=,20i5,/,(10x,20i5))
      write (6,7017) (nmapca(k),k=1,nnett+1)
 7017 format (5x,5hmapca,20i5,/,(10x,20i5))
      write (6,7018) ((nxspa(k+1)-nxspa(k)),k=1,nnett)
 7018 format (5x,5hnxsp=,20i5,/,(10x,20i5))
!
!
      if ( ncvxer .le. 0 ) go to 200
      write (6,5001) ncvxer
 5001 format (  33(2h *) ,/,'   execution terminated due to ',i5        &
     & ,'nonconvexity errors.  (see messages above) ')
      stop
  200 continue
      if ( i502er.gt.0 ) call a502er ('sbcond'                          &
     &                      ,'job aborted due to previous errors. q.v.')
      return
      END subroutine sbcond
! **deck scmpkt
      subroutine scmpkt(a,i,m,n)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  combine columns of matrix which are mapped into the same     *
!     *  index by an index map. then compact columns and index map.   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  cycle through columns in order. for a given column cycle     *
!     *  through remaining columns to find members of its equivalence *
!     *  class. use vadd to add column vector of subsequent member    *
!     *  to given member and then delete subsequent member from class.*
!     *  compact non-deleted columns using incremental 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                   *
!     *                                                               *
!     *   a         argument  in/output given matrix                  *
!     *                                                               *
!     *   i         argument  in/output index map whose domain is the *
!     *                                 column indices of a           *
!     *                                                               *
!     *   m         argument  input     number of rows in a           *
!     *                                                               *
!     *   n         argument  in/output number of columns in a        *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension a(m,n),i(n)
!c
!     *  cycle through columns in order. for a given column cycle     *
!     *  through remaining columns to find members of its equivalence *
!     *  class. use vadd to add column vector of subsequent member    *
!     *  to given member and then delete subsequent member from class.*
!
      do 600 k=2,n
      if(i(k).eq.0) go to 600
      km1=k-1
      do 500 l=1,km1
      if(i(l).ne.i(k)) go to 500
      call vadd(a(1,l),1.d0,a(1,k),a(1,l),m)
      i(k)=0
      go to 600
  500 continue
  600 continue
!c
!     *  compact non-deleted columns using incremental index.         *
!
      j=0
      do 800 k=1,n
      if(i(k).eq.0) go to 800
      j=j+1
      i(j)=i(k)
      call dcopy (m,a(1,k),1,a(1,j),1)
  800 continue
      n=j
      return
      END subroutine scmpkt
! **deck scntrl
      subroutine scntrl
      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 control point defining quantities                 *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!c
!     *  compute control point defining quantities                    *
!
!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
!
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
      nw      =   300000
      call setcor ('scntrl')
      call getcor ('za'  ,llza  ,3*maxcp)
      call getcor ('taue',lltaue,  mxempt)
      call igtcor ('ia'  ,llia  ,  maxcp)
      call igtcor ('mapb',llmapb,  maxcp)
      call igtcor ('mapc',llmapc,  maxcp)
!
      call igtcor ('locf',lllocf,  maxcp)
      call igtcor ('iama',lliama,  maxcp)
      call igtcor ('key' ,llkey,   maxcp)
      call igtcor ('keyi',llkeyi,  maxcp)
!
      call igtcor ('nedm',llnedm,4*mxnett+1)
      call igtcor ('nfsg',llnfsg,4*mxnett+1)
      call igtcor ('kfsg',llkfsg,4*mxfdsg)
      call igtcor ('neda',llneda,  mxnabt+1)
      call igtcor ('ifsg',llifsg,2*mxfdsg)
!
      call igtcor ('mcmp',llmcmp,  mxfdsg)
      call igtcor ('mtch',llmtch,4*mxnabt)
      call igtcor ('kemp',llkemp,  mxempt)
      call igtcor ('nbra',llnbra,  mxnai)
      call igtcor ('ksgn',llksgn,  mxfdsg)
      call igtcor ('iedg',lliedg,4*mxnett)
!
      call tcntrl (w(llza),w(lltaue),w(llia),w(llmapb),w(llmapc)        &
     &     ,w(lllocf),w(lliama),w(llkey),w(llkeyi)                      &
     &     ,w(llnedm),w(llnfsg),w(llkfsg),w(llneda),w(llifsg)           &
     &     ,w(llmcmp),w(llmtch),w(llkemp),w(llnbra),w(llksgn),w(lliedg))
!c
!     *  print out job status and cost for step just completed        *
!
      call frecor ('scntrl')
      call cstprt ('cntrl pt')
      return
!---  return
      END subroutine scntrl
! **deck sdcopy
      subroutine sdcopy (n,  s,is,  d,id)
      real s(1)
      double precision d(1)
      ls = 1
      if ( is.lt.0 ) ls = 1 + iabs(is)*(n-1)
      ld = 1
      if ( id.lt.0 ) ld = 1 + iabs(id)*(n-1)
      do 100 k = 1,n
         d(ld) = s(ls)
         ld = ld + id
         ls = ls + is
  100 continue
      return
      END subroutine sdcopy
! **deck sectnp
      subroutine sectnp (zm,isrnt,isrsr,iduser                          &
     &                  ,ips,ipvf,array,prcoef                          &
     &                  ,mxgrpn,mxgrnt,mxntpn,indtrc                    &
     &                  ,itcsa,ntrnet,isinfo,ntrstr,netind              &
     &                  ,nmgp,nngp,npagp,mxpan,itvf)
!
      implicit double precision (a-h,o-z)
!
!     --------------------- purpose of routine ------------------------
!
!
!     *    compute sectional properties for specified cutting planes  *
!c    *                   * * *  m e t h o d  * * *                   *
!     * prcoef contains data for each network that will participate in*
!     * the sectional properties calculation.  certain wakes are      *
!     * excluded (type 18 and 20) and all networks for which          *
!     * netdat(igrps,netwrk,1) = 0.  all included networks have the   *
!     * appropriate array filled with the total number of panels for  *
!     * that network, i.e.,                                           *
!     * netdat(igrps,netwrk,1) =       rows * columns   .  some of the*
!     * elements of prcoef may not have useful data because the       *
!     * indexing scheme is the same as the panel index scheme within  *
!     * the rest of tranair.
!
!     --------------------- formal parameter list ---------------------
!
!
!     zm : coordinate of corner points
!
      dimension zm(3,*)
!
      character*10 iduser(nnett)
!
!      array : sectional properties for cut  *
!      prcoef : pressure coefficients data for networks in a group
!
      dimension array(21,*)
      dimension prcoef(3,mxpan,numgrp)
!
      dimension ips(mxgrpn),ipvf(2,mxntpn),isrnt(nnett)
      dimension itvf(2*indtrc*mxgrnt)
!
      dimension itcsa(*),ntrnet(mxgrnt),isinfo(4,mxgrnt*indtrc)
      dimension ntrstr(mxgrnt*indtrc)
      dimension nmgp(mxgrnt),nngp(mxgrnt),npagp(mxgrnt+1)
      dimension netind(2,indtrc*mxgrnt)
      character*5 isrsr(nnett)
!     --------------------- labelled common blocks --------------------
!
!
!     freastream angles
!
!     alpha (i) : angle of attack for i th casse
!     beta(i) : sideslip angle for i th case
!     fsvm(i) : free stream magnitude for i th casse
!     fsvm(3,i) : free stream velocity coordinates for i th casse
!
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!
!     panel defining quantities
!
!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
!
!     network quantities
!                                                                    ...
!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
!
!      igrps  : group number (often used as an index)
!      numgrp : number of groups of sectional properties
!
!      actfx :
!      cutdat : data about the cut within  a group
!      isecpr : turns on diagnostic printout if '1.0'
!      ixyzop : option for use of x or y or z for chord calculation
!      netdat : data about the network's part in the group
!      numcut : number of cuts in the group
!      numnet : number of networks in a group
!      numscd : output number of pressure surface conditions
!      optcrd :  option for chord value
!      optmrp : option for moment reference point
!      xyzlim : x,y,z minimum and maximum values
!
!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
!
!
!     reference parameters
!
!     xref : x coordinate of the reference point for the moment
!     yref : y coordinate of the reference point for the moment
!     zref : z coordinate of the reference point for the moment
!     sref : refrenece area
!     bref : reference length for moment about x axis
!     cref : reference length for moment about y axis
!     dref : reference length for moment about z  axis
!call fmcof
      common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof
!end  fmcof
!
!
!     scratch common block used in sectional properties.
!
!      igrps  : group number (often used as an index)
!      netwrk : network number (an index)
!call secscr
      common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin  &
     &             , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2)
!end  secscr
!call ncons
      common /ncons/ pi,pi2,pi4i,twopi,pio2
!end  ncons
!call titles
      common /titles/ title1(20),title2(20)
      character*4 title1, title2
!end  titles
!
!
!     --------------------- local array declarations ------------------
!
!
      dimension icard(33)
      logical first
      logical intsec
      save alpbet
      save first
!
      character*26 alpbet
      data alpbet /'abcdefghijklmnopqrstuvwxyz'/
!
      data first /.true./
!
!     --------------------- executable code ---------------------------
!
!     set initial variables
!
      epssec = 1.0d-6
      nout = 6
!
!     calculate flight path angles
!
      ra   = pi/180.d0
      sina = sin(ra*alpha(iacase))
      cosa = cos(ra*alpha(iacase))
      sinb = sin(ra*beta(iacase))
      cosb = cos(ra*beta(iacase))
!
!     maximum total number of traces in a group
!
      mxtrac = mxgrnt * indtrc
!
!     these are temporary files opened only for sectnp
!
      ifil61=61
      open(ifil61,access='sequential',form='formatted',status='scratch')
      ifil62=62
      open(ifil62,access='sequential',form='formatted',status='scratch')
      ifil63=63
      open(ifil63,access='sequential',form='formatted',status='scratch')
      npspfl = 64
      open (unit=npspfl,file='iflggp',status='unknown')
      npspg = 65
      open (unit=npspg,file='ispggp',status='unknown')
      iprtst = 1
!                                                                     se
      write(nout,7900)
 7900 format('1')
!
      if ( first )                                                      &
     &    write (npspg,8144)  (title1(i),i=1,18), (title2(i),i=1,18)
 8144 format ( '(i14,6f16.6,/,3x,f11.6,6f16.6)'                         &
     &  ,/,   '*dupt'                                                   &
     &  ,/,   '$',18a4                                                  &
     &  ,/,   '$',18a4                                                  &
     &  ,/,   '$','sectional forces'                                    &
     &  ,/,   '*dup'                                                    &
     &   )
!
!     loop on groups
      do 3000 igrps=1,numgrp
!
!     set local print flags
      igrprt = 1
      icutpr = 1
      rewind ifil61
      if( iprtnf(igrps) .eq. 1 ) rewind ifil62
      if( iprtpp(igrps) .eq. 1 ) rewind ifil63
!
      write(npspg,8239) iacase, igrps
 8239 format('c',i1,'.',i1)
!
      if ( first ) write(npspg,8145)
!
!       loop on cutting planes
        do 2000 icut=1,numcut(igrps)
!
          if (iprtst .eq.   1) call bmark('section ')
          iprtst   = 0
!
!         initialize accumulated cut data
          cfxtot = 0.d0
          cfytot = 0.d0
          cfztot = 0.d0
          cmxtot = 0.d0
          cmytot = 0.d0
          cmztot = 0.d0
          cfttot = 0.d0
          cfrtot = 0.d0
          cfntot = 0.d0
          totmom = 0.d0
          totcut = 0.d0
          clcoct = 0.d0
!
!         initialize maximum and minimum cut values
          xrmin =  1.d+10
          yrmin =  1.d+10
          zrmin =  1.d+10
          xrmax = -1.d+10
          yrmax = -1.d+10
          zrmax = -1.d+10
!
          xc  = cutdat(1,igrps,icut)
          yc  = cutdat(2,igrps,icut)
          zc  = cutdat(3,igrps,icut)
!
          xcn = cutdat(4,igrps,icut)
          ycn = cutdat(5,igrps,icut)
          zcn = cutdat(6,igrps,icut)
!
          xcntst = xcn
          ycntst = ycn
          zcntst = zcn
!
          pdist = xc*xcn + yc*ycn + zc*zcn
!
          if (pdist .lt. 0.d0) then
             xcntst =   -xcn
             ycntst =   -ycn
             zcntst =   -zcn
             pdist = -pdist
           endif
!
!          construct special coordinate system
!          cl - perpindicular to freestream in cut plane
!               (cross product of freestream into cut plane normal)
!          cy - along cut plane normal vector
!          cd - perpindicular to cl in cut plane
!               (cross product of cut plane normal into cl vector)
!
           unnorm = (-cosa*sinb*zcn -      sina*ycn )**2 +              &
     &              (      sina*xcn - cosa*cosb*zcn )**2 +              &
     &              ( cosa*cosb*ycn + cosa*sinb*xcn )**2
!
           if( unnorm .gt. 1.d-6 ) unnorm = 1.d0/sqrt(unnorm)
!
           tx   = unnorm*(-cosa*sinb*zcn -      sina*ycn)
           ty   = unnorm*(      sina*xcn - cosa*cosb*zcn)
           tz   = unnorm*( cosa*cosb*ycn + cosa*sinb*xcn)
!
           rx   = unnorm*( ( cosa*cosb*ycn + cosa*sinb*xcn)*ycn -       &
     &                     (      sina*xcn - cosa*cosb*zcn)*zcn   )
           ry   = unnorm*( (-cosa*sinb*zcn -      sina*ycn)*zcn -       &
     &                     ( cosa*cosb*ycn + cosa*sinb*xcn)*xcn   )
           rz   = unnorm*( (      sina*xcn - cosa*cosb*zcn)*xcn -       &
     &                     (-cosa*sinb*zcn -      sina*ycn)*ycn   )
!
!
! ---     *** diagnostic printout
! ---     if( isecpr(igrps) .eq. 1) write(nout,9000) pdist
!9000     format(' pdist= ',e15.6)
! ---     end diagnostic printout ***
!
!         initialize the trace array, array
          call zero (array,21*mxgrpn)
!
!         *****************************************************
!
          kcut     = 0
          npagp(1) = 0
          nntcut   = 0
          ntra     = 0
          itcsa(1) = 0
!
!         loop on networks
          do 400 netwrk=1,nnett
!
            if( netdat(igrps,netwrk,1) .eq. 0 ) go to 400
!
!           set up group network indexing
!
            nntcut = nntcut + 1
            nmgp(nntcut) = nm(netwrk)
            nngp(nntcut) = nn(netwrk)
            npagp(nntcut+1) = npagp(nntcut) + npa(netwrk+1) -           &
     &                        npa(netwrk)
!
!           set up for the determination of whether the plane can
!           intersect the network
!
            xmaxp = xyzlim(netwrk,1,2)
            ymaxp = xyzlim(netwrk,2,2)
            zmaxp = xyzlim(netwrk,3,2)
            xminp = xyzlim(netwrk,1,1)
            yminp = xyzlim(netwrk,2,1)
            zminp = xyzlim(netwrk,3,1)
!
            dist11 = xminp*xcntst + yminp*ycntst + zminp*zcntst - pdist
            dist12 = xmaxp*xcntst + ymaxp*ycntst + zmaxp*zcntst - pdist
            dist21 = xminp*xcntst + ymaxp*ycntst + zmaxp*zcntst - pdist
            dist22 = xmaxp*xcntst + yminp*ycntst + zminp*zcntst - pdist
            dist31 = xmaxp*xcntst + yminp*ycntst + zmaxp*zcntst - pdist
            dist32 = xminp*xcntst + ymaxp*ycntst + zminp*zcntst - pdist
            dist41 = xmaxp*xcntst + ymaxp*ycntst + zminp*zcntst - pdist
            dist42 = xminp*xcntst + yminp*ycntst + zmaxp*zcntst - pdist
!
!           test whether intersection of the network with the
!           cutting plane is possible
!
            if ((dist11*dist12 .le. 0.d0)  .or.                         &
     &          (dist21*dist22 .le. 0.d0)  .or.                         &
     &          (dist31*dist32 .le. 0.d0)  .or.                         &
     &          (dist41*dist42 .le. 0.d0)) then
!
!              trace across net for entry and exit pts of cutting plane
!              on each panel
!
               nmk    = nm(netwrk)
               nnk    = nn(netwrk)
               nzk    = nza(netwrk) + 1
               npak   = npa(netwrk)
               npakgp = npagp(nntcut)
!
               call trace(zm(1,nzk),nmk,nnk,npak,npakgp,                &
     &              array,xcntst,ycntst,zcntst,pdist,intsec)
!
               if (intsec) then
                  kcut=1
!
!                 sort panel data
!
                  call sortpn (netwrk,nntcut,nmk,nnk,npakgp,epssec,ipvf &
     &                      ,itcsa,ips,array,ntra,ntrnet(nntcut),netind &
     &                      ,nout)
!
                else
                   ntrnet(nntcut) = 0
                endif
!
             else
                ntrnet(nntcut) = 0
             endif
!
  400     continue
!
!         error - no intersection found - go to next cut
!
          if(kcut.eq.0) then
             write(nout,6543)igrps,icut
 6543        format(//,' *****************warning*****************',//  &
     &              ,' program failed to intesect any of the'           &
     &              ,' active networks for this cut!!',/                &
     &              ,' group number = ',i5,' cut number = ',i5,/        &
     &           ,//,' *****************warning*****************',//)
             go to 2000
          endif
!
!         sort the traces to generate strings
!
          call sorttr(epssec,itcsa,ips,array,itvf,ntra,ntrstr,          &
     &                numstr,isinfo,nout)
!
!         compute chord
!
!         delta between max and min points in coord direction of choice
          if (nint(optcrd(igrps)) .eq. 0) then
            if( ixyzop(igrps) .eq. 1 ) chrd = abs( xrmax - xrmin )
            if( ixyzop(igrps) .eq. 2 ) chrd = abs( yrmax - yrmin )
            if( ixyzop(igrps) .eq. 3 ) chrd = abs( zrmax - zrmin )
!
!         distance between max and min points
          elseif (nint(optcrd(igrps)) .eq. 1) then
            chrd =                                                      &
     &       sqrt((xrmax-xrmin)**2+(yrmax-yrmin)**2+(zrmax-zrmin)**2)
!
!         user input - cut plane point
          elseif (nint(optcrd(igrps)) .eq. 2) then
             chrd = cutdat(7,igrps,icut)
!
!         when all else fails, set it to one
          elseif (chrd .le. 0.d0) then
             chrd = 1.0d0
          endif
!
!         moment reference
!
!         user input
          if(nint(optmrp(igrps)) .eq. 2) then
             xr   = cutdat(1,igrps,icut)
             yr   = cutdat(2,igrps,icut)
             zr   = cutdat(3,igrps,icut)
!
!         fraction of computed chord
          elseif(nint(optmrp(igrps)) .eq. 1) then
             refrac = cutdat(8,igrps,icut)
             xr   = xrmin + refrac*(xrmax-xrmin)
             yr   = yrmin + refrac*(yrmax-yrmin)
             zr   = zrmin + refrac*(zrmax-zrmin)
!
!         configuration reference
          elseif(nint(optmrp(igrps)) .eq. 0) then
             xr   = xref
             yr   = yref
             zr   = zref
          endif
!
! --------------------- generate file headers --------------------
!
!     write banner for cut definitions and reference data on unit 6
!
      if( igrprt .eq. 1) write(nout,8025) iacase, igrps
 8025 format('0',11x,                                                   &
     & 'sectional properties - cut definitions and reference data',     &
     & ', solution number ',i4,', group no. ',i4,/)
!     write banner for forces and moments on unit 7 (=ifil61)
      if( igrprt .eq. 1) write(ifil61,8027) iacase, igrps
 8027 format('1',17x,                                                   &
     & 'sectional properties - cut force and moment data',              &
     & ', solution number ',i4,', group no. ',i4,/)
!
!     write banner for forces and moments on unit 8 (=ifil62)
!
      if( igrprt .eq. 1) write(ifil62,8133) iacase, igrps
 8133 format('1',17x,                                                   &
     & 'sectional properties - network force and moment data',          &
     & ', solution number ',i4,', group no. ',i4,/)
!
!     write banner for forces and moments on unit 9 (=ifil63)
!
      if( igrprt .eq. 1) write(ifil63,8227) iacase, igrps
 8227 format('1',17x,                                                   &
     & 'sectional properties - panel force and moment data',            &
     & ', solution number ',i4,', group no. ',i4,/)
!
!     if requested, write header to output file for panel information
!
      igrprt = 0
      etaref = refeta(igrps)
      if( etaref .eq. 0.0d0 ) etaref = 1.0d0
      if( icutpr .eq. 1   ) write(nout,8030) etaref
 8030 format('0','reference length for eta = ',f20.5,/,                 &
     & '0','cut no.',8x,'eta',9x,'xc',9x,'yc',9x,'zc',                  &
     &               8x,'xcn',8x,'ycn',8x,'zcn',                        &
     &               9x,'xr',9x,'yr',9x,'zr',6x,'chord',/)
!
!     if requested, print cut information
!
      if (icutpr .ne. 0) then
!        write "totals for cuts"
         write(ifil61,8127)
 8127    format('0','force (x,y,z) and moment ',                        &
     &    '(x,y,z) in global coordinates.',/,                           &
     &    ' force (l,d) in cut plane. force (n) ',                      &
     &    'normal to cut plane. '                                       &
     &,/,'   direction of positive cl is: free stream vector crossed '  &
     &  ,'into the cut plane normal'                                    &
     &,/,'   direction of positive cn is: same as cut plane normal'     &
     &,/,'   direction of positive cd is: cut plane normal crossed '    &
     &  ,'into the lift (cl) vector'                                    &
     &,/,' sectional moment normal to cut.',/)
!
!        write banner for cut totals
         write(ifil61,8128)
 8128    format(                                                        &
     &    '0',7x,'    cut no.',9x,'    cfx',9x,'    cfy',9x,            &
     &    '    cfz',8x,'     cmx',8x,'     cmy',8x,'     cmz',/,        &
     &    16x,'eta',6x,'       cdc',9x,'    cnc',9x,'    clc',          &
     &    2x,'clc*chord/cref',2x,'           cmc',2x,'    cut-length')
!
         write(ifil61,8052)
 8052    format(3x,7(4x,'------------'),/)
!
      endif
!
!     write banner for network totals
!
      write(ifil62,8134) icut
 8134 format('0','cut number ',i4,/,                                    &
     & '0',7x,'network no.',9x,'    cfx',9x,'    cfy',9x,               &
     & '    cfz',8x,'     cmx',8x,'     cmy',8x,'     cmz',/,           &
     & 23x,2x,'       cdc',9x,'    cnc',9x,'    clc',                   &
     & 2x,'clc*chord/cref',2x,'           cmc',2x,'    cut-length')
      write(ifil62,8052)
!
!     write banner for panel totals
!
      write(ifil63,8234) icut
 8234 format('0','cut number ',i4,/,                                    &
     & '0',1x,'net no.',2x,'panel no.',                                 &
     & '             x',                                                &
     & '             y',                                                &
     & '             z',                                                &
     & '            cp',                                                &
     & '           fxp',                                                &
     & '           fyp',                                                &
     & '           fzp',                                                &
     & '   cut-segment')
      write(ifil63,8053)
 8053 format(2x,'-------',2x,'---------',8(2x,'------------'),/)
!
 8145 format(                                                           &
     & 4x,'   cut-no.',9x,'    cfx',9x,'    cfy',9x,                    &
     & '    cfz',8x,'     cmx',8x,'     cmy',8x,'     cmz','  more',/,  &
     & ' ',10x,'eta',9x,'    cdc',9x,'    cnc',9x,'    clc',            &
     & 2x,'clc*chord/cref',2x,'           cmc',2x,'    cut-length')
!
      icutpr = 0
!
!     compute the span factor, eta
       if((cutdat(9,igrps,icut).eq.0.d0).and.(refeta(igrps).eq.0.d0))   &
     &    eta =  yc
       if((cutdat(9,igrps,icut).ne.0.d0).and.(refeta(igrps).eq.0.d0))   &
     &   eta =  cutdat(9,igrps,icut)
       if((cutdat(9,igrps,icut).eq.0.d0).and.(refeta(igrps).ne.0.d0))   &
     &    eta =  yc/refeta(igrps)
       if((cutdat(9,igrps,icut).ne.0.d0).and.(refeta(igrps).ne.0.d0))   &
     &     eta =  cutdat(9,igrps,icut)/refeta(igrps)
!
      write(nout,8040) icut, eta, xc, yc, zc,                           &
     &                    xcn, ycn, zcn, xr, yr, zr, chrd
 8040 format(1x,i7,11(1x,1pe10.3))
!
! -------------------- end of banner section ------------------------
!
! -------------------- calculate forces and print -------------------
!
          nntcut = 0
          itrano = 0
!
          do 1000 netwrk=1,nnett
!
            if( netdat(igrps,netwrk,1) .eq. 0 ) go to 1000
!
            nntcut = nntcut + 1
            if(ntrnet(nntcut) .eq. 0) go to 1000
!
!           initialize the resolved forces and secmom on network
!
            cfx    = 0.d0
            cfy    = 0.d0
            cfz    = 0.d0
            cmx    = 0.d0
            cmy    = 0.d0
            cmz    = 0.d0
            cft    = 0.d0
            cfr    = 0.d0
            cfn    = 0.d0
            secmom = 0.d0
            cutnet = 0.d0
!
            write(ifil63,8235) netwrk,                                  &
     &      iduser(netwrk)
 8235       format('0',4x,i4,2x,a)
!
!
! ---       diagnostic printout ***
! ---       if( isecpr(igrps) .eq. 1 )
! ---1      write(nout,5000) alpha(iacase),sina,cosa,
! ---2                     beta(iacase),sinb,cosb
!5000       format(1h ,7halpha= ,e15.6,6hsina= ,e15.6,6hcosa= ,e15.6,
! ---1                 6hbeta= ,e15.6,6hsinb= ,e15.6,6hcosb= ,e15.6)
! ---       end diagnostic printout ***
!
!
!           calculate forces on cut panels in this network
!
            nmk    = nm(netwrk)
            nnk    = nn(netwrk)
            npak   = npa(netwrk)
            npakgp = npagp(nntcut)
            npank = (nmk-1)*(nnk-1)
            call integr(npank,array(1,npakgp+1),                        &
     &                  prcoef(1,npak+1,igrps),                         &
     &                  netdat(igrps,netwrk,2))
!
!           dump data for traces on this network
!
            do 510 itnont = 1,ntrnet(nntcut)
!
               itrano = itrano + 1
               netgl  = netwrk
               netgp  = nntcut
!
!              loop on panels
!
               do 500 jp = itcsa(itrano)+1,itcsa(itrano+1)
!
!                panel index in group, network and global reference
                 ipgp = ips(jp)
                 ipgl = ipgp - npagp(netgp) + npa(netgl)
                 ipnt = ipgp - npagp(netgp)
!
!                compute resolved forces on network
!
                 cfx = cfx + array(15,ipgp)
                 cfy = cfy + array(16,ipgp)
                 cfz = cfz + array(17,ipgp)
                 cmx = cmx + array(18,ipgp)
                 cmy = cmy + array(19,ipgp)
                 cmz = cmz + array(20,ipgp)
!
                 cft = cft +                                            &
     &             (   array(15,ipgp) * tx   +                          &
     &                 array(16,ipgp) * ty   +                          &
     &                 array(17,ipgp) * tz    )
                 cfr = cfr +                                            &
     &             (   array(15,ipgp) * rx   +                          &
     &                 array(16,ipgp) * ry   +                          &
     &                 array(17,ipgp) * rz    )
                 cfn = cfn +                                            &
     &             (   array(15,ipgp) * xcn  +                          &
     &                 array(16,ipgp) * ycn  +                          &
     &                 array(17,ipgp) * zcn   )
!
!                compute moment on network
!
                 secmom = secmom +                                      &
     &                  ( xcn*array(18,ipgp)+ycn*array(19,ipgp)+        &
     &                    zcn*array(20,ipgp) )
!
!                compute total cut length on network
!
                 cutloc = array(21,ipgp)
                 cutnet = cutnet + cutloc
!
!
!                write totals for each panel of the network
!
!
                 panelx = (array(2,ipgp) + array(5,ipgp))/2.d0
                 panely = (array(3,ipgp) + array(6,ipgp))/2.d0
                 panelz = (array(4,ipgp) + array(7,ipgp))/2.d0
                 pancpi = prcoef(1,ipgl,igrps) +                        &
     &                    prcoef(2,ipgl,igrps)*array(8,ipgp) +          &
     &                    prcoef(3,ipgl,igrps)*array(9,ipgp)
                 pancpo = prcoef(1,ipgl,igrps) +                        &
     &                    prcoef(2,ipgl,igrps)*array(10,ipgp) +         &
     &                    prcoef(3,ipgl,igrps)*array(11,ipgp)
                 panlcp = (pancpi + pancpo)/2.d0
!
                 write(ifil63,8250) ipnt, panelx, panely, panelz,       &
     &           panlcp,array(15,ipgp),array(16,ipgp),                  &
     &           array(17,ipgp),cutloc
 8250            format(14x,i6,8(1x,1pe13.5))
!
! ---            diagnostic printout ***
                 if( isecpr(igrps) .eq. 1 ) then
!                   --------------------------------------------------
!                   the following writes are used only for diagnostics
!                   --------------------------------------------------
! ---               write " panel # "
                    write(nout,8080) ipnt
 8080               format('0',10x,'panel number ',i5)
!                   write   panel data
                    write(nout,8090)                                    &
     &                    array( 2,ipgp),array( 3,ipgp),                &
     &                    array( 4,ipgp),array( 5,ipgp),array( 6,ipgp), &
     &                    array( 7,ipgp),array(12,ipgp),array(13,ipgp), &
     &                    array(14,ipgp)
 8090               format('0',10x,                                     &
     &                     'global geometry: x, y, z, x, y, z, nx, ',   &
     &                     'ny, nz',/,6x,9e14.6)
                    write(nout,8100)                                    &
     &                    array( 8,ipgp),array( 9,ipgp),array(10,ipgp), &
     &                    array(11,ipgp), array(21,ipgp),               &
     &                    prcoef(1,ipgl,igrps),prcoef(2,ipgl,igrps),    &
     &                    prcoef(3,ipgl,igrps)
 8100               format('0',10x,                                     &
     &                     'local geometry : x, y, x, y, cutloc, co',   &
     &                     ' cx, cy',/,8x,8e14.6)
                    write(nout,8110)                                    &
     &                    array(15,ipgp),array(16,ipgp),                &
     &                    array(17,ipgp),array(18,ipgp),array(19,ipgp), &
     &                    array(20,ipgp)
 8110               format('0',10x,'force and moment:fx,fy,fz,mx,my,mz',&
     &              /,8x,8e14.6)
! ---               ------------------------------------------------
! ---            end diagnostic printout ***
                 endif
!
  500         continue
  510       continue
!
            clcoc = (cft * chrd / cref)
!
!     write totals for each network of the cut
!
      write(ifil62,8150) netwrk,cfx,cfy,cfz,                            &
     &                        cmx,cmy,cmz
 8150 format(5x,i14,6f16.6)
      write(ifil62,8151) cfr,cfn,cft,clcoc,secmom,cutnet
 8151 format(19x,6f16.6,/)
!
!           accumulate network totals to build cut totals
            cfxtot = cfxtot + cfx
            cfytot = cfytot + cfy
            cfztot = cfztot + cfz
            cmxtot = cmxtot + cmx
            cmytot = cmytot + cmy
            cmztot = cmztot + cmz
!
            cfttot = cfttot + cft
            cfrtot = cfrtot + cfr
            cfntot = cfntot + cfn
            totmom = totmom + secmom
            totcut = totcut + cutnet
            clcoct = clcoct + clcoc
!
! ------------------- end loop on networks ---------------------
!
 1000     continue
!
!     write totals for each cut of the group
!
      write(ifil61,8140) icut,cfxtot,cfytot,cfztot,                     &
     &                        cmxtot,cmytot,cmztot
 8140 format(5x,i14,6f16.6)
      write(ifil61,8141) eta, cfrtot, cfntot,                           &
     &                   cfttot, clcoct, totmom, totcut
 8141 format(3x,7f16.6,/)
!
      write(npspg,8146) icut,cfxtot,cfytot,cfztot,                      &
     &                        cmxtot,cmytot,cmztot
 8146 format(4x,i10,6f16.6)
!
      write(npspg,8147) eta,cfrtot,cfntot,cfttot,clcoct,totmom,totcut
 8147 format(3x,f11.6,6f16.6)
!
!     generate ggp file for strings
!
!
!     ggp file of strings
!
!
      if ( first )                                                      &
     &    write (npspfl,8241)  (title1(i),i=1,18), (title2(i),i=1,18)
 8241 format ('(5(1pe13.5))'                                            &
     &  ,/,   '*dupt'                                                   &
     &  ,/,   '$',18a4                                                  &
     &  ,/,   '$',18a4                                                  &
     &  ,/,   '$','sectional pressures'                                 &
     &  ,/,   '*dup'                                                    &
     &   )
!
      ipos = 0
!
      do 1100 istr = 1,numstr
         write(npspfl,8240)alpbet(igrps:igrps), icut, alpbet(istr:istr),&
     &                    iacase
 8240    format('c',a1,i2.2,a1,i1)
!
         if (first) then
            if( ixyzop(igrps) .eq. 1 ) write(npspfl,8242)
            if( ixyzop(igrps) .eq. 2 ) write(npspfl,8243)
            if( ixyzop(igrps) .eq. 3 ) write(npspfl,8244)
 8242       format('            x','            y','            z',     &
     &       '          x/c', '           cp')
 8243       format('            x','            y','            z',     &
     &       '          y/c', '           cp')
 8244       format('            x','            y','            z',     &
     &       '          z/c', '           cp')
            first = .false.
         endif
!
         do 1120 itra = 1,ntrstr(istr)
            ipos = ipos + 1
            netgl = netind(1,isinfo(1,ipos))
            netgp = netind(2,isinfo(1,ipos))
            do 1110 ipct = isinfo(2,ipos),isinfo(3,ipos),               &
     &                     isinfo(4,ipos)
!
!              panel index in group and global reference
               ipgp = ips(ipct)
               ipgl = ipgp - npagp(netgp) + npa(netgl)
!
               panelx = (array(2,ipgp) + array(5,ipgp))/2.d0
               panely = (array(3,ipgp) + array(6,ipgp))/2.d0
               panelz = (array(4,ipgp) + array(7,ipgp))/2.d0
               pancpi = prcoef(1,ipgl,igrps) +                          &
     &                  prcoef(2,ipgl,igrps)*array(8,ipgp) +            &
     &                  prcoef(3,ipgl,igrps)*array(9,ipgp)
               pancpo = prcoef(1,ipgl,igrps) +                          &
     &                  prcoef(2,ipgl,igrps)*array(10,ipgp) +           &
     &                  prcoef(3,ipgl,igrps)*array(11,ipgp)
               panlcp = (pancpi + pancpo)/2.d0
               if( ixyzop(igrps) .eq. 1 ) xpanel = (panelx-xrmin)/chrd
               if( ixyzop(igrps) .eq. 2 ) xpanel = (panely-yrmin)/chrd
               if( ixyzop(igrps) .eq. 3 ) xpanel = (panelz-zrmin)/chrd
               write(npspfl,8251) panelx, panely, panelz, xpanel, panlcp
 8251          format(5(1pe13.5))
!
 1110       continue
 1120    continue
!
         write(npspfl,8142)
 8142    format('*eof')
!
 1100 continue
!
!
!
!
! ---------------------- end loop on cutting planes ------------------
!
 2000   continue
!
      write(npspg,8142)
!
!     write trailing banner on unit 6
      kvals = 0
!
      do 920 j = 1, nnett
        if( netdat(igrps,j,1) .eq. 0 ) go to 910
        kvals = kvals + 1
        isrnt(kvals)=j
  910 continue
  920 continue
!
      if( kvals .gt. 0 ) write(nout,3900) igrps
 3900 format('0',///,1x,'group no.',i4,                                 &
     & '  uses the following networks (by number) and surface (surf)',  &
     & ' pressure distribution for computations:',/,/,                  &
     & 1x,'net no   net id       surface',/,                            &
     & 1x,'------   ----------   -------')
!
      do 940 j = 1, kvals
        if(netdat(igrps,isrnt(j),2).eq.1)isrsr(j)='upper'
        if(netdat(igrps,isrnt(j),2).eq.2)isrsr(j)='lower'
        if(netdat(igrps,isrnt(j),2).eq.3)isrsr(j)='difer'
  940 continue
!
      write(nout,4000)(isrnt(j),iduser(isrnt(j)),isrsr(j),j=1,kvals)

 4000 format(1x,i6,3x,a10,3x,a5)
      write(nout,8500)
 8500 format(///,1x,'note - the same pressure distribution used ',      &
     &      'in calculating the 3-d forces and ',                       &
     & /,8x,'moments is used to calculate the sectional ',              &
     &      'properties.  currently, the second'                        &
     &,/,8x,'order pressure coefficient is used without velocity '      &
     &     ,'corrections.'                                              &
     &,/)
!
!     copy ifil61 data to end of unit 6 for output
      endfile ifil61
      rewind ifil61
  950 read(ifil61,8600,end=960) icard
      write(nout,8600) icard
 8600 format(33a4)
      go to 950
!
!     copy ifil62 data to end of unit 6 for output
  960 if(iprtnf(igrps) .eq. 0) go to 962
      endfile ifil62
      rewind ifil62
  961 read(ifil62,8600,end=962) icard
      write(nout,8600) icard
      go to 961
  962 continue
!
!     copy ifil63 data to end of unit 6 for output
  970 if(iprtpp(igrps) .eq. 0) go to 972
      endfile ifil63
      rewind ifil63
  971 read(ifil63,8600,end=972) icard
      write(nout,8600) icard
      go to 971
  972 continue
!
! ---------------------- end loop on groups --------------------------
!
 3000 continue
!
!     the temporary files are closed here
!
      close(ifil61)
      close(ifil62)
      close(ifil63)
!     end loop on groups
!
      return
!
      END subroutine sectnp
! **deck setcor
      subroutine setcor (label)
      character*(*) label
!
!        establish a new level of dynamic memory, associated with the
!        character string 'label'.  the dynamic memory allocated subsequ
!        to this call will then be deallocated when frecor is called wit
!        the same 'label'.
!
!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
!                                  check for a reset
! **  write (6,7100) label
!--- 7100 format ( 1x, 27( 4h * /  ), ' setcor : ',a8 )
 7100 format ( 1x, 27( 4h * /  ), ' setcor : ',a )
      if ( iniset .ne. 'goodcore' ) go to 1000
      if ( levprt ) write (6,6200) label
!
      levdyn  =  levdyn + 1
      if ( levdyn .gt. maxlev ) CALL AbortPanair('setcor-1')
!
      chrlev(levdyn) = label
      maplev(1,levdyn) = maplev(1,levdyn-1) + maplev(2,levdyn-1)
      maplev(2,levdyn) = 0
      maplev(3,levdyn) = maplev(3,levdyn-1)
!
      mxxlev  =  max(mxxlev,levdyn)
      return
!
 1000 continue
      write (6,6500) label, iniset
      CALL AbortPanair('sngcor-2')
 6500 format (' *****  error  *****   setcor called before inicor.  labe&
     &l  =  ',a,'    status word  =  ',a)
!--- xl  =  ',a8,'    status word  =  ',a8)
!
 6200 format ('  setcor call : ',a)
!--- 6200 format ('  setcor call : ',a8)
      END subroutine setcor
! **deck setup
      subroutine setup(maxarr, ihmnst, neqn, ihmxst, mxorp1, mxorp2,    &
     &    itout, ireler, iabser, iphimx, iipos, ieps, irelps, iabsps,   &
     &    iptseq, icore, iy, it, iiflag, iyy, ip, iyp, iphi, ialpha,    &
     &    ibeta, isig, iv, iw, ig, iaphse, ipsi, ix, ih, ihold,         &
     &    iastrt, itold, idelsn, ins, iifail, ik, ikold, iicomp,        &
     &    iipts1, iipts2, istmln, itinp, iknew,                         &
     &    iicrsh,iacrsh, imordr, idumst, ipoten, numptx,                &
     &    mxordx, arr1, zof, pzof)
      implicit double precision (a-h,o-z)
!**
!**       this subroutine computes the location of various arrays
!**       in array arr1. all these locations get stored in array
!**       iwrk because of the way this subroutine is called
!**
!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
!ca cinout
!                                                           /cinout/
      common /cinout/ ntsin, ntsout
!end  cinout
      dimension arr1(maxarr), zof(3000), pzof(4000)
      data ncall/0/
!**
!**         start computing array locations
!**
      mxorp1 = mxordr + 1
      mxorp2 = mxordr + 2
      istmln = 1
      if ( numpts*ncassl .gt. 600 ) numpts = 600/ncassl
      itinp  =  istmln + 7*numpts*ncassl
      ireler = itinp + 1
      iabser = ireler + 1
      iphimx = iabser + 1
      iipos  = iphimx + 1
      irelps = iipos + 1
      iabsps = irelps + 1
      iptseq = 4*neqn + neqn*mxorp2 + 5*mxordr + mxorp1 + mxorp1 + 28
!**
!**        icore is the number of equations that can be worked on
!**        asynchronously.
!**
      icore = (mxarr1 - iabsps) / iptseq
      icore   =  min ( 200, icore)
!**
      iy = iabsps + 1
      it = iy + neqn*icore
      ihmnst = it + icore
      ihmxst = ihmnst + icore
      itout = ihmxst + icore
      imordr = itout + icore
      idumst = imordr + icore
      iiflag = idumst + 3*icore
      ipoten = iiflag + icore
      iyy    = ipoten + icore
      ip     = iyy + icore*neqn
      iyp    = ip +  icore*neqn
      iphi   = iyp + neqn*icore
      ialpha = iphi + neqn*mxorp2*icore
      ibeta  = ialpha + mxordr*icore
      isig   = ibeta  + mxordr*icore
      iv     = isig + mxorp1*icore
      iw     = iv + mxordr*icore
      ig     = iw + mxordr*icore
      iaphse = ig + mxorp1*icore
      ipsi   = iaphse + icore
      ix     = ipsi + icore*mxordr
      ih     = ix + icore
      ihold  = ih + icore
      iastrt = ihold + icore
      itold  = iastrt + icore
      idelsn = itold + icore
      ins    = idelsn + icore
      iifail = ins + icore
      ik     = iifail + icore
      ikold  = ik + icore
      iicomp = ikold + icore
      iipts1 = iicomp + icore
      iipts2 = iipts1 + icore
      iknew  = iipts2 + icore
      ieps = iknew + icore
      iicrsh = ieps + icore
      iacrsh = iicrsh + icore
      itotal = iacrsh + icore - 1
      write (ntsout,3300)
      write (ntsout,3000) icore, iptseq,iabsps,itotal
      write (ntsout,3250) nstmln, numpts, hmin, hmax, maxstm,           &
     &    mxordr, abserr, mxarr1, isprnt
!**
!**       write out arr1 map.  ncall flag is used so that the map is
!**       printed out only once.
!**
      if(ncall.ne.0) go to 100
        ncall = 1
      write (ntsout,3050)
      write (ntsout,3100) istmln, itinp, itout, ireler, iabser, iphimx, &
     &    iipos, irelps, iabsps, iy, it, iiflag, iyy, ip, iyp, iphi,    &
     &    ialpha, ibeta, isig, iv, iw, ig, iaphse, ipsi, ix, ih, ihold, &
     &    iastrt, itold, idelsn, ins, iifail, ik, ikold, iicomp,        &
     &    iipts1, iipts2, iknew, ieps, iicrsh, iacrsh, itotal,          &
     &    ihmnst, ihmxst, imordr, idumst, ipoten
      write (ntsout,3150)
      write (ntsout,3200) istmln, itinp, itout, ireler, iabser, iphimx, &
     &  iipos, irelps, iabsps, iy, it, iiflag, iyy, ip, iyp, iphi,      &
     &    ialpha, ibeta, isig, iv, iw, ig, iaphse, ipsi, ix, ih, ihold, &
     &    iastrt, itold, idelsn, ins, iifail, ik, ikold, iicomp,        &
     &    iipts1, iipts2, iknew, ieps, iicrsh, iacrsh, itotal,          &
     &    ihmnst, ihmxst, imordr, idumst, ipoten
  100 continue
      write (ntsout,3300)
!**
!**        locations computed. call setup1 for streamline computation.
!**
      call setup1(neqn, arr1(iy), arr1(it), arr1(itout), arr1(ireler),  &
     &    arr1(iabser), arr1(iiflag), arr1(iyy), arr1(ip), arr1(iyp),   &
     &    arr1(iphi), arr1(ialpha), arr1(ibeta), arr1(isig), arr1(iv),  &
     &    arr1(iw), arr1(ig), arr1(iaphse), arr1(ipsi), arr1(ix),       &
     &    arr1(ih), arr1(ihold), arr1(iastrt), arr1(itold),             &
     &    arr1(idelsn), arr1(ins), arr1(iifail), arr1(ik), arr1(ikold), &
     &    arr1(iicomp), arr1(iipts1), arr1(iipts2), arr1(iphimx),       &
     &    icore, arr1(iipos), mxorp1, mxorp2,                           &
     &    arr1(istmln), arr1(itinp), arr1(ieps), arr1(irelps),          &
     &    arr1(iabsps), arr1(iknew), arr1(iicrsh), arr1(iacrsh),        &
     &    arr1(ihmnst), arr1(ihmxst), arr1(imordr), arr1(idumst),       &
     &    arr1(ipoten), numptx, mxordx , zof, pzof)
!**
!**            format statements
!**
 3000 format(//5x,45hno. of streamlines in core        (icore ) = ,i5   &
     &        /5x,45hstorage reqd. per streamline      (iptseq) = ,i5   &
     &        /5x,45hglobal storage required.          (iabsps) = ,i5   &
     &        /5x,45hstorage required for array arr1   (itotal) = ,i5,  &
     &        5x,22h(+ 100 for array iwrk))
 3050 format(///36x,34h*** map of array arr1 in octal *** )
 3100 format(//9x,6histmln,7x,5hitinp,7x,5hitout,6x,6hireler,6x,        &
     &     6hiabser,6x,6hiphimx,7x,5hiipos,6x,6hirelps,6x,6hiabsps,     &
     &    10x,2hiy/5x,10(i10,2x)//13x,2hit,6x,6hiiflag,9x,3hiyy,10x,    &
     &    2hip,9x,3hiyp,                                                &
     &    8x,4hiphi,6x,6hialpha,7x,5hibeta,8x,4hisig,10x,2hiv           &
     &    /5x,10(i10,2x)//13x,                                          &
     &    2hiw,10x,2hig,6x,6hiaphse,8x,4hipsi,10x,2hix,10x,2hih,        &
     &    7x,5hihold,6x,6hiastrt,7x,5hitold,6x,6hidelsn                 &
     &    /5x,10(i10,2x)//12x,                                          &
     &    3hins,6x,6hiifail,10x,2hik,7x,5hikold,6x,6hiicomp,6x,         &
     &    6hiipts1,6x,6hiipts2,7x,5hiknew,8x,4hieps,6x,6hiicrsh         &
     &    /5x,10(i10,2x)//9x,6hiacrsh,6x,6hitotal,6x,6hihmnst,          &
     &    6x,6hihmxst, 6x,6himordr,                                     &
     &    6x,6hidumst,6x,6hipoten/5x,10(i10,2x))
 3150 format(///36x,44h*** map of array arr1 in decimal numbers ***)
 3200 format(//9x,6histmln,7x,5hitinp,7x,5hitout,6x,6hireler,6x,        &
     &     6hiabser,6x,6hiphimx,7x,5hiipos,6x,6hirelps,6x,6hiabsps,     &
     &    10x,2hiy/5x,10(i10,2x)//13x,2hit,6x,6hiiflag,9x,3hiyy,10x,    &
     &    2hip,9x,3hiyp,                                                &
     &    8x,4hiphi,6x,6hialpha,7x,5hibeta,8x,4hisig,10x,2hiv           &
     &    /5x,10(i10,2x)//13x,                                          &
     &    2hiw,10x,2hig,6x,6hiaphse,8x,4hipsi,10x,2hix,10x,2hih,        &
     &    7x,5hihold,6x,6hiastrt,7x,5hitold,6x,6hidelsn                 &
     &    /5x,10(i10,2x)//12x,                                          &
     &    3hins,6x,6hiifail,10x,2hik,7x,5hikold,6x,6hiicomp,6x,         &
     &    6hiipts1,6x,6hiipts2,7x,5hiknew,8x,4hieps,6x,6hiicrsh         &
     &    /5x,10(i10,2x)//9x,6hiacrsh,6x,6hitotal,6x,6hihmnst,          &
     &    6x,6hihmxst,6x,6himordr,                                      &
     &    6x,6hidumst,6x,6hipoten/5x,10(i10,2x))
 3250 format(//5x,45hnstmln, numpts, hmin, hmax                 = ,     &
     &     i5,3x,i5,2(3x,e13.5)                                         &
     &        /5x,45hmaxstm, mxordr, abserr, mxarr1, isprnt     = ,     &
     &     i5,3x,i5,3x,e13.5,5x,i5,2x,i4)
 3300 format(1h1)
!**
      return
      END subroutine setup
! **deck setup1
      subroutine setup1(neqn, y, t, tout, relerr, abserx, iflag, yy,    &
     &     p, yp,  phi, alpha, beta, sig, v, w, g, aphase,              &
     &    psi, x, h, hold, astart, told, delsgn, ns, ifail, k, kold,    &
     &     icomp, ipts1, ipts2, phimax,  icore,                         &
     &    ipos, mxorp1, mxorp2, stmln, tinp, eps, releps, abseps,       &
     &    knew, icrsh, acrash, hmnst, hmxst, mordr, dumst, poten,       &
     &    numptx, mxordx , zof, pzof)
      implicit double precision (a-h,o-z)
!
!         this subroutine along with setup breaks up the work array
!         passed to this overlay. the number of points for which
!         computations can be carried out asynchronously is computed
!         by these subroutines. this fact depends on the following
!         parameters.
!
!         mxordr - highest order adams-moulton method considere while
!                  integrating for streamlines
!
!         numpts - number of off-body points for which stream lines
!                  are to be computed.
!
!         icore  - computed based on size of work array, mxordr and
!                  numpts. icore is computed in setup and passed to
!                  this routine.
!
!         the program first reads in the coordinate of off body points
!         and initializes various flags. the program then setup the
!         logic so that step can be called.
!
!         mxorp1 = mxordr + 1
!         mxorp2 = mxordr + 2
!
!call solstr
      common /solstr/ iastr(600), iaxstr(200), ivzof(200)
!end  solstr
!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 irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!ca cinout
!                                                           /cinout/
      common /cinout/ ntsin, ntsout
!end  cinout
      dimension y(neqn,icore), t(icore), iflag(icore), yy(neqn,icore),  &
     &    p(neqn,icore), yp(neqn,icore),                                &
     &     phi(neqn,mxorp2,icore) , zof(3,icore), pzof(4,icore)
      dimension stmln(7,numptx)
      dimension alpha(mxordx, icore), beta(mxordx,icore),               &
     &    sig(mxorp1,icore), v(mxordx,icore), w(mxordx,icore),          &
     &    g(mxorp1,icore), aphase(icore), psi(mxordx,icore),            &
     &    x(icore), h(icore), hold(icore), astart(icore),               &
     &    told(icore), delsgn(icore), ns(icore),                        &
     &    k(icore), kold(icore), ifail(icore), icomp(icore),            &
     &    ipts1(icore), ipts2(icore), knew(icore), eps(icore),          &
     &    icrsh(icore), acrash(icore), poten(icore),                    &
     &    hmnst(icore), hmxst(icore), mordr(icore), dumst(3,icore)      &
     &    ,tout(icore)
!
!
!
      logical stiff, crash, start, phase1
      data fouru / 3.d-14 /
!
!         initialize and setup arrays. first set tout large so that
!         interpolation is never carried out
!
      call CPU_TIME(tb)
      if( isprnt .eq. 0 ) go to 10
      write(ntsout,5001) tb
 5001 format('   tb = ',f10.4,' time beginning step')
   10 relerr = 0.d0
!**
!**        rewind file 8
!**
      rewind ntsmln
!**
!**      read input on unit nti and record no. 18
!**
      call readmd (nti,stmln,nidq(18),18)
!
      lbstr   =  0
      do 20 ia = 1,4
          if ( indvsl(ia).eq.0 ) go to 20
          do 15 istr = 1,numpts
               iastr(istr+lbstr) = indvsl(ia)
   15     continue
          if ( lbstr.ne.0 ) call xfera (stmln,stmln(1,lbstr+1),7*numpts)
          lbstr   =  lbstr + numpts
   20 continue
      numpsv  =  numpts
      numpts  =  lbstr
!
!
!         set the value of eps
!
      ipos  = min (numpts,icore)
      do 50 i = 1, ipos
         icomp(i) = 1
         ipts1(i) = i
         ipts2(i) = 0
         iflag(i) = 1
          astart(i) = 1.d0
          t(i)      = 0.d0
          tout(i)=sign(1.0d+8,stmln(7,i))
          y(1,i)    = stmln(1,i)
          y(2,i)    = stmln(2,i)
          y(3,i)    = stmln(3,i)
         iaxstr(i) = iastr(i)
          hmnst(i) = 10000.d0
          hmxst(i) = -100000.d0
          mordr(i) = 0
          h(i) = hmin
          aphase(i) = 1.d0
          icrsh(i) = 0
          acrash(i) = -1.d0
   50 continue
!
!         if ipos.eq. numpts then all the off-body-points can be
!         worked on right away. in such a case if icore.gt. ipos
!         then we initialize icomp for then = 10 so that they are
!         not considered for computation.
!
      if(ipos.lt.numpts) go to 100
        ipos = ipos + 1
        if(ipos.gt.icore) go to 150
          do 75 i = ipos, icore
            icomp(i) = 10
   75     continue
          go to 150
!
!            all off-body points cannot be considered right away.
!            setup ipos pointer so that points can be considered as
!            position become available.
!
  100 continue
      ipos = ipos + 1
  150 continue
!
!         start computation and start loop
!
  200 continue
      kwork = 0
!
!        kwork = 0 indicats that all the streamlines have been
!        generated and there is no need for any more
!        computation.
!
      do 1000 i = 1,icore
      if( icomp(i) .ge. 9 ) go to 990
        kwork = 1
        if(iflag(i).eq.1.and.icomp(i).eq.1) go to 220
          start = astart(i).gt.0.d0
          phase1 = aphase(i).gt.0.d0
          crash = acrash(i).gt.0.d0
         go to 400
  220   continue
!**
!**           iflag(i).eq.1 indicates new computation for a new
!**           stream line.
!          set interval of integration (immaterial as the code is
!          used here since the program advances 1 step and check
!          t > phimax. if so computation stops.
!
  300     del=tout(i) - t(i)
         eps(i) =  max (relerr,abserr)
        absdel = abs(del)
        tend   = t(i) + 10.d0* del
        kle4   = 0
        releps = relerr / eps(i)
        abseps = abserr / eps(i)
!
!         on start and restart set work variables x and yy(*). store
!         the direction of integration and initialize the step size.
!
  330   start = .true.
        x(i) = t(i)
        do 340  l = 1,neqn
          yy(l,i) =  y(l,i)
  340   continue
        delsgn(i) = sign(1.d0,del)
        h(i) = sign( max (abs(tout(i)-x(i)),fouru*abs(x(i))),           &
     &              tout(i)-x(i))
  400  continue
!**
!**         call step. in step the execution starts at various points
!**         depending on the value of icomp. see documentation of
!**         step for further clarification.
!**
       iptr = i
      call step(neqn,t(i),relerr,abserx,iflag(i),                       &
     &    yy(1,i),  p(1,i), yp(1,i),  phi(1,1,i),                       &
     &    alpha(1,i), beta(1,i), sig(1,i), v(1,i), w(1,i), g(1,i),      &
     &    phase1, psi(1,i), x(i), h(i), hold(i), start, told(i),        &
     &    delsgn(i), ns(i), k(i), kold(i), ifail(i), icomp(i),          &
     &    stiff, crash, phimax,  icore, ipos, mxorp1,                   &
     &    mxorp2, eps(i), ipts1, ipts2, iptr, knew(i), dumst, stmln,    &
     &    poten(i), numptx, mxordx)
!
!           save logical variables as flags so that they can be
!           stored.
!
       astart(i) = -1.d0
       if(start) astart(i) = 1.d0
       aphase(i) = - 1.d0
       if(phase1) aphase(i) = 1.d0
       acrash(i) = -1.d0
       if(crash) acrash(i) = 1.d0
!**
!**      test for values too small.  set values back and
!**      restart.
!**
      if(.not.crash) go to 450
        icrsh(i) = icrsh(i) + 1
      write (ntsout,4100) ipts1(i), icrsh(i), ipts2(i)
      write (ntsout,4200) poten(i), y(1,i), y(2,i), y(3,i)
        if(icrsh(i) .lt. 5) go to 450
!**
!**         this streamline already crashed 5 times.  write a
!**         message and stop working on this streamline.
!**
      write (ntsout,4300)
          ia = ipts1(i)
      write (ntsout,4250) ipts1(i), ipts2(i), stmln(1,ia), stmln(2,ia), &
     &       stmln(3,ia), y(1,i), y(2,i), y(3,i), hmnst(i),             &
     &       hmxst(i), mordr(i), stmln(7,ia)
          go to 600
  450 continue
      if( icomp(i) .eq. 9 ) write(ntsout,4500)
!**
!**       check if icomp = 5. in such a case a full step has been
!**       completed and data can be dumped out.
!**
       if(icomp(i).ne.5) go to 990
!**
!**         first store data
!**
        ipts2(i) = ipts2(i) + 1
      icrsh(i) = 0
      acrash(i) = -1.d0
       do 475 l = 1,neqn
         y(l,i) = yy(l,i)
  475  continue
       t(i) = x(i)
       told(i) = t(i)
       icomp(i) = 1
       ia = ipts1(i)
      if( isprnt .eq. 0 ) go to 480
      write(ntsout,5319) ipts1(i),ipts2(i),t(i),y(1,i),y(2,i),y(3,i),   &
     &                  yp(1,i),yp(2,i),yp(3,i),poten(i),kold(i),       &
     &                  hmnst(i),hmxst(i),mordr(i),stmln(7,ia)
 5319 format(2x,2i5,8(1x,e12.6)/2x,i5,2(1x,e12.6),2x,i5,2x,e12.6)
  480 write(ntsmln)ipts1(i),ipts2(i),t(i),y(1,i),y(2,i),y(3,i),         &
     &       yp(1,i), yp(2,i), yp(3,i), poten(i), kold(i),              &
     &       stmln(7,ia)
!**
!**      check for minimum, maximum step size, order etc for the
!**      current streamline.
!**
      if(hmnst(i).gt.hold(i)) hmnst(i) = hold(i)
      if(hmxst(i).lt.hold(i)) hmxst(i) = hold(i)
      if(mordr(i).lt.kold(i)) mordr(i) = kold(i)
!**
!**       check if for the current streamline number of integration
!**       points exceed max. no. allowed.
!**
      if(ipts2(i).eq.maxstm) go to 540
!**
!**      check for convergence
!**
      if (((stmln(1,ia)-stmln(4,ia)).lt.y(1,i)).and.                    &
     &    ((stmln(2,ia)-stmln(5,ia)).lt.y(2,i)).and.                    &
     &    ((stmln(3,ia)-stmln(6,ia)).lt.y(3,i)).and.                    &
     &    (y(1,i).lt.(stmln(1,ia)+stmln(4,ia))).and.                    &
     &    (y(2,i).lt.(stmln(2,ia)+stmln(5,ia))).and.                    &
     &    (y(3,i).lt.(stmln(3,ia)+stmln(6,ia))))    go to 990
        go to 550
!**
!**       write message that integration stopped due to max integ-
!**       ration point limit.
!**
  540 continue
      write (ntsout,4400) ipts1(i), maxstm
!**
!**       integration for this streamline stopped or complete.
!**       print summary info.
!**
  550 continue
      write (ntsout,4250) ipts1(i), ipts2(i), stmln(1,ia), stmln(2,ia), &
     &     stmln(3,ia), y(1,i), y(2,i), y(3,i), hmnst(i), hmxst(i),     &
     &     mordr(i), stmln(7,ia)
  600 continue
       icomp(i) = 10
       if(ipos.gt.numpts) go to 990
        ipts2(i) = 0
        ipts1(i) = ipos
        icomp(i) = 1
        iflag(i) = 1
         icrsh(i) = 0
        astart(i) = 1.d0
        t(i)      = 0.d0
          tout(i) = sign( 1.d8, stmln(7,ipos) )
        y(1,i)    = stmln(1,ipos)
        y(2,i)    = stmln(2,ipos)
        y(3,i)    = stmln(3,ipos)
          iaxstr(i) = iastr(ipos)
         hmnst(i) = 10000.d0
         hmxst(i) = -10000.d0
         mordr(i) = 0
         h(i) = hmin
        aphase(i) = 1.d0
        acrash(i) = -1.d0
        ipos = ipos + 1
  990  continue
 1000 continue
!**
!**         check if computation for any point is still being
!**         computed.
!**
      if(kwork.eq.0)  go to 2000
!**
!**       call in routine for function evaluation.
!**
!**
      call fstmln(poten,yy,yp,icomp,icore,neqn,zof,pzof)
      call CPU_TIME(te)
      if( isprnt .eq. 0 ) go to 1234
      write(ntsout,5005) te
 5005 format('   te = ',f10.4,'time ending step')
!**
 1234 go to 200
!**
!**         all functions complete  return control
!**
 2000 continue
      rewind ntsmln
      numpts  =  numpsv
      return
!
!
!
 4000 format(1h ,20x,2i10)
 4100 format(1h0,5x,18h *** streamline = , i5, 9h crashed , i5,         &
     &    13h times after , i5, 17h computations ***)
 4200 format(1h ,5x,17h *** potential = , e15.6, 13h  position =   ,    &
     &    3e15.6, 6h   ***)
 4250 format(1h0,5x,16hstreamline no. =, i4,4x,                         &
     &  21hintegration points = ,i5,4x,19hstarting position =,3e14.6/   &
     &  5x,17hending position =,3e14.6,4x,21hmin. max. step size =,     &
     &  2e14.6/5x,12hmax. order =,i3,4x,23hforward backward flag =,     &
     &  f5.2,37h (non zero value indicates backward)  )
 4300 format(1h ,5x,' *** no more computations performed for this',     &
     &                     ' streamline  ***')
 4400 format(1h0,5x,'***streamline no. =',i5,                           &
     &              ' computations stopped at',i6,                      &
     &              ' iterations due to max integ. points limit***')
 4500 format(1h ,5x,' *** no more computations performed for this',     &
     &       ' streamline ***',/,5x,' *** hmin/abserr too',             &
     &       ' restrictive',24x,3h***,/,5x,' *** successful',           &
     &       ' integration step not possible',12x,3h***)
      END subroutine setup1
! **deck sffgen
      subroutine sffgen
      implicit double precision (a-h,o-z)
!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
!
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
      call setcor ('sffgen')
      call igtcor ('neda',llneda,  mxnabt+1)
      call igtcor ('kseg',llkseg,4*mxfdsg)
      call igtcor ('kkey',llkkey,  mxfdsg)
      call igtcor ('ksgn',llksgn,  mxfdsg)
      call igtcor ('nedm',llnedm,4*mxnett+1)
      call getcor ('taue',lltaue,  mxempt)
      call igtcor ('iskp',lliskp,  mxsngt)
      call getcor ('scr', llscr, 28*200)
      call ffgen (w(llneda), w(llkseg), w(llkkey), w(llksgn), w(llnedm) &
     &           ,w(lltaue), w(lliskp), w(llscr))
      call frecor ('sffgen')
      return
      END subroutine sffgen
! **deck sgeomc
      subroutine sgeomc
      implicit double precision (a-h,o-z)
!call xcntrl
      common /xcntrl/ icntrl,jcntrl
!end  xcntrl
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to compute defining quantities associated with panel and     *
!     *  network geometry                                             *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!c
!     *  compute panel and network geometry defining quantities       *
!
      call tgeomc
!c
!     *  print out job status and cost for step just completed        *
!
      call cstprt ('geometry')
!---  return
      return
      END subroutine sgeomc
! **deck sginvx
      subroutine sginvx (a,na,nx,m,n,x)
      implicit double precision (a-h,o-z)
      dimension a(na,1), x(nx,1)
      dimension sa(33), d(33), jq(33)
!
      mnmax   =  max(m,n)
      if ( mnmax.gt.33 ) call a502er ('sginvx','scratch cm overflow')
      call dcbht (a,d,sa,jq,na,m,n)
      call psintp (na,m,n,a,d,x,sa)
      call mcopy (m,n,  x,1,na,  a,1,na)
      call zero (x,6*m)
      do 100 i = 1,m
      do 100 j = 1,n
  100 x(jq(j),i)=  a(i,j)
      return
      END subroutine sginvx

! **deck shftic
      subroutine shftic (z,nz,deg,x,y)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   shftic applies a translation of origin transformation to    *
!     *   the rows of a panel influence coefficient matrix.  this     *
!     *   transformation is needed so that the influence coefficients *
!     *   represent the influence of the panel basis functions        *
!     *   ( 1, xi, eta, ... ) rather than the shifted basis functions *
!     *   ( 1, xi-x, eta-y, ... ) .                                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   shftic uses a generalization of the extended horner algor-  *
!     *   ithm for the translation of polynomials.  for polynomials   *
!     *   of degree 3, this algorithm is founded upon the observation *
!     *   that  t,  defined by                                        *
!     *                                                               *
!     *    ( 1  x y  x*x/2 x*y y*y/2  x*x*x/6 x*x*y/2 x*y*y/2 y*y*y(6)*
!     *    (    1      x    y          x*x/2    x*y    y*y/2         )*
!     *    (      1         x    y             x*x/2    x*y    y*y/2 )*
!     *    (           1                 x       y                   )*
!     *  t=(                1                    x       y           )*
!     *    (                     1                       x       y   )*
!     *    (                             1                           )*
!     *    (                                     1                   )*
!     *    (                                             1           )*
!     *    (                                                     1   )*
!     *                                                               *
!     *   may be factored as                                          *
!     *                                                               *
!     *                  t  =  t(1) * t(2) * t(3)                     *
!     *                                                               *
!     *   where                                                       *
!     *                                                               *
!     *          (  1  x/3 y/3                      )                 *
!     *          (      1                           )                 *
!     *          (          1                       )                 *
!     *          (             1                    )                 *
!     *   t(1) = (                1                 )                 *
!     *          (                   1              )                 *
!     *          (                      1           )                 *
!     *          (                         1        )                 *
!     *          (                            1     )                 *
!     *          (                               1  )                 *
!     *                                                               *
!     *          ( 1  x/3  y/3                            )           *
!     *          (     1        x/2  y/2                  )           *
!     *          (          1        x/2  y/2             )           *
!     *          (               1                        )           *
!     *   t(2) = (                    1                   )           *
!     *          (                         1              )           *
!     *          (                            1           )           *
!     *          (                               1        )           *
!     *          (                                  1     )           *
!     *          (                                     1  )           *
!     *                                                               *
!     *          ( 1  x/3  y/3                            )           *
!     *          (     1        x/2  y/2                  )           *
!     *          (          1        x/2  y/2             )           *
!     *          (               1             x  y       )           *
!     *   t(3) = (                    1           x  y    )           *
!     *          (                         1         x  y )           *
!     *          (                             1          )           *
!     *          (                                1       )           *
!     *          (                                   1    )           *
!     *          (                                      1 )           *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   deg       argument  input     degree of polynomial to be    *
!     *                                 shifted                       *
!     *                                                               *
!     *   k         local     - - - -   index over transformations    *
!     *                                 t(k)                          *
!     *                                                               *
!     *   l         local     - - - -   index over the blocks of the  *
!     *                                 matrices  t(k),  traversed    *
!     *                                 in reverse order              *
!     *                                                               *
!     *   lbs       local     - - - -   an address bias for subblock l*
!     *                                                               *
!     *   nz        argument  input     row dimension of array z of   *
!     *                                 influence coefficients        *
!     *                                                               *
!     *   iz        local     - - - -   index over rows of z-matrix   *
!     *                                                               *
!     *   x         argument  input     amount of x shift to be       *
!     *                                 applied                       *
!     *                                                               *
!     *   y         argument  input     amount of y shift to be       *
!     *                                 applied                       *
!     *                                                               *
!     *   xf        local     - - - -   x divided by some integer     *
!     *                                                               *
!     *   yf        local     - - - -   y divided by some integer     *
!     *                                                               *
!     *   z         argument  in/out    array of influence coeff      *
!     *                                 icients to be transformed     *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      integer nz, deg
      dimension z(nz,1)
      do 40 k = 1,deg
          do 30 lbk = 1,k
               l       =  k + 1 - lbk
               lbs     =  (l*(l+1))/2
               lbsml   =  lbs - l
               f       =  deg+1-l
               xf      =  x/f
               yf      =  y/f
               do 20 i = 1,l
                    do 10 iz = 1,nz
                    iplbs   =  i + lbs
                    ilbsml  =  i + lbsml
                    z(iz,iplbs  ) = z(iz,iplbs  ) + xf*z(iz,ilbsml)
                    z(iz,iplbs+1) = z(iz,iplbs+1) + yf*z(iz,ilbsml)
   10               continue
   20          continue
   30     continue
   40 continue
      return
      END subroutine shftic
! **deck shlsr2
      subroutine shlsr2 (n,a)
      implicit double precision (a-h,o-z)
!c
!     shlsr2 is a variation of routine shlsrt in which the 4 integers
!     per word logic has been removed. this was necessary for the
!     conversion to cray-2 unicos at nasa-ames which uses a 46 bit
!     integer word.
!
      integer a(1), asv
      if ( n.le.0 ) return
      m       =  n
!
  100 m       =  m/2
      if ( m.le.0 ) return
      jmax    =  n - m
      do 200 j = 1,jmax
      ia      =  j
      iap     =  ia + m
  150 do 160 i=1,4
      if ( a(4*ia-4+i) .lt. a(4*iap-4+i) ) go to 200
      if ( a(4*ia-4+i) .eq. a(4*iap-4+i) ) go to 160
!
      do 155 l=1,4
      asv           =  a(4*ia-4+l)
      a(4*ia-4+l)   =  a(4*iap-4+l)
  155 a(4*iap-4+l)  =  asv
!
      iap     =  ia
      ia      =  ia - m
      if ( ia.gt.0 ) go to 150
      go to 200
  160 continue
  200 continue
      go to 100
      END subroutine shlsr2
! **deck shlsrt
      subroutine shlsrt (n,a)
      implicit double precision (a-h,o-z)
      integer a(1), asv
      if ( n.le.0 ) return
      m       =  n
  100 continue
      m       =  m/2
      if ( m.le.0 ) return
      jmax    =  n - m
      do 200 j = 1,jmax
      ia      =  j
      iap     =  ia + m
  150 if ( a(ia) .le. a(iap) ) go to 200
          asv     =  a(ia)
          a(ia)   =  a(iap)
          a(iap)  =  asv
!
!
          iap     =  ia
          ia      =  ia - m
          if ( ia.gt.0 ) go to 150
  200 continue
      go to 100
      END subroutine shlsrt
! **deck sincd
      subroutine sincd(z,ds,ic)
      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 doublet strength and gradient (in globlal          *
!     *  coordinates) at a given point on a panel  in terms of the    *
!     *  nine canonical  values of doublet strength on the panel.     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  calculate doublet strength and gradient (in local sub-panel  *
!     *  coordinates) in terms of local quadratic  taylor             *
!     *  coefficients.                                                *
!     *  pre-multiply appropriately by transormation of gradient from *
!     *  local to global coordinates.                                 *
!     *  post-multiply by transformation from nine canonical values   *
!     *  to sub-panel quadratic taylor 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                   *
!     *                                                               *
!     *   ar        /pandq/   input     transformation from global to *
!     *                                 local sub-panel coordinates   *
!     *                                                               *
!     *   cp        /pandq/   input     nine canonical panel points   *
!     *                                 (includes corner points,edge  *
!     *                                 midpoints and center)         *
!     *                                                               *
!     *   ds        argument  output    array relating doublet        *
!     *                                 strength and gradient (in     *
!     *                                 global coordinates) at given  *
!     *                                 point to nine canonical values*
!     *                                 of doublet strength on panel  *
!     *                                                               *
!     *   ic        argument  input     sub-panel of panel (whose     *
!     *                                 defining quantities are       *
!     *                                 currently in /pandq/) on which*
!     *                                 given point lies              *
!     *                                                               *
!     *   icp       -local-   - - - -   index of geometric quantities *
!     *                                 associated with sub-panel ic  *
!     *                                                               *
!     *   icpp      -local-   - - - -   index defining which of nine  *
!     *                                 canonical panel points is the *
!     *                                 origin of sub-panel           *
!     *                                                               *
!     *   qq        /pandq/   input     transformation from doublet   *
!     *                                 values at nine canonical panel*
!     *                                 points to quadratic taylor    *
!     *                                 coefficients in local         *
!     *                                 sub-panel coordinate systems  *
!     *                                                               *
!     *   w         -local-   - - - -   local sub-panel coordinates   *
!     *                                 of given point                *
!     *                                                               *
!     *   x         -local-   - - - -   first local coordinate of     *
!     *                                 given point                   *
!     *                                                               *
!     *   y         -local-   - - - -   second local coordinate of    *
!     *                                 given point                   *
!     *                                                               *
!     *   z         argument  input     given point in global         *
!     *                                 coordinates                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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),ds(4,9),w(3),dsp(4,6)
      equivalence (x,w(1)), (y,w(2))
      icp=min (ic,5)
      icpp=icp-min (0,4*(4-icp))
!c
!     *  find local sub-panel coordinates of given point              *
!
      call unipan(ar(1,icp),cp(1,icpp),z,w)
!c
!     *  calculate doublet strength and gradient (in local sub-panel  *
!     *  coordinates) in terms of local quadratic  taylor             *
!     *  coefficients.                                                *
!
      ds(1,1)=1.d0
      ds(1,2)=x
      ds(1,3)=y
      ds(1,4)=.5d0*x*x
      ds(1,5)=x*y
      ds(1,6)=.5d0*y*y
      ds(2,1)=0.d0
      ds(2,2)=1.d0
      ds(2,3)=0.d0
      ds(2,4)=x
      ds(2,5)=y
      ds(2,6)=0.d0
      ds(3,1)=0.d0
      ds(3,2)=0.d0
      ds(3,3)=1.d0
      ds(3,4)=0.d0
      ds(3,5)=x
      ds(3,6)=y
!c
!     *  pre-multiply appropriately by transormation of gradient from *
!     *  local to global coordinates.                                 *
!
      do 200 i=1,6
      dsp(1,i)=ds(1,i)
      ds(4,i)=0.d0
      call mxm (ds(2,i),1,ar(1,icp),3,dsp(2,i),3)
  200 continue
      icp0=mod(ic+3,4)+1
      call subpqr(cp,ar(1,icp),p,alam(1,icp0),pp(1,1,ic),qq(1,1,ic),    &
     &rr(1,1,ic),ic)
!c
!     *  post-multiply by transformation from nine canonical values   *
!     *  to sub-panel quadratic taylor coefficients.                  *
!
      call mxm (dsp,4,qq(1,1,ic),6,ds,9)
      return
      END subroutine sincd
! **deck sincs
      subroutine sincs(z,ds)
      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 source strength at a given point on a panel in     *
!     *  terms of the coefficients of the linear source distribution  *
!     *  on the panel. these coefficients are defined in the common   *
!     *  coordinate system of the four interior sub-panels            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   ar        /pandq/   input     transformation from global to *
!     *                                 local sub-panel coordinates   *
!     *                                                               *
!     *   cp        /pandq/   input     nine canonical panel points   *
!     *                                 (includes corner points,edge  *
!     *                                 midpoints and center)         *
!     *                                                               *
!     *                                                               *
!     *   ds        argument  output    source strength at given point*
!     *                                 in terms of coefficients of   *
!     *                                 linear distribution           *
!     *   w         -local-   - - - -   local sub-panel coordinates   *
!     *                                 of given point                *
!     *                                                               *
!     *   x         -local-   - - - -   first local coordinate of     *
!     *                                 given point                   *
!     *                                                               *
!     *   y         -local-   - - - -   second local coordinate of    *
!     *                                 given point                   *
!     *                                                               *
!     *   z         argument  input     given point in global         *
!     *                                 coordinates                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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),ds(3),w(3)
      equivalence (x,w(1)), (y,w(2))
!c
!     *  find local sub-panel coordinates of given point              *
!
      call unipan(ar(1,5),cp(1,9),z,w)
!c
!     *  calculate source strength in terms of linear coefficients.   *
!
      ds(1)=1.d0
      ds(2)=x
      ds(3)=y
      return
      END subroutine sincs
! **deck sinfcc
      subroutine sinfcc(z,icc,dsdfs,dddfs)
      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 influence of neighboring source and/or doublet     *
!     *  parameters on value of source strength and/or doublet        *
!     *  strength and gradient at a given point on a panel. defining  *
!     *  quantities of desired panel are assumed to currently occupy  *
!     *  common block /pandq/.                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  call sincs (for source) and/or sincd (for doublet)  to obtain*
!     *  influence due to parameters describing local panel           *
!     *  singularity distribution. then post-multiply by matrix       *
!     *  relating these parameters to neighboring singularity         *
!     *  parameters.                                                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   astd      /pandq/   input     matrix relating nine canonical*
!     *                                 panel doublet values to       *
!     *                                 neighboring singularity       *
!     *                                 parameters                    *
!     *                                                               *
!     *   asts      /pandq/   input     matrix relating linear source *
!     *                                 coefficients of panel source  *
!     *                                 distribution to neighboring   *
!     *                                 source parameters             *
!     *                                                               *
!     *   dddfs     argument  output    matrix whose i,jth element is *
!     *                                 the influence of the jth      *
!     *                                 neighboring doublet parameter *
!     *                                 on the ith component of the   *
!     *                                 combined doublet strength/    *
!     *                                 gradient vector at the        *
!     *                                 evaluation point              *
!     *                                                               *
!     *  dsdfs      argument       output    vector whose ith element *
!     *                                      is the influence of the  *
!     *                                      ith neighboring          *
!     *                                      source parameter on      *
!     *                                      source strength at the   *
!     *                                      evaluation point         *
!     *                                                               *
!     *   icc       argument       input     sub-panel on which       *
!     *                                 projection of z lies          *
!     *                                                               *
!     *   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   *
!     *                                                               *
!     *   its       /pandq/   input     panel singularity type        *
!     *                                 =1 source alone               *
!     *                                 =2 doublet alone              *
!     *                                 =3 source and doublet         *
!     *                                                               *
!     *   ncd       /pandq/   input     number of parameters (i.e.    *
!     *                                 canonical values) defining    *
!     *                                 panel doublet distribution    *
!     *                                                               *
!     *   ncs       /pandq/   input     number of parameters (i.e.    *
!     *                                 linear coefficients) defining *
!     *                                 panel source distribution     *
!     *                                                               *
!     *   z         argument  input     given point expressed in      *
!     *                                 global coordinates            *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 dsdfs(16),dddfs(4,25),z(3),ds(4,9)
!c
!     *  ignore doublet computation if panel is pure source panel     *
!
      if(its.lt.2) go to 500
!c
!     *  call sincd to obtain influence of the nine canonical panel   *
!     *  doublet values on doublet strength/gradient at the given     *
!     *  evaluation point                                             *
!
      call sincd(z,ds,icc)
!c
!     *  post-multiply by matrix relating canonical values to         *
!     *  neighboring doublet parameters                               *
!
      call mxm (ds,4,astd,ncd,dddfs,ind)
!c
!     *  ignore source computations if panel is pure doublet panel    *
!
  500 if(its.eq.2) go to 900
!c
!     *  call sincs to obtain influence of the linear coefficients    *
!     *  defining the panel source distribution on source strength at *
!     *  the given evaluation point                                   *
!
      call sincs(z ,ds)
!c
!     *  post-multiply by matrix relating linear distribution         *
!     *  coefficients to neighboring source parameters                *
!
      call mxm (ds,1,asts,ncs,dsdfs,ins)
  900 return
      END subroutine sinfcc
! **deck sinflu
      subroutine sinflu (nndc,indc,  zb,iflb)
      implicit double precision (a-h,o-z)
      dimension indc(nndc), zb(3,1:*), iflb(1:*)
!
!         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)
!         This routine is a supplementary influence tester for super-
!         sonic cases where vinsup has determined that a type 6
!         near field is required.  This routine is based upon dinflu.
!
      complex*16 zed
      dimension p(3)
      dimension rx(3)
      logical  influ, mplane
      logical within
      dimension     r(3,16), xi(16), et(16)                             &
     &              , rc(3), tg(3)                                      &
     &              , rm(3), rp(3)
!call epsff
      common /epsff/ eps1, eps2, eps3, eps4, eps5                       &
     &             , phc1, phc2, phc3
!end  epsff
!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 qc(3)
! --- dimension rq(3,16), enc(3)
! --- equivalence (cpfz,qc), (icsf,ics), (n,nsff), (rq,rqff), (enc,encf)
      data  rthaf/  .70710678118655d0 /
      data ncall/0/
      data nerr /0/
!
      ncall   =  ncall + 1
!
      qrdb    =  .5d0*diamf
      n       =  nsff
      qrdb2   =  qrdb**2
      mplane  =  rfmin*sbetam .gt. 0.d0
!
      dist1   =  eps1*diamf
      dist2   =  eps2*diamf
      dist3   =  eps3*diamf
      dist4   =  eps4*diamf
      dist5   =  eps5*diamf
!                                  loop over selected cp images
      do 3000 ic = 1,nndc
      ib      =  indc(ic)
      p(1)    =  zb(1,ib)
      p(2)    =  zb(2,ib)
      p(3)    =  zb(3,ib)
!                                  make fast influence tests
      ifluij  =  7
      tg(1)   =  p(1)-pwf(1)
      tg(2)   =  p(2)-pwf(2)
      tg(3)   =  p(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:',2d12.4,5x,2d12.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
!                                  set up looping over planes of symmetr
!                                  compute the distance from the mean
!                                  plane panel center to the boundary
!                                  of the cone, in x(bar).
      tg(1)   =  cpfz(1) - p(1)
      tg(2)   =  cpfz(2) - p(2)
      tg(3)   =  cpfz(3) - p(3)
      rc(1)   =  ggcp(1,1)*tg(1)+ggcp(1,2)*tg(2)+ggcp(1,3)*tg(3)
      rc(2)   =  ggcp(2,1)*tg(1)+ggcp(2,2)*tg(2)+ggcp(2,3)*tg(3)
      rc(3)   =  ggcp(3,1)*tg(1)+ggcp(3,2)*tg(2)+ggcp(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  cpfz  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  =  7
               if ( .not. influ ) go to 1200
               if ( dqcb .gt. dist3 ) go to 1000
!                                  perform detailed influence test
  100 continue
      dmin    =  dqcb
      hsqmin  =  hcsq
!
      isx     =  0
      k       =  0
      do 300 is = 1,nsff
          if ( is .eq. icsf ) go to 300
          isx     =  isx + 1
          r(1,is) =  rqff(1,is) + rc(1)
          r(2,is) =  rqff(2,is) + rc(2)
          r(3,is) =  rqff(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 (  encf(1)**2 .le.  encf(2)**2+encf(3)**2  ) go to 400
!
          xn      =  encf(1)*rc(1) + encf(2)*rc(2) + encf(3)*rc(3)
          if ( xn*encf(1) .gt. 0.d0 ) go to 340
!                                  panel is upstream of the control pt.
!                                  check for piercing
               ichk    =  1
               rx(1)   =  xn/encf(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*encf(1)
               rx(2)   =  xn*encf(2)
               rx(3)   =  xn*encf(3)
!                                  determine if rx(*) is in the avg pane
  350     continue
          do 360 is = 1,nsff
               xi(is)  =  1.d0
               et(is)  =  0.d0
               if ( is.eq.icsf ) go to 360
               isp1    =  mod(is,nsff)+1
               if ( isp1.eq.icsf ) isp1 = mod(isp1,nsff)+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( encf,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.
               nerr    =  nerr + 1
               if(nerr.lt.10) call errmsg(' zwindg eror in sinflu')
               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,nsff
          if ( is.eq.icsf ) go to 500
          isp1    =  mod(is,nsff)+1
          if ( isp1.eq.icsf ) isp1 = mod(isp1,nsff)+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  =  7
      if ( .not.influ ) go to 1200
!                                  define  ifluij
 1000 continue
      ifluij  =  6
      if ( dmin .gt. dist5 ) ifluij = 5
      if ( dmin .gt. dist4 ) ifluij = 4
      if ( dqcb .gt. dist3 ) ifluij = 3
      if ( dqcb .gt. dist2 ) ifluij = 2
      if ( dqcb .gt. dist1 ) ifluij = 1
!
 1200 continue
!--      write (6,6202) p,ipnf,ifluij,dmin,dqcb,influ
 6202 format (' p',3d12.4,' ipnf',i4,'ifluij',i4                        &
     &       ,'  dmin,dqcb,influ:',2d12.4,2x,l3)
!
 2100 continue
!
      iflb(ib) = ifluij
 3000 continue
!
!
!
      return
      END subroutine sinflu
! **deck sing
      subroutine sing (knet,ntk,nm,nn,nsa,nssa,ns,nss                   &
     &                ,maps,locs,npa,zm,ia,za)
      implicit double precision (a-h,o-z)
      dimension zm(3,nm,nn),maps(1)
      dimension locs(1)
      dimension ia(1:*), za(3,1:*)
!***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 a given network using the method of least squares.       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the routine calculates the dependence of each panel          *
!     *  singularity strength distribution on the free singularity    *
!     *  parameters of the network.  first the locations of the free  *
!     *  singularity parameters for the particular network type are   *
!     *  computed and indexed.  for each panel the singularity        *
!     *  parameters affecting the distribution of singularity strength*
!     *  on that panel are isolated.  each such parameter is assigned *
!     *  a weight (large if the parameter actually lies on the panel).*
!     *  the panel singularity distribution is then obtained by       *
!     *  fitting a linear or quadratic (if the singularity is of      *
!     *  doublet type) form to the parameters by the method of least  *
!     *  squares.  the matrix which relates the coefficients of the   *
!     *  distribution to the singularity parameters is then stored    *
!     *  on a file along with indices identifying the parameters.     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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    inverse from least-squares fit*
!     *                                                               *
!     *   aqi       /pandq/   input     transformation matrix from    *
!     *                                 near plane to global          *
!     *                                 coordinate system             *
!     *                                                               *
!     *   ar        /pandq/   input     transformation from global to *
!     *                                 local sub-panel coordinates   *
!     *                                                               *
!     *   astd      /pandq/   output    matrix relating nine canonical*
!     *                                 panel doublet values to       *
!     *                                 neighboring singularity       *
!     *                                 parameters                    *
!     *                                                               *
!     *   asts      /pandq/   output    matrix relating linear source *
!     *                                 coefficients of panel source  *
!     *                                 distribution to neighboring   *
!     *                                 source parameters             *
!     *                                                               *
!     *   i         -local-   - - - -   index of loop over            *
!     *                                 dependent column parameters   *
!     *                                                               *
!     *   ia        /skrch1/  -local-   index array for singularity   *
!     *                                 parameter grid za             *
!     *                                                               *
!     *   iid       /pandq/   output    index array for panel doublet *
!     *                                 singularity parameters        *
!     *                                                               *
!     *   iis       /pandq/   output    index array for panel source  *
!     *                                 singularity parameters        *
!     *                                                               *
!     *   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         *
!     *                                                               *
!     *   itsing    -local-   - - - -   local network type flag       *
!     *                                                               *
!     *   j         -local-   - - - -   index of dependant rows       *
!     *                                                               *
!     *   jmax      -local-   - - - -   number dependant rows         *
!     *                                                               *
!     *   k         -local-   - - - -   index over terms in least     *
!     *                                 square fit                    *
!     *                                                               *
!     *   kn        argument  input     network number                *
!     *                                                               *
!     *   ncd       /pandq/   output    number of parameters (i.e.    *
!     *                                 quadratic coefficients)       *
!     *                                 defining panel doublet        *
!     *                                 distribution                  *
!     *                                                               *
!     *   ncs       /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     *
!     *                                                               *
!     *   no        /lsqsfc/  output    order of least-squares fit    *
!     *                                                               *
!     *   npa       argument  input     number of panels in all       *
!     *                                 previous networks             *
!     *                                                               *
!     *   npk       /lsqsfc/  output    number of data points used    *
!     *                                 in least-squares fit          *
!     *                                                               *
!     *   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         *
!     *                                                               *
!     *   wtk       /lsqsfc/  output    weights used in least-squares *
!     *                                 fit                           *
!     *                                                               *
!     *   za        /skrch1/  -local-   global coordinates of network *
!     *                                 singularity parameter         *
!     *                                 locations                     *
!     *                                                               *
!     *   zk        /lsqsfc/  output    (z,y,z) coordinates of corner *
!     *                                 points used in least-squares  *
!     *                                 fit                           *
!     *                                                               *
!     *   zm        argument  input     coordinates of corner points  *
!     *                                 in network grid               *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call lsqsfc
!                                                            /lsqsfc/
      common/lsqsfc/zk(3,16),wtk(16),ak(6,16),no,npk
!end  lsqsfc
!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
      dimension locpak(4)
      data wt /1.d4/
!c
!     *  set type, order and number of coefficients in singularity    *
!     *  distribution                                                 *
!
      nt=iabs(ntk)
      itsing=2-mod(nt,2)
      no=itsing
!c
!     *  determine number of rows and columns of singularity          *
!     *  parameters                                                   *
!
      nma=nm+1
      if(nt.eq.1) nma=nm-1
      if((nt.gt.2).and.(nt.le.6)) nma=nm
      nna=nn+1
      if((nt.eq.3).or.(nt.eq.4)) nna=nn
      if((nt.eq.1).or.(nt.eq.5)) nna=nn-1
!c
!     *  determine location of singularity parameters                 *
!
      call gcpcal(nm,nn,zm,nma,nna,za)
!c
!     *  order distinct singularity parameters                        *
!
      call grdind(nma,nna,za,ia,nia)
!c
!     *  set indices defining limits of each local dependance         *
!
      imax=3
      if(nma.eq.nm) imax=4
      jmax=3
      if(nna.eq.nn) jmax=4
      mind=3
      if(nma.gt.nm) mind=2
      nind=3
      if(nna.gt.nn) nind=2
!c
!     *  loop cycles through all panels in network                    *
!
!c
!     *  loop ranges over columns in network                          *
!
      do 699 n=2,nn
!c
!     *  loop ranges over rows in network                             *
!
      do 698 m=2,nm
!c
!     *  retrieve panel defining quantities                           *
!
      ip=m-1+(nm-1)*(n-2)+npa
      call strns (ip,cp)
      its=itsing
      if(ntk.lt.0) its=3
      if(its.eq.1) ind=0
      if(its.eq.2) ins=0
      if(itsing.eq.1) ncs=3
      if(itsing.eq.2) ncd=6
      npk=0
!c
!     *  calculate locations of singularity parameters affecting      *
!     *  panel singularity distribution                               *
!
!c
!     *  loop ranges over columns of dependance                       *
!
      do 629 j=1,jmax
      nj=n+j-nind
      if((nj.lt.1).or.(nj.gt.nna)) go to 629
      if((nt.eq.3).and.((j.eq.1).or.(j.eq.jmax))) go to 629
!c
!     *  loop ranges over rows of dependance                          *
!
      do 628 i=1,imax
      mi=m+i-mind
      if((mi.lt.1).or.(mi.gt.nma)) go to 628
      if(((nt.eq.3).or.(nt.eq.5)).and.((i.eq.1).or.(i.eq.imax)))        &
     &go to 628
      lmn=mi+nma*(nj-1)
      npk=npk+1
!c
!     *  set index of singularity parameters affecting panel          *
!     *  singularity distribution                                     *
!
      iis(npk)  =  nssa + lmn
!c
!     *  project singularity parameter locations onto near plane and  *
!     *  obtain local coordinates of projection                       *
!
      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))
!c
!     *  weight contribution of each singularity parameter            *
!
      wtk(npk)=1.d0
      if(((mi.eq.nma-nm).or.(mi.eq.nm+1).or.((i.gt.1).and.(i.lt.imax))) &
     &.and.((nj.eq.nna-nn).or.(nj.eq.nn+1).or.((j.gt.1)                 &
     &.and.(j.lt.jmax)))) wtk(npk)=wt
      if((nt.ne.1).or.(i.ne.2).or.(j.ne.2)) go to 628
      if(nm.gt.2) 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(nn.gt.2) 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
      if(itsing.eq.2) ind=npk
      if(itsing.eq.1) ins=npk
!c
!     *  least squares panel singularity distribution to singularity  *
!     *  parameters                                                   *
!
      call lsqsf
      if(isingp.eq.1) write(6,2000) ip,kp,no,npk
 2000 format(///1x,11hpanel no. =,i5,5x,13hnetwork no. =,i5,            &
     &5x,20hdistribution order =,i5,                                    &
     &5x,34hnumber of singularity parameters =,i5,///2x,2his,           &
     &3x,6hweight,7x,3hkse,10x,3heta,10x,4hzeta,10x,1ha,11x,3haks,      &
     &10x,3haet,9x,5haksks,8x,5hakset,8x,5haetet,/)
      if(itsing.eq.1) nc=ncs
      if(itsing.eq.2) nc=ncd
      do 649 k=1,npk
      do 648 i=1,nc
      l=i+nc*(k-1)
      if(itsing.eq.1) asts(l)=ak(i,k)
      if(itsing.eq.2) astd(l)=ak(i,k)
  648 continue
      if((isingp.eq.1).and.(itsing.eq.1)) write(6,3000)                 &
     &iis(k),wtk(k),(zk(l,k),l=1,3),(ak(l,k),l=1,6)
      if((isingp.eq.1).and.(itsing.eq.2)) write(6,3000)                 &
     &iid(k),wtk(k),(zk(l,k),l=1,3),(ak(l,k),l=1,6)
 3000 format(i5,e10.3,9f13.5)
  649 continue
!c
!     *  compact matrix describing dependence of singularity          *
!     *  coefficients on surrounding singularity parameters           *
!
      if(itsing.eq.1) call scmpkt(asts,iis,ncs,ins)
      if(itsing.eq.2) call scmpkt(astd,iid,ncd,ind)
  690 continue
!c
!     *  store panel singularity distribution defining quantities on  *
!     *  i/o unit 2 along with panel geometry defining quantities     *
!
      call istrns(ip,cp)
  698 continue
  699 continue
      do 750 nj=1,nna
      do 700 mi=1,nma
      lmn=mi+nma*(nj-1)
      k=lmn+nssa
      maps(k)=ia(lmn)+nsa
      if ( nma.lt.nm ) ifn = 2*mi
      if ( nma.eq.nm ) ifn = 2*mi-1
      if ( nma.gt.nm ) ifn = max ( 1, min ( 2*nm-1, 2*mi-2))
      if ( nna.lt.nn ) jfn = 2*nj
      if ( nna.eq.nn ) jfn = 2*nj-1
      if ( nna.gt.nn ) jfn = max ( 1, min ( 2*nn-1, 2*nj-2))
      locpak(1) = knet
      locpak(2) = jfn
      locpak(3) = ifn
      locpak(4) = itsing
      call icopy (4,  locpak,1, locs(4*(k)-3),1)
  700 continue
  750 continue
  800 continue
      nss=nma*nna
!c
!     *  set total number of singularity parameters in network        *
!
      ns=nia
      return
      END subroutine sing
! **deck sinput
      subroutine sinput
      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 read input                                                *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 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 symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!c
!     *  call input calling routine                                   *
!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 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 mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!call lndblx
!                                                           /lndblx/
      common /lndblx/ genwak(3,mxnett), slndbl(mxnett)                  &
     &              , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett)
!end  lndblx
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
      dimension gen(3)
!
      nw      =  300000
      call setcor ('sinput')
!
      call inputa
!                                  set up nw list for off-body-point
!                                  calculation if it has not already bee
!                                  done.
      if ( nnwofb .gt. 0 ) go to 20
      nnwofb  =  nnett
      do 10 i = 1,nnett
      nwofb(i)  =  i
   10 continue
!                                  clean up the nwofb list
   20 continue
      call shlsrt (nnwofb,nwofb)
      inew    =  0
      do 30 i = 1,nnwofb
          if ( nwofb(i).lt.1  .or.  nwofb(i).gt.nnett ) go to 30
          if ( inew.eq.0 ) go to 25
          if ( nwofb(i) .eq. nwofb(inew) ) go to 30
   25     continue
               inew    =  inew + 1
               nwofb(inew) = nwofb(i)
   30 continue
      nnwofb  =  inew
      write (6,40) nnwofb, (nwofb(i),i=1,nnwofb)
   40 format ('  off-body-points network list,',i5,' networks'          &
     &    ,/, (1x,20i5)  )
!                                  generate wake directions for wake net
      do 500 knet = 1,nnett
          j1      =  (nn(knet)+1)/2
          j2      =  j1+1
          kte1    =  nza(knet) + j1*nm(knet)
          kte2    =  nza(knet) + j2*nm(knet)
          kup1    =  kte1 - 1
          kup2    =  kte2 - 1
          do 480 i = 1,3
               gen(i) = .5d0*(  zm(i,kte1)-zm(i,kup1)                   &
     &                       +zm(i,kte2)-zm(i,kup2)  )
  480     continue
          call uvect (gen)
          call dcopy (3,  compd,1,  gen,1)
          call dcopy (3,  gen,1,  genwak(1,knet),1)
  500 continue
!c
!     *  print out job status and cost for step just completed        *
!
      call frecor ('sinput')
      call cstprt ('input   ')
!            geometry input is complete
!
      write(6,5081)
 5081 format(//,2x,23hgeometry input complete,//)
      call emark('input-da')
      return
      END subroutine sinput
! **deck sinver
      subroutine sinver (nsngtp,sols)
      implicit double precision (a-h,o-z)
      dimension sols(nsngtp,4)
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to solve problem matrix equation                             *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   iacase    /acase/   -local-   index of loop over right hand *
!     *                                 side cases                    *
!     *                                                               *
!     *   ifact     /factrd/  input     flag for restarting program   *
!     *                                 using factored aic matrix     *
!     *                                                               *
!     *   iray      /solnt/   input     part of the calling sequence  *
!     *                                 to the solution package       *
!     *                                 see subroutine tinver for     *
!     *                                 further description           *
!     *                                                               *
!     *   is        -local-   - - - -   index of loop over known or   *
!     *                                 unknown singularity parameters*
!     *                                                               *
!     *   jc        -local-   - - - -   overall control point index   *
!     *                                                               *
!     *   mtitle    /solnt/   -local-   title of solution matrix      *
!     *                                                               *
!     *   mtype     -local-   - - - -   matrix type code              *
!     *                                                               *
!     *   nacase    /acase/   input     number of freestream cases    *
!     *                                 for simultaneous solution     *
!     *                                                               *
!     *   naic      /solnt/   input     i/o unit on which aic matrix  *
!     *                                 resides                       *
!     *                                                               *
!     *   nans      /solnt/   input     i/o unit on which solution    *
!     *                                 resides                       *
!     *                                                               *
!     *   ncls      -local-   - - - -   number of matrix columns      *
!     *                                                               *
!     *   nrws      -local-   - - - -   number of matrix rows         *
!     *                                                               *
!     *   nsc1      /solnt/   -local-   scratch i/o unit for          *
!     *                                 solution package use          *
!     *                                                               *
!     *   nsc2      /solnt/   -local-   scratch i/o unit for          *
!     *                                 solution package use          *
!     *                                                               *
!     *   nrhs      /solnt/   input     i/o unit on which right hand  *
!     *                                 side matrix resides           *
!     *                                                               *
!     *   nsngk     /index/   input     total number of known         *
!     *                                 singularity parameters        *
!     *                                                               *
!     *   nsngu     /index/   input     total number of unknown       *
!     *                                 singularity parameters        *
!     *                                                               *
!     *   scr                           scratch array for tinver      *
!     *                                 later, solution singularity   *
!     *                                 parameters for each right hand*
!     *                                 side case                     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      character form26*26
      character*72 line
!call factrd
!                                                            /factrd/
      common /factrd/ ifact
!end  factrd
      integer pp,qq,p
!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 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 skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
!call chybrj
!                                                            /chybrj/
!         unit numbers and scratch memory addresses in sinver
      common /chybrj/ ljac, ljly, lans                                  &
     &              , lldvdl, llvica, llvicd, llaic
!end  chybrj
      common /srwi/ nsdqzz, nsszz, nrszz, ntszz, nns, nis(maxpan+1)
!call vrwi
      common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp)
!end  vrwi
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!call iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
      dimension nhdat(10)
      dimension fcnmax(4), fnwmax(4), dumans(5)
      dimension dlminf(4), alminf(4), dlmprv(4), dlmfac(4), fsqcp2(4)   &
     &                                         , cndcp2(4), gsqcp2(4)
      logical fbelow(4), fcheck(4), fdone(4)
      logical prtcp2, cp2sum
      logical bkprnt, cp2prt
      logical newton, lamprt
!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
!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
      dimension anscp2(4,maxcp2), rhscp2(4,maxcp2), ansbas(maxcp2)
!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 cp2flg
!         /cp2flg/:  newton iteration, lambda print and cp2 print flags
      common /cp2flg/ istcp2, iexcp2, nitcp2
!end  cp2flg
!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 nlilun
!         logical units for nonlinear iteration             /nlilun/
      common /nlilun/ nlimat, nlitmp, nlillu, nlirhs, nlibn, nlians     &
     &              , indmat(maxcp2+1)
!                                                           /nlilun/
!end  nlilun
!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 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 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
      logical rlse19, rlse20, rlse27
      logical rlse51, rlse52, rlse53, rlse54, rlse55, rlse56, rlse57
      logical fexist
      character*8 fname
!
!
!
      data tol/1.d-5/
!
!
!
      nw      =  300000
      call setcor ('sinver')
!                                  allocate cm for 1st part of sinver
      call setcor ('sinver-1')
      nnsa    =  250000
      call getcor ('sa',llsa,nnsa)
!                                  set release flags
      rlse19  =  .false.
      rlse20  =  .true.
      rlse27  =  .true.
!                                  release flags for NLI units
      rlse51  =  .false.
      rlse52  =  .false.
      rlse53  =  .false.
      rlse54  =  .false.
      rlse55  =  .false.
      rlse56  =  .false.
      rlse57  =  .false.
!
      nlirhs  =  52
      nlians  =  53
      nlimat  =  54
      nlitmp  =  55
      nlillu  =  56
      nlibn   =  57
      open (unit=52,file='nlirhs',form='unformatted',status='unknown')
      open (unit=53,file='nlians',form='unformatted',status='unknown')
      ljac    =  51
      ljly    =  10000
      open (unit=ljac,file='ft51',form='unformatted',status='unknown')
!                                  SCRATCH REQUIREMENTS FOR SOLVER
      nsfclu  =  klublk + ityprc*( 3*nppblk*nppblk + 2*nppblk )
      nbpp    =  min(nppblk,nrhs)
      nbrhs   =  (nrhs+nppblk-1)/nppblk
      kbn     =  npblk*nbrhs + 1
      nssolv  =  klublk + kbn + ityprc*( nppblk*nppblk + nppblk         &
     &                                   +2*(nppblk*nbpp) + nrhs )
      nsfact  = max (nssolv,nsfclu)
      if ( nsfact.gt.nnsa ) then
         call a502er ('sinver','nnsa was set smaller than nsfact')
      endif
      nsfact  =  nnsa
!
      if(nsngu.eq.0) go to 801
!---      nta     =  iray(2)
!---      nna     =  mxsngu + 1
!---      call openms (nta,nia,nna,0)
      call xtrns (21,nbccp2,nx21)
      call xtrns (20,ncp2ab,nx20)
      if ( iexcp2.lt.1 ) go to 40
      call outmti ('idcp2',3,3,ncp2ab,idcp2)
      call outmti ('jc,rw,in',maxcp2,nbccp2,3,jcncp2)
   40 continue
!
      nnrhs   =  nacase + 1 + nbccp2
!---      lmat    =  nta
!---      lint    =  iray(7)
      llu     =  iray(6)
      lrhs    =  iray(9)
      lans    =  iray(4)
      lbn     =  28
!
      bkprnt  =  icostp.gt.1
      write (6,6100) bkprnt
 6100 format ('0logical flags for cp/2 iteration:'                      &
     &   ,/,  1x,l8,' = bkprnt, print flag for solver statistics'       &
     &     )
!
      rewind lrhs
      do 100 i = 1,nsngu
      read (lrhs) (sols(i,iacase),iacase=1,nacase)
  100 continue
! *** call outvec ('rhs(0)',nsngu,scr)
!
      rewind lrhs
      rewind lans
!
! *** this section determines whether we are using an old factored
! *** aic matrix or are going to have to factor the current one
!
      if(ifact.eq.0)then
         call bkfclu (w(llsa),nsfact,nsngu,nnrhs                        &
     &               ,nppblk,nqqblk,llu                                 &
     &               ,bkprnt,nhdat,ier)
      write (line,9001) llu,(nhdat(i),i=1,6)
 9001 format (' ft',i2.2, ' (l*u) done.  nhdat:',6i7)
      call remarx (line)
      else
         klu     =  klublk
         call getcor ('ilu',llilu,klu)
         call openms(llu,w(llilu),klu,0)
         call readms(llu,nhdat,6,1)
         call closms(llu)
         ier=nhdat(1)
      endif
      if ( ier.eq.0 ) go to 500
  200 continue
      iaic    =  0
      do 400 jc = 1,nctrt
          call btrns (jc,cu1)
          call ctrns (jc,zc)
          ii      =  1
          if ( nlopt1.ne.0 ) iaic = iaic + 1
          if ( ier.eq.iaic ) go to 350
          ii      =  2
          if ( nlopt2.ne.0 ) iaic = iaic + 1
          if ( ier.eq.iaic ) go to 350
          go to 400
!                                  bad aic row detected
  350 continue
      call mnmod (ijfgc, 2*nm(kc)-1, ifn, jfn)
      write (6,6200) iaic, ii, kc, iduser(kc)                           &
     &             , ifn, jfn, nlopt1, nlopt2
 6200 format ('0  singularity in matrix was detected while performing'  &
     & ,' elimination on aic row #',i5                                  &
     &    ,/, '   bc #',i4,'  at the control point on network',i5       &
     &    ,2x,2a5,'  at fine grid location (row,col)=',2i3              &
     &   ,/, '   boundary condition options (nlopt1,nlopt2) =',2i5)
      go to 500
!
!
!
  400 continue
  500 continue
      if(ifact.eq.0)call remarx ('1-st factor done')
      if(ifact.eq.1)call remarx ('using pre-factored aic')
      if ( ier.ne.0 ) call a502er ('sinver'                             &
     &                      ,'failure in aic matrix factorization')
!
      call bksolv (w(llsa),nsfact,nsngu,nnrhs                           &
     &            ,llu,lrhs,lbn,lans                                    &
     &            ,bkprnt,nhdat,ier)
      call remarx ('1-st solve done')
!
      if ( ier.ne.0 ) call a502er ('sinver'                             &
     &                      ,'failure in aic matrix solution phase')
!c
!     *  read the solution matrix into core, transpose it, and write  *
!     *  back out                                                     *
!
      rewind nans
!c
!     *  loop ranges over the rows of the solution matrix             *
!
      tcondx  =  0.d0
      do 800 is=1,nsngu
      read(nans)(sols(is,iacase),iacase=1,nacase)                       &
     &         , tconis
      tcondx  =  max( tcondx, abs(  tconis -           1.d0       ) )
  800 continue
      write (6,6000) tcondx
 6000 format (1h0,                                                      &
     &/15x, 35h***********************************                      &
     &/15x, 35h*                                 *                      &
     &/15x, 35h*       condition indicators      *                      &
     &/15x, 35h*                                 *                      &
     &/15x, 20h*  uniform solution ,   e12.6,3h  *                      &
     &/15x, 35h*                                 *                      &
     &/15x, 35h***********************************                      &
     &)
  801 continue
      if(nsngk.eq.0) go to 899
      rewind 93
!c
!     *  read known singularity parameters into solution array        *
!
      do 850 is=1,nsngk
      isp=nsngu+is
      read(93) (sols(isp,iacase),iacase=1,nacase)
  850 continue
  899 continue
      call frecor ('sinver-1')
!
!
!
      if ( nbccp2.le.0 ) go to 2000
      call openms (ntv,niv,nnv,0)
      call readms (ntv,nwv,nctrt,nctrt+1)
!                                  print baseline solution, first case
      if ( iexcp2.ge.1 )                                                &
     &    call outvec ('lambda/0',nsngt,scr)
!                                  set up and run iteration for cp2 matc
      ll      =  450000
!                                  define nf, the nonlinear problem size
      nf      =  nbccp2
!
      call getcor ('dvdl',lldvdl, 4*(nsngu+nsngk) )
      call getcor ('vica',llvica, 3*(nsngu+nsngk) )
      call getcor ('vicd',llvicd, 3*(nsngu+nsngk) )
      call getcor ('aic', llaic,    (nsngu+nsngk) )
!
      if ( nitcp2.le.0 ) goto 1960
!     --------------------
!-----iexcp2 = 2
!     ---------------------
      call getcor ('xvec',llxvec, nf)
      call getcor ('fvec',llfvec, nf)
!                                  allow  25 000 to out-of-core solver
      nss     =  25000
      call getcor ('ss',  llss,  nss)
!                                  allocate all lower level arrays
!         ======================>  be sure to allocate llb if you set <=
!         ======================>  test = .true. in fsolve            <=
      ll = llss
      call getcor ('b',llb,1)
! === call getcor ('b',llb, nf*nf)
!                                  allocate scratch for fsolve
      call getcor ('scr' ,llscr , nf)
      call getcor ('xnew',llxnew, nf)
      call getcor ('fnew',llfnew, nf)
      call getcor ('dphi',lldphi, nf)
      call getcor ('d',   lld,    nf)
!                                  block size in fhybrj: coordinate chgs
      nblkaj  =  20
!                                  allocate scratch for fhybrj
      call getcor ('alam',llalam, nsngt)
      call getcor ('fv',  llfv,   nf)
      call getcor ('dldx',lldldx, nf)
      call getcor ('dfdl',lldfdl, nblkaj*nsngu)
      call getcor ('aj',  llaj,   nblkaj*nf )
!                                  set various flags for fhybrj usage
      mode    =  1
      factor  =  10.d0
      nprint  =  -1.d0
      maxfev  =  40
      tol = 1.d-5
      call dcopy (nf,  0.d0,0,  w(llxvec),1)
!
      do 1600 iacase = 1,nacase
!
      call dcopy (nbccp2,  0.d0,0,  w(llxvec),1)
!                                  solve nonlinear problem for
!                                  current case
      call fsolve (nf,w(llxvec),w(llfvec),nitcp2,nss,w(llss)            &
     &       ,w(llb),w(llscr),w(llxnew),w(llfnew),w(lldphi),w(lld)      &
     &       ,w(lldvdl),w(llvica),w(llvicd),w(llaic)                    &
     &       ,w(llalam),w(llfv),w(lldldx),w(lldfdl),w(llaj)             &
     &       ,nsngt,sols)
      rewind lans
      do 1500 is = 1,nsngu
      read (lans) (dumans(k),k=1,nacase+1),(w(llfvec+k-1),k=1,nbccp2)
      call vip (w(llfvec),1,  w(llxvec),1,  nbccp2,  deltlm)
      sols(is,iacase) = sols(is,iacase) + deltlm
 1500 continue
 1600 continue
!                                  close NLI files: not yet implemented
!
!
 1960 continue
      prtcp2  =  iexcp2.gt.1
      cp2sum  =  istcp2.lt.3
      do 1980 iacase = 1,nacase
      call fcncpx (mxsngt,sols(1,iacase), w(lldvdl),w(llvica),w(llaic)  &
     &            ,rhscp2,fcnmax,  ljac,.false.,prtcp2,cp2sum)
 1980 continue
      call closms (ntv)
!
      goto 2100
!
!
 2000 continue
!                                  generate direct solution summary
      do 2020 k = 1,72
      line(k:k) = ' '
 2020 continue
      write (line,9004)
 9004 format (' direct solution, no iteration performed')
      call remarx (line)
      goto 2100
!
!                                  collection point
 2100 continue
!c
!     *  loop ranges over the columns of the solution matrix          *
!
      rewind nans
      do 900 iacase=1,nacase
      lsa = llsa + (iacase-1)*nsngt
      call dcopy (nsngt,  sols(1,iacase),1, w(lsa),1)
      write(nans) (sols(is,iacase),is=1,nsngt)
  900 continue
!                                     put solutions on records 90-93
      call ixtrns (90+mlofrq,w(llsa),kklr2i*nsngt*nacase)
      write (line,9002) lans
 9002 format (' ft',i2.2,' (singularity file) complete')
      call remarx (line)
      lamprt  =  iextrp.ge.2
      if ( lamprt )                                                     &
     &    call outvec ('lambda/n',nsngt,scr)
!                                  close the LU file
      if ( rlse19 ) then
         fname  =  'rwms19'
         inquire (file=fname,exist=fexist)
         if ( fexist ) then
           open (llu,file=fname,recl=2048/1,access='direct',status='old')
           close (llu,status='delete')
         endif
      endif
!                                  close the AIC file
!----      call closms (nta)
!c
!     *  print out job status and cost for step just completed        *
!
      call frecor ('sinver')
!
      call cstprt ('mtrxsoln')
      return
      END subroutine sinver
! **deck sloft
      subroutine sloft
      implicit double precision (a-h,o-z)
!call lofdat
      common/lofdat/nloft,nslof,loft1,loft2,loft3
!end  lofdat
      write(6,1000) nloft
      call remarx ('no lofting package available yet')
 1000 format(1h1,50x,17hloft computations,////,17h network number =,i5)
      return
      END subroutine sloft
! **deck sngcal
      subroutine sngcal(z,s,tsc)
      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 source strength and/or doublet strength and        *
!     *  gradient at given point on panel. defining quantities of     *
!     *  desired panel are assumed to currently occupy common block   *
!     *  /pandq/.                                                     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the routine calls sinfcc to obtain the influence of each     *
!     *  singularity parameter on the singularity strength and its    *
!     *  derivatives at the evaluation point.  the actual singularity *
!     *  strength and derivatives are then obtained by multiplying the*
!     *  influence coefficients by the respective singularity         *
!     *  parameters.                                                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   dddfs     -local-   - - - -   doublet strength and gradient *
!     *                                 coefficients                  *
!     *                                                               *
!     *   dsdfs     -local-   - - - -   source strength coefficients  *
!     *                                                               *
!     *   icc       -local-   - - - -   sub-panel on which zp lies    *
!     *                                                               *
!     *   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   *
!     *                                                               *
!     *   its       /pandq/   input     panel singularity type        *
!     *                                 =1 source alone               *
!     *                                 =2 doublet alone              *
!     *                                 =3 source and doublet         *
!     *                                                               *
!     *   s         argument  input     vector containing all         *
!     *                                 singularity parameters        *
!     *                                                               *
!     *   sip       -local-   - - - -   array containing only         *
!     *                                 singularity parameters        *
!     *                                 affecting local panel         *
!     *                                 singularity distribution      *
!     *                                                               *
!     *   tsc       argument  output    source strength and doublet   *
!     *                                 strength and gradient at given*
!     *                                 point.                        *
!     *                                 tsc(1)=source strength        *
!     *                                 tsc(2)=doublet strength       *
!     *                                 tsc(3-5)=doublet gradient in  *
!     *                                          global coordinates   *
!     *                                                               *
!     *   z         argument  input     given point expressed in      *
!     *                                 global coordinates            *
!     *                                                               *
!     *   zp        -local-   - - - -   given point projected onto    *
!     *                                 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
      dimension sip(25), dsdfs(16), dddfs(4,25), zp(3)
      dimension s(3500)
      dimension z(3),tsc(5)
!c
!     *  zero out singularity values in case panel is not composite   *
!
      call zero(tsc,5)
!c
!     *  project given point onto panel                               *
!
      call surpro(z,zp,icc)
!c
!     *  calculate the influence of each singularity parameter on the *
!     *  singularity strength and its derivatives                     *
!
      call sinfcc(zp,icc,dsdfs,dddfs)
!c
!     *  ignore doublet computation if panel is pure source panel     *
!
      if(its.lt.2) go to 500
      do 200 ic=1,ind
      is=iid(ic)
  200 sip(ic)=s(is)
!c
!     *  post-multiply by actual doublet parameters                   *
!
      call mxm (dddfs,4,sip,ind,tsc(2),1)
!c
!     *  ignore source computations if panel is pure doublet panel    *
!
  500 if(its.eq.2) go to 900
      do 700 ic=1,ins
      is=iis(ic)
  700 sip(ic)=s(is)
!c
!     *  post-multiply by actual source parameters                    *
!
      call mxm (dsdfs,1,sip,ins,tsc,1)
  900 return
      END subroutine sngcal
! **deck sngdel
      subroutine sngdel (nedaba,kfdseg,kfdkey,kfdsgn                    &
     &                  ,locsrt,keyloc,maps,iflgsp                      &
     &                  ,kptlm,ksgnlm)
      implicit double precision (a-h,o-z)
      dimension nedaba(*), kfdseg(*), kfdkey(*), kfdsgn(*)              &
     &        , locsrt(*), keyloc(*), maps(*),   iflgsp(*)              &
     &        , kptlm(*),  ksgnlm(*)
!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 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 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 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
      common /zspbsc/ kloc
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
      dimension locpak(4), zk(3), zl(3)
!call indedg
!                                                            /indedg/
      common /indedg/ kokseg, kedseg, i1kseg, i2kseg                    &
     &              , lokseg, ledseg, i1lseg, i2lseg
!end  indedg
      logical ident
!
      iabt    =  iabs( kabmtc )
      nedg    =  0
      if ( iabt.ne.0 ) nedg = nedaba(iabt+1) - nedaba(iabt)
      izdc    =  zdc
      ier = 1
      if ( ( izdc.eq.5 .and. nedg.ne.1 )  .or.                          &
     &     ( izdc.ne.5 .and. nedg.eq.1 )        ) go to 1000
      if ( kabmtc .eq. 0 ) go to 950
      naicbc  =  0
      if ( nlopt1.ne.0 .and. nct1.ne.3 ) naicbc = naicbc + 1
      if ( nlopt2.ne.0 .and. nct2.ne.3 ) naicbc = naicbc + 1
      nactbc  =  0
      if ( nlopt1 .ne. 0 ) nactbc = nactbc + 1
      if ( nlopt2 .ne. 0 ) nactbc = nactbc + 1
!                                  check that there is an aic row which
!                                  the matching condition may replace
!                                  and that when this has been done,
!                                  aic"s are no longer needed.
      ier = 2
      if ( nactbc .le. 0 ) go to 1000
      ier = 3
      if ( naicbc .ge. 2 ) go to 1000
      if ( nedg .gt. 2 ) go to 950
      if ( kabmtc .lt. 0 ) go to 950
!                                 we have a 1 or 2 edge matching conditi
      call mnmod ( ijfgc, 2*nm(kc)-1, ifn, jfn)
      call spbsc (kc,ifn,jfn,2,  kbasic,  locsrt,keyloc,maps)
      if ( kbasic.le.0 ) go to 610
      call enrchg (kc,ifn,jfn,zk)
      if ( nedg .eq. 2 ) go to 500
!                                  one edge :  matchhinging to zero
      if ( iextrp.eq.0 ) go to 200
      knaif   =  0
      if ( iflgsp(kbasic) .ne.0 ) write (6,'(1x,a10,1x, 10i12)')        &
     &  'sngdel/1',jcn                                                  &
     &   ,kabmtc,iabt,nedg,kc,ifn,jfn,knaif,kbasic,iflgsp(kbasic)
  200 continue
      iflgsp(kbasic) =  3
      go to 800
!                                  two edges :  check if there are two
!                                  doublet parameters adjacent
  500 continue
      iedg1   =  nedaba(iabt) + 1
      iedg2   =  iedg1 + 1
      ifsg    =  kfdkey( iedg1 )
      if ( ifsg.eq.kfsgc ) ifsg = kfdkey(iedg2)
      call icopy (4,  kfdseg(4*ifsg-3),1,  lokseg,1)
      lnet    =  (ledseg+3)/4
!                                  check on a variety of error and warni
!                                  conditions and possibly issue some ms
      kchk    =  0
      if ( kc.ne.lnet .and. kfsgc.eq.ifsg ) kchk = 1
      if ( kchk.ne.0 ) write (6,'(1x,a10,1x, 10i12)')                   &
     & 'sngdel=chk',kabmtc,izdc                                         &
     &    ,iedg1,iedg2,kc,lnet,kfsgc,ifsg,ledseg,jcn
      if ( kchk.ne.0 )                                                  &
     &    call a502ms ('sngdel','unequal nw-s share fund. sgmt.')
      jfsg    =  kfdkey(iedg1) + kfdkey(iedg2) - ifsg
      call icopy (4,  kfdseg(4*ifsg-3),1, lokseg,1)
      lnet    =  (ledseg+3)/4
      lsd     =  ledseg - (lnet-1)*4
      mfl     =  2*nm(lnet) - 1
      nfl     =  2*nn(lnet) - 1
!                                  more checks on a variety of error
!                                  and warning conditions
      if ( ifsg.eq.kfsgc ) write (6,'(1x,a10,1x, 4i12)')                &
     & 'sngdel=err'                                                     &
     &    ,kfsgc,kfdkey(iedg1),kfdkey(iedg2),jcn
      if ( kfsgc.ne.kfdkey(iedg1) .and. kfsgc.ne.kfdkey(iedg2) )        &
     &write (6,'(1x,a10,1x, 4i12)')                                     &
     & 'sngdel=err',kfsgc,kfdkey(iedg1),kfdkey(iedg2),jcn
      if ( kfsgc.ne.kfdkey(iedg1) .and. kfsgc.ne.kfdkey(iedg2) )        &
     &     CALL AbortPanair('sngdel-1')
      if ( ifsg.eq.kfsgc ) CALL AbortPanair('sngdel-2')
!                                  get the control point's location
!                                  on its matching edge
      call icopy (4,  kfdseg(4*kfsgc-3),1, kokseg,1)
      knet    =  (kedseg+3)/4
      ksd     =  kedseg - (knet-1)*4
      if ( knet.ne.kc )                                                 &
     &   call labort (jcn,kc,'knet .ne. kc, subroutine sngdel')
      call mnmod (ijfgc, 2*nm(kc)-1, ifn, jfn)
      ifnkc   =  ifn
      jfnkc   =  jfn
      if ( ksd.eq.1 ) kptfn = jfn
      if ( ksd.eq.2 ) kptfn = ifn
      if ( ksd.eq.3 ) kptfn = 2*nn(kc) - jfn
      if ( ksd.eq.4 ) kptfn = 2*nm(kc) - ifn
      kpt     =  (kptfn+1)/2
! *** call edgmpi (kedseg,kpt,nedmpa,  kmp)
! *** call fsgcmp (kmp,nedmpa,nfsga,kfdseg,nnett,  kfsg1,kfsg1)
! *** if ( mod(kptfn,2).eq.0 ) kfsg1 = kfsg2
!
      kloc    =  0
      if ( kptfn .eq. 2*i1kseg-1 ) kloc = -1
      if ( kptfn .eq. 2*i2kseg-1 ) kloc = +1
!                                  get the relative sign of the two edge
      ksgn    =  isign( 1, kfdsgn(kfsgc) )
      lsgn    =  isign( 1, kfdsgn(ifsg ) )
      klsgn   =  ksgn * lsgn
!                                  examine points on opposing edge of nw
!                                  lnet for being coincident with the po
!                                  zk on nw kc
      ll1     =  nssa(lnet) + 1
      ll2     =  nssa(lnet+1)
      i1lfn   =  2*i1lseg - 1
      i2lfn   =  2*i2lseg - 1
      do 600 ll = ll1,ll2
      call icopy (4,  locsrt(4*ll-3),1, locpak,1)
      if ( locpak(4) .ne. 2 ) go to 600
      jfn     =  locpak(2)
      ifn     =  locpak(3)
      go to ( 510, 520, 530, 540), lsd
!
  510 continue
          if ( ifn.ne.1 ) go to 600
          lptfn   =  jfn
          go to 550
!
  520 continue
          if ( jfn.ne.nfl ) go to 600
          lptfn   =  ifn
          go to 550
!
  530 continue
          if ( ifn.ne.mfl ) go to 600
          lptfn   =  2*nn(lnet) - jfn
          go to 550
!
  540 continue
          if ( jfn.ne.1 ) go to 600
          lptfn   =  2*nm(lnet) - ifn
          go to 550
!
  550 continue
      call enrchg (lnet,ifn,jfn,zl)
      call pident (zk,zl,ident)
      if ( .not. ident ) go to 600
!                                  make a final check
      if ( lptfn.lt.i1lfn  .or.  lptfn.gt.i2lfn )                       &
     &    go to 600
      lloc    =  0
      if ( lptfn .eq. 2*i1lseg-1 ) lloc = -1
      if ( lptfn .eq. 2*i2lseg-1 ) lloc = +1
      if ( kloc*lloc*klsgn .ge. 0 ) go to 570
!                                  error detected in old logic
      go to 600
!
  570 continue
      llsv    =  ll
      go to 700
  600 continue
!
  610 continue
      if ( iextrp.eq.0 ) go to 620
      write (6,'(1x,a10,1x, 1i12)')                                     &
     & 'no match'
      write (6,'(1x,a10,1x, 8i12)')                                     &
     & 'sngdel/mp',kc,ifn,jfn,kbasic,kloc                               &
     & ,zk(1),zk(2),zk(3)
      write (6,'(1x,a10,1x, 10i12)')                                    &
     & 'sngdel/2',jcn,kabmtc,iedg1,iedg2,ifsg                           &
     &           ,ledseg,lnet,lsd,mfl,nfl
  620 continue
      go to 950
!                                  an equivalent singularity parameter
!                                  has been found
  700 continue
      if ( iextrp.ne.0 )                                                &
     &  write (6,6801) jcn,kfsgc,kc,jfsg,knet,ksd,i1kseg,i2kseg,ksgn    &
     &                             ,kloc,kptfn,ifnkc,jfnkc              &
     &                             ,ifsg,lnet,lsd,i1lseg,i2lseg,lsgn    &
     &                             ,lloc,lptfn,ifn  ,jfn
 6801 format (' jc',i4,2x,2i5,3x,10i5,3x,10i5)
      ll      =  llsv
      ifsg1   =  kfdkey( iedg1 )
      ifsg2   =  kfdkey( iedg2 )
      isgn    =  - kfdsgn(ifsg1) * kfdsgn(ifsg2)
      isgn    =  isign( 1, isgn)
      lnaif   =  keyloc(ll)
      lbasic  =  maps( lnaif )
      if ( iextrp.eq.0 .and. iflgsp(kbasic).eq.0 ) go to 720
      write (6,'(1x,a10,1x, 10i12)')                                    &
     & 'match',ll,lnaif,lbasic,isgn,ifsg,jfsg                           &
     &    ,iflgsp(lbasic),iflgsp(kbasic),kfsgc,kbasic
  720 continue
      knaif   =  0
      if ( iflgsp(kbasic) .ne.0 ) write (6,'(1x,a10,1x, 10i12)')        &
     & 'sngdel/1',jcn                                                   &
     &   ,kabmtc,iabt,nedg,kc,ifn,jfn,knaif,kbasic,iflgsp(kbasic)
      if ( iflgsp(kbasic) .ne. 0 ) return
      iflgsp(kbasic) =  2
      call abteqc (kptlm,ksgnlm,nsngt,  kbasic,lbasic,isgn)
      go to 800
!
  800 continue
      if ( nbinmc.eq.1 ) go to 810
      if ( nbinmc.eq.2 ) go to 820
                 ier = 4
          go to 1000
  810 continue
          nlopt1  =  0
          nbinmc = 0
          go to 950
  820 continue
          nlopt2  =  0
          nbinmc = 0
          go to 950
!
  950 continue
      return
!
 1000 continue
      write (6,'(1x,a10,1x, 10i12)')                                    &
     & 'sngdel/abt',izdc,nedg,nct1,nlopt1,nct2,nlopt2                   &
     &     ,naicbc,nactbc,jcn,ier
      CALL AbortPanair('sngdel-3')
      END subroutine sngdel
! **deck soffbd
      subroutine soffbd
      implicit double precision (a-h,o-z)
!
!     evaluate the off-body velocities and generate appropriate
!     printed output
!
!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 rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!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 rtrnbk
      common /rtrnbk/ cpr(3,4), enr(3,5), diamr, itdm, itsr, icsr, isqnr&
     &              , ipr, kpr, pwr(3), pxr, rfminr, qdltr, rqffr(3,4)  &
     &              , c1r, c2r, c3r, aqr(9), encfr(3)                   &
     &              , sv1r1(3), dv1r1(6), dvzr1(9), amuxr1(3)           &
     &              , sv2r1(3,2), dv2r1(10,2)                           &
     &              , sv8r1(3,8), dv8r1(6,8)                            &
     &              , usvr1(6),  uvmvr1(4,6), amsvr1(3,3), amdvr1(3,3)  &
     &              , sv1r2(3), dv1r2(6), dvzr2(9), amuxr2(3)           &
     &              , sv2r2(3,2), dv2r2(10,2)                           &
     &              , sv8r2(3,8), dv8r2(6,8)                            &
     &              , usvr2(6),  uvmvr2(4,6), amsvr2(3,3), amdvr2(3,3)  &
     &              , sv1r3(3), dv1r3(6), dvzr3(9), amuxr3(3)           &
     &              , sv2r3(3,2), dv2r3(10,2)                           &
     &              , sv8r3(3,8), dv8r3(6,8)                            &
     &              , usvr3(6),  uvmvr3(4,6), amsvr3(3,3), amdvr3(3,3)  &
     &              , sv1r4(3), dv1r4(6), dvzr4(9), amuxr4(3)           &
     &              , sv2r4(3,2), dv2r4(10,2)                           &
     &              , sv8r4(3,8), dv8r4(6,8)                            &
     &              , usvr4(6),  uvmvr4(4,6), amsvr4(3,3), amdvr4(3,3)
      integer rtrnbf(435)
      equivalence (rtrnbf,cpr)
!
!end  rtrnbk
!call sngval
      common /sngval/ nsngv, nsolv
!end  sngval
!call solnt
      common/solnt/naic,nrhs,nans,nsc1,nsc2,nsc3,nsc4,iray(10),mtitle(5)
!end  solnt
!call acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!call irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!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 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 /ofbcom/ zof(3,6000), pvof(4,6000), ivzof(6000)
      dimension pvx(4,4)
!                                  read in offbody evaluation points
      if ( nof.le.0 ) go to 15
      call readmd (nti,zof,nidq(16),16)
      nof     =  min( 6000/nacase, nof)
      call zero (pvof,4*nacase*nof)
      do 10 ia = 1,nacase
          lbzof   =  (ia-1)*nof
          do 5 i = 1,nof
               ivzof(i+lbzof) = ia
    5     continue
          if ( ia.gt.1 ) call xfera (zof,zof(1,lbzof+1),3*nof)
   10 continue
      nofcas  =  nof*nacase
   15 continue
!                                  loop over the panels requested for
!                                  off body calculations
      rewind ntr
      do 50 ipx = 1,npanr
          read (ntr) (rtrnbf(i),i=1,nrdq)
          call rtunpk
          ip      =   ipn
!
          if ( nof.le.0 ) go to 41
          do 40 iof = 1,nof
               isolx   =  0
               call zero (pvx,4*nacase)
               ipc     =  0
               call pivv (isolx,ipc,zof(1,iof),pvx)
               do 35 j = 1,nacase
                    ijof    =  iof + (j-1)*nof
                    pvof(1,ijof) = pvof(1,ijof) + pvx(1,j)
                    pvof(2,ijof) = pvof(2,ijof) + pvx(2,j)
                    pvof(3,ijof) = pvof(3,ijof) + pvx(3,j)
                    pvof(4,ijof) = pvof(4,ijof) + pvx(4,j)
   35          continue
   40     continue
   41     continue
!
   50 continue
!
!                                  complete processing of offbody points
      if ( nof.le.0 ) go to 500
      do 200 iof = 1,nofcas
          if ( tpoff.eq.0.d0 ) call cscal2 (betams,pvof(2,iof),1)
          ia      =  ivzof(iof)
          pvof(2,iof) = pvof(2,iof) + fsv(1,ia)
          pvof(3,iof) = pvof(3,iof) + fsv(2,ia)
          pvof(4,iof) = pvof(4,iof) + fsv(3,ia)
  200 continue
!
      call offbdx (nofcas,ivzof,zof,pvof)
!
  500 continue
      call cstprt ('soffbd  ')
      return
      END subroutine soffbd
! **deck sortak
      subroutine sortak (n,a,key)
      implicit double precision (a-h,o-z)
      integer a(1), asv
      integer key(1)
      m       =  n
      if ( n.le.0 ) return
  100 continue
      m       =  m/2
      if ( m.le.0 ) return
      jmax    =  n - m
      do 200 j = 1,jmax
      ia      =  j
      iap     =  ia + m
  150 if ( a(ia)  .le.  a(iap) ) go to 200
          asv     =  a(ia)
          a(ia)   =  a(iap)
          a(iap)  =  asv
!
          asv     =  key(ia)
          key(ia) =  key(iap)
          key(iap)=  asv
!
          iap     =  ia
          ia      =  ia - m
          if ( ia.gt.0 ) go to 150
  200 continue
      go to 100
      END subroutine sortak
! **deck sortpn
      subroutine sortpn(netgl,netgp,nmk,nnk,npak,epssec,ipvf,           &
     &                  itcsa,ips,array,numtra,ntrnet,netind,           &
     &                  nout)
      implicit double precision (a-h,o-z)
!
!     --------------------- purpose of routine ------------------------
!
!     this routine takes all of the panels on a network that have
!     been cut and tries to connect the segments into traces.  the
!     output from this routine is a list of the panels in each
!     independent trace
!
!     parameters:
!
!        array    matrix    in/out  contains cut geometry information
!        epssec   real      input   tolerance where trace ends are
!                                   considered to be equivalent
!        ips      vector    in/out  panel stack - contains all of the
!                                   panel numbers (global basis) that
!                                   this cutting plane intersects.
!                                   the panels are sorted by traces.
!                                   itcsa provides pointers into ips.
!        itcsa    vector    in/out  contains trace pointers into panel
!                                   stack vector (ips)
!        ipvf     matrix    scrtch  panel visited flag matrix
!                                   col 1 - 1st point in segment
!                                   col 2 - end point in segment
!                                   0 - not visited, 1 - checked
!        netgl    integer   input   global configuration network no.
!        netgp    integer   input   group network number
!        netind   vector    output  contains the global and group
!                                   network indicies for each trace
!                                   col 1 - global network index
!                                   col 2 - group network index
!        nmk      integer   input   number of rows in network k
!        nnk      integer   input   number of columns in network k
!        npak     integer   input   number of panels up to network k
!        nout     integer   input   standard output unit
!        numtra   integer   in/out  total number of traces so far
!        ntrnet   integer   output  number of traces on this network
!
!     --------------------- formal parameter list ---------------------
!
      dimension array(21,*)
      integer ipvf(2,(nmk-1)*(nnk-1)),itcsa(*)
      integer ips(*),netind(2,*)
!
!     --------------------- labelled common blocks --------------------
!
!
!     --------------------- local array declarations ------------------
!
      integer neighs(9,2)
!
!     --------------------- executable code ---------------------------
!
      call jzero (ipvf, 2*(nmk-1)*(nnk-1) )
      call jzero (neighs,18)
!
!     initialize counters for this first string
!
      ntrnet = 0
      numpan = itcsa(numtra+1)
!
!     initialize counters for all traces in this network
!
      ibegtr = 1
!
!     outer loop over all segments looking for new traces
!
      do 1000 ipan = 1,(nmk-1)*(nnk-1)
!
!     work only with panels that have been cut
!
      if (nint(array(1,ipan+npak)) .ne. 0) then
!
!        new trace within this network
!
         if ((ipvf(1,ipan) .eq. 0) .and. (ipvf(2,ipan) .eq. 0)) then
            numtra = numtra + 1
            ntrnet = ntrnet + 1
            ibegtr = ibegtr + numpan
            ipanno = ipan + npak
            netind(1,numtra) = netgl
            netind(2,numtra) = netgp
            call addpan ('new',ipanno,1,iother,array(1,ipanno),         &
     &                   ips(ibegtr),numpan,nout)
!
!           search other segments to see if they are connected
!           first look at tail of basis segment then head
!
            do 900 iend = 2,1,-1
!
!              get descriptors for basis end
!
               ienbas = iend
               ipnbas = ipan
               if (iend .eq. 1) then
                  ixbas = 2
               else
                  ixbas = 5
               endif
!
!              if the end has not been connected, try
!
               if (ipvf(iend,ipan) .eq. 0) then
!
!                 look at all other non-used segment ends from
!                 surrounding panels and see if they
!                 are connected to this one.  this do-while loop
!                 follows traces building a string until it hits a dead
!                 end.
!
!     ----------- top of do-while loop
  100             continue
!
                  ipvf(ienbas,ipnbas) = 1
                  dist = 1.0d10
!
!                 find trace end with minimum dist. to basis trace end
!                 looking only at neighboring panels
!
                  call mnmod(ipnbas,nmk-1,ipbrow,jpbcol)
!
                  do 810 jcol = max(1,jpbcol-1),min(nnk-1,jpbcol+1)
!
                     do 800 irow = max(1,ipbrow-1),min(nmk-1,ipbrow+1)
!
                        ipncmp = irow + (jcol-1)*(nmk-1)
                        if ((ipncmp .eq. ipnbas) .or.                   &
     &                      (nint(array(1,ipncmp+npak)).eq.0)) go to 800
!
!                       check both ends
!
                        do 700 kend = 1,2
!
!                          check trace end only if it has not been used
!
                           if (ipvf(kend,ipncmp) .eq. 0) then
!
                              if (kend .eq. 1) then
                                 ixcmp = 2
                              else
                                 ixcmp = 5
                              endif
!
                              call distnc (array(ixcmp,ipncmp+npak),    &
     &                             array(ixbas,ipnbas+npak),dtest)
!
                              if (dtest .lt. dist) then
                                 dist   = dtest
                                 ipnsav = ipncmp
                                 iensav = kend
                              endif
!
                           endif
!
  700                   continue
!
  800             continue
!
  810             continue
!
!                 now see if trace ends are actually connected
!
                  if (dist .lt. epssec) then
!
!                    add trace to string only if both ends are free
!
                     iother = mod(iensav,2) + 1
!
                     if (ipvf(iother,ipnsav) .eq. 0) then
!
!                       ****** match *****
!                       where the segment is added depends on which
!                       end of the trace you are using as a basis
!
                        ipanno = ipnsav + npak
                        if (iend .eq. 1) then
                           call addpan ('top',ipanno,iensav,            &
     &                          iother,array(1,ipanno),ips(ibegtr),     &
     &                          numpan,nout)
                        else
                           call addpan ('bottom',ipanno,iensav,         &
     &                          iother,array(1,ipanno),ips(ibegtr),     &
     &                          numpan,nout)
                        endif
!
!                       mark old end checked, make other end
!                       of new trace the basis end and go to
!                       top of do-while loop
!
                        ipvf(iensav,ipnsav) = 1
                        ienbas = iother
                        ipnbas = ipnsav
                        if (iother .eq. 1) then
                           ixbas  = 2
                        else
                           ixbas = 5
                        endif
!
!   ------------------- bottom of do-while loop
!
                        go to 100
!
                     else
!
!                       if other end of matching trace has already
!                       been connected, dont connect this one
!                       but mark it visited.
!                       this is the end of the string on this end
!
                        ipvf(iensav,ipnsav) = 1
                     endif
!
                  endif
!
               endif
!
  900       continue
!
!        mark trace used and go to the next one
!
         else
            ipvf(1,ipan) = 1
            ipvf(2,ipan) = 1
         endif
!
         itcsa(numtra+1) = itcsa(numtra) + numpan
!
      endif
 1000 continue
!
!     subroutine end
!
      return
      END subroutine sortpn
! **deck sortsp
      subroutine sortsp (nmk,nnk,npak,    is,ips,ipvf,  npanfp,array)
      implicit double precision (a-h,o-z)
      dimension array(21,npanfp)
!
!     purpose: sort sectional properties data by network
!
!     limitations: up to indtrc ( 10 ) independent traces per network
!
!
!     ips       panel-stack
!     is        counter of total panels cut
!     itcs      trace-counter-stack
!     ipvf      panel-visited-flag
!
!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 secscr
      common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin  &
     &             , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2)
!end  secscr
!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 sortpar
!     maximum number of panels sorted
      common /sortpr/ sortmx
      integer sortmx
!     maximum number of traces per network
                                            parameter (indtrc = 100)
!end  sortpar
!
      dimension ips(mxntpn), itcs(indtrc)
      dimension ipvf(mxntpn), neighs(9,2)
!
      sortmx  =  mxntpn
!
! initialize trace counters
      do 50 it = 1, indtrc
         itcs(it)=0
   50 continue
      it=0
!
! initialize panel-stack to always point to first panel of network
      do 52 ipv=1,sortmx
        ips(ipv) = 1
   52 continue
!
! initialize panel-visited-flag
      do 55 ipv = 1, sortmx
         ipvf(ipv) = 0
   55 continue
!
! initialize global counter for panel-stack
      iscg = 0
!
! **********************************************************************
!
   60 continue
!
! determine whether more than one trace exists in a network
! while (more panels cut and panel not visited) do
!
! initialize stack counter
!
      isc=0
!
! find whether an edge panel is cut
! loop on edges of network
!
      irow = 1
      do 65 icol = 1, nnk - 1
         call pannum( irow, nmk, icol, ip)
         if( ( array(1,ip+npak) .ne. 0 ) .and.                          &
     &       ( ipvf ( ip ) .ne. 1 )       ) go to 190
   65 continue
!
      icol = 1
      do 70 irow = 1, nmk - 1
         call pannum( irow, nmk, icol, ip)
         if( ( array(1,ip+npak) .ne. 0 ) .and.                          &
     &       ( ipvf ( ip ) .ne. 1 )       ) go to 190
   70 continue
!
      icol = nnk - 1
      do 75 irow = 1, nmk - 1
         call pannum( irow, nmk, icol, ip)
         if( ( array(1,ip+npak) .ne. 0 ) .and.                          &
     &       ( ipvf ( ip ) .ne. 1 )       ) go to 190
   75 continue
!
      irow = nmk - 1
      do 80 icol = 1, nnk - 1
         call pannum( irow, nmk, icol, ip)
         if( ( array(1,ip+npak) .ne. 0 ) .and.                          &
     &       ( ipvf ( ip ) .ne. 1 )       ) go to 190
   80 continue
! end-loop
!
! find whether an interior panel is cut
! loop on interior of network
!
      do 170 irow = 2, nmk - 2
         do 170 icol = 2, nnk - 2
         call pannum( irow, nmk, icol, ip)
         if( ( array(1,ip+npak) .ne. 0 ) .and.                          &
     &       ( ipvf ( ip ) .ne. 1 )       ) go to 190
         call pannum( irow, nmk, icol, ip)
         if( ( array(1,ip+npak) .ne. 0 ) .and.                          &
     &       ( ipvf ( ip ) .ne. 1 )       ) go to 190
  170 continue
! end-loop
!
! no more panels were cut
!
      go to 600
!
  190 continue
!
!     "starting panel", ip, has been found
      ipc=ip
!
      it=it+1
      isc=isc+1
      iscg = iscg + 1
      ips(iscg) = ipc
      itcs(it)=isc
      ipvf(ipc)=1
!
  200 continue
!     until( neighbor list is exhausted or neighbor all have been visite
!
      dmin = 1.d+10
!
!     find neighbor
!
      call neghbr( nmk, nnk, ipc, neighs)
!
      if( neighs(5,2) .eq. 4 ) go to 600
!
      do 300 jj=1,9
      if( jj .eq. 5 ) go to 300
      if( .not.((      neighs(jj,2)  .eq. 0 ) .and.                     &
     &          ( ipvf(neighs(jj,1)) .ne. 1 ))         ) go to 300
!
!     find the nearest, non-visited neighbor
!
      call distnc( array(2,neighs(jj,1)+npak), array(2,ipc+npak), dist)
        if( dist .gt. dmin) go to 270
          dmin = dist
          np = neighs(jj,1)
!
  270 call distnc( array(2,neighs(jj,1)+npak), array(5,ipc+npak), dist)
        if( dist .gt. dmin) go to 280
          dmin = dist
          np = neighs(jj,1)
!
  280 call distnc( array(5,neighs(jj,1)+npak), array(2,ipc+npak), dist)
        if( dist .gt. dmin) go to 290
          dmin = dist
          np = neighs(jj,1)
!
  290 call distnc( array(5,neighs(jj,1)+npak), array(5,ipc+npak), dist)
        if( dist .gt. dmin) go to 300
          dmin = dist
          np = neighs(jj,1)
!
  300   continue
!
        if( dmin .eq. 1.d+10 ) go to 310
!
         if( isc .eq. nmk*nnk ) go to 600
         ipc=np
         isc=isc+1
      iscg = iscg + 1
      ips(iscg) = ipc
         itcs(it)=isc
         ipvf(ipc)=1
         go to 200
!     end-until
!
  310 go to 60
!
! end-while
! **********************************************************************
!
  600 continue
      is = 0
      do 700 itc = 1, indtrc
         is = is + itcs( itc )
  700 continue
!
!     write(6,1000) (jj, ips(jj), jj=1,is)
!1000 format(1x,i10,2x,i20)
      if( is .gt. nmk*nnk ) is = nmk*nnk
!
!
      return
      END subroutine sortsp
! **deck sorttr
      subroutine sorttr (epssec,itcsa,ips,array,itvf,ntra,ntrstr,numstr &
     &                  ,isinfo,nout)
      implicit double precision (a-h,o-z)
!
!     --------------------- purpose of routine ------------------------
!
!     this routine takes all of the independent traces and tries to
!     connect those that it can into strings.  the output from this
!     routine is a list of the traces and the pointers to them
!     for each independent string
!
!     parameters:
!
!        array    matrix    input   contains cut geometry information
!        epssec   real      input   tolerance where trace ends are
!                                   considered to be equivalent
!        ips      vector    input   panel stack - contains all of the
!                                   panel numbers (global basis) that
!                                   this cutting plane intersects.
!                                   the panels are sorted by traces.
!                                   itcsa provides pointers into ips.
!        isinfo   matrix    output  list containing the information
!                                   about traces making up the strings
!                                   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)
!        itcsa    vector    input   contains trace pointers into panel
!                                   stack vector (ips)
!        itvf     matrix    scrtch  trace visited flag matrix
!                                   col 1 - 1st point in trace
!                                   col 2 - end point in trace
!                                   0 - not visited, 1 - checked
!        nout     integer   input   standard output unit
!        ntra     integer   input   total number of traces in this group
!        ntrstr   vector    output  number of traces in each string
!        numstr   integer   output  total number of strings in this cut
!
!     --------------------- formal parameter list ---------------------
!
      dimension array(21,*)
      integer itvf(2,ntra),ntrstr(ntra),isinfo(4,ntra),itcsa(ntra+1)
      integer ips(*)
!
!     --------------------- labelled common blocks --------------------
!
!
!     --------------------- local array declarations ------------------
!
!
!     --------------------- executable code ---------------------------
!
      call jzero (itvf,2*ntra)
!
!     initialize counters for this first string
!
      numstr = 0
      numtra = 0
!
!     initialize counters for all strings in this cut plane
!
      ibegst = 1
!
!     outer loop over all traces looking for new strings
!
      do 1000 itra = 1,ntra
!
!        new string within this cut
!
         if ((itvf(1,itra) .eq. 0) .and. (itvf(2,itra) .eq. 0)) then
            numstr = numstr + 1
            ibegst = ibegst + numtra
            call addtra ('new',itra,1,itcsa                             &
     &                  ,isinfo(1,ibegst),numtra,nout)
!
!           search other traces to see if they are connected
!           to either end of the basis trace
!
            do 900 iend = 1,2
!
!              get descriptors for basis end
!
               ienbas = iend
               itrbas = itra
               if (iend .eq. 1) then
                  ixbas = 2
                  indbas = itcsa(itra) + 1
               else
                  ixbas = 5
                  indbas = itcsa(itra+1)
               endif
!
!              if the end has not been connected, try
!
               if (itvf(iend,itra) .eq. 0) then
!
!                 look at all other non-used trace ends and see if they
!                 are connected to this one.  this do-while loop
!                 follows traces building a string until it hits a dead
!                 end.
!
!     ----------- top of do-while loop
  100             continue
!
                  itvf(ienbas,itrbas) = 1
                  dist = 1.0d10
!
!                 find trace end with minimum dist. to basis trace end
!
                  do 800 ktra = 1,ntra
!
!                    check both ends
!
                     do 700 kend = 1,2
!
!                       check trace end only if it has not been used
!
                        if (itvf(kend,ktra) .eq. 0) then
!
                           if (kend .eq. 1) then
                              ixcmp = 2
                              indcmp = itcsa(ktra) + 1
                           else
                              ixcmp = 5
                              indcmp = itcsa(ktra+1)
                           endif
!
                           call distnc (array(ixcmp,ips(indcmp)),       &
     &                               array(ixbas,ips(indbas)),dtest)
!
                           if (dtest .lt. dist) then
                              dist   = dtest
                              itrsav = ktra
                              iensav = kend
                           endif
!
                        endif
!
  700                continue
!
  800             continue
!
!                 now see if trace ends are actually connected
!
                  if (dist .lt. epssec) then
!
!                    add trace to string only if both ends are free
!
                     iother = mod(iensav,2) + 1
!
                     if (itvf(iother,itrsav) .eq. 0) then
!
!                       ****** match *****
!                       where the trace is added depends on which
!                       end of the string you are using as a basis
!
                        if (iend .eq. 1) then
                           call addtra ('top',itrsav,iensav,itcsa       &
     &                                 ,isinfo(1,ibegst),numtra,nout)
                        else
                           call addtra ('bottom',itrsav,iensav,itcsa    &
     &                                 ,isinfo(1,ibegst),numtra,nout)
                        endif
!
!                       mark old end checked, make other end
!                       of new trace the basis end and go to
!                       top of do-while loop
!
                        itvf(iensav,itrsav) = 1
                        ienbas = iother
                        itrbas = itrsav
                        if (iother .eq. 1) then
                           ixbas  = 2
                           indbas = itcsa(itrsav) + 1
                        else
                           ixbas = 5
                           indbas = itcsa(itrsav+1)
                        endif
!
!   ------------------- bottom of do-while loop
!
                        go to 100
!
                     else
!
!                       if other end of matching trace has already
!                       been connected, dont connect this one
!                       but mark it visited.
!                       this is the end of the string on this end
!
                        itvf(iensav,itrsav) = 1
                     endif
!
                  endif
!
               endif
!
  900       continue
!
!        mark trace used and go to the next one
!
         else
            itvf(1,itra) = 1
            itvf(2,itra) = 1
         endif
!
         ntrstr(numstr) = numtra
!
 1000 continue
!
!     subroutine end
!
      return
      END subroutine sorttr
! **deck spbsc
      subroutine spbsc (kc,ifn,jfn,isd,  kbasic,  locsrt,keyloc,maps)
      implicit double precision (a-h,o-z)
      dimension locsrt(1), keyloc(1), maps(1)
!
!         given a specification of a singularity by: [kc,ifn,jfn,isd]
!         where:
!                 kc     =  nw number
!                 ifn    =  row f.g. index
!                 jfn    =  col f.g. index
!                 isd    =  sing. type [1=sg,2=mu,3=mu/x on wake]
!         find the location of the singularity in the locsrt data
!         structure which contains entries for every naive sing.
!         parm.   when the position of the sing. parm. is found,
!         the naive index is obtained from the key array keyloc
!         generated when locsrt was originally sorted, and then
!         the  naive-to-basic  map,  maps is used to get kbasic.
!
!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 locpak(4)
      dimension locind(4)
      common /zspbsc/ kloc
!
      kbasic  =  0
      locpak(1) = kc
      locpak(2) = jfn
      locpak(3) = ifn
      locpak(4) = isd
      call icopy (4,  locpak,1, locind(1),1)
      nspnwn  =  nssa(kc+1) - nssa(kc)
      lsp     =  nssa(kc) + 1
      call ibsrc2 (locsrt,lsp,nspnwn,locind,kl)
      kl      =  kl+1 + nssa(kc)
      nsngn   =  nssa(nnett+1)
      if ( kl.lt.1 .or. kl.gt.nsngn ) go to 950
      if ( locind(1) .ne. locsrt(4*kl-3) .or.                           &
     &     locind(2) .ne. locsrt(4*kl-2) .or.                           &
     &     locind(3) .ne. locsrt(4*kl-1) .or.                           &
     &     locind(4) .ne. locsrt(4*kl  ) ) go to 950
      knaif   =  keyloc(kl)
      kbasic  =  maps(knaif)
  950 continue
!                                  return kl value as kloc to sngdel
      kloc    =  kl
      return
      END subroutine spbsc
! **deck srchol
      subroutine srchol (ia,n,ialx,lx)
      implicit double precision (a-h,o-z)
!         search an ordered list  ia(1:n)  and return the value  lx
!         for which  ia(lx) = ialx.   if  ialx  does not appear,  l = 0
!         is returned.  if the list is not ordered, a fatal error messag
!         may be printed.
      integer ia(1)
      data ncall,niter/0,0/
      ncall = ncall + 1
      nloop   =  0
      lx      =  0
      if ( n .le. 0 ) return
      ial     =  ialx
      lmin    =  1
      iamin   =  ia(1)
      l       =  1
      if ( ial - iamin ) 700,1000,10
   10 lmax    =  n
      iamax   =  ia(n)
      l       =  n
      if ( ial - iamax ) 20,1000,600
   20 continue
      if ( iamin.ge.iamax  .or.  lmin.ge.lmax-1 ) go to 600
      l       =  max ( lmin+1, min ( lmax-1,                            &
     &              lmin +  ((ial-iamin)*(lmax-lmin))/(iamax-iamin)   ))
      niter   =  niter + 1
      nloop   =  nloop+1
      if ( nloop .gt. n ) go to 2000
      if ( ia(l) - ial )  30,1000,40
   30 lmin    =  l
      iamin   =  ia(l)
      go to 20
   40 lmax    =  l
      iamax   =  ia(l)
      go to 20
  600 if ( lmin.lt.lmax  .and.  iamin.gt.iamax ) go to 2000
      if ( lmin.ne.lmax  .and.  iamin.eq.iamax ) go to 2000
  700 continue
      l       =  0
 1000 lx      =  l
      return
 2000 continue
      write(6,2100) l,ia(l),lmin,iamin,lmax,iamax
 2100 format ('  fatal error in srchol  ',6i10)
      write (6,6100) n, ialx, (ia(i),i=1,n)
 6100 format ('   n = ',i5,'  ialx =',i5,'    ia follows ..... '        &
     &  ,/, (2x,20i6) )
      CALL AbortPanair('srchol')
      stop
      END subroutine srchol
! **deck ssing
      subroutine ssing
      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 defining quantities associated with network       *
!     *  singularity splines                                          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!c
!     *  compute singularity spline defining quantities               *
!
!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
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
      call setcor ('ssing')
      call igtcor ('keyl',llkeyl,mxsngt)
      call igtcor ('maps',llmaps,mxsngt)
      call igtcor ('locs',lllocs,4*mxsngt)
      call tsing (w(llkeyl),w(llmaps),w(lllocs))
!c
!     *  print out job status and cost for step just completed        *
!
      call frecor ('ssing')
      call cstprt ('singular')
      return
!---  return
      END subroutine ssing
! **deck stedge
      subroutine stedge (ksd,t,svar,tvar)
      implicit double precision (a-h,o-z)
!
      go to (100,200,300,400), ksd
  100 continue
      svar  =  1.d0-2.d0*t
      tvar  =  1.d0
      go to 500
  200 continue
      svar  = -1.d0
      tvar  =  1.d0-2.d0*t
      go to 500
  300 continue
      svar  =  2.d0*t-1.d0
      tvar  = -1.d0
      go to 500
  400 continue
      svar  =  1.d0
      tvar  =  2.d0*t-1.d0
      go to 500
!
  500 continue
      return
      END subroutine stedge
! **deck step
      subroutine step(neqn,t,relerr,abserx,iflag,                       &
     &   y,  p, yp,  phi, alpha, beta, sig, v, w, g,                    &
     &   phase1, psi, x, h, hold, start, told, delsgn, ns,              &
     &    k, kold, ifail, icomp, stiff, crash, phimax,                  &
     &   icore, ipos, mxorp1, mxorp2, eps,                              &
     &   ipts1, ipts2, iptr, knew, dumst, stmln, poten,                 &
     &   numptx, mxordx)
      implicit double precision (a-h,o-z)
!**
!**
!**       this subroutine is a modification of code given in the
!**       text book shampine/gordon. the code has been modified so
!**       that upto icore equations can be worked on asynchronously.
!**       in this application, function f evaluation is time
!**       consuming and requires so much code that it may have to be
!**       overlayed. to save computer time and overlay swaps, icore
!**       equations are worked on simultaneously. in the overlay
!**       containing step, upto icore equation are worked on till a
!**       value of f is required. at that point icomp is set to a
!**       suitable value and control returned to setup1. after this
!**       is done for all equations, setup1 calls for function
!**       evaluation. when step calls in next time, the icomp
!**       directs branch to the statement right after previous call
!**       to f. in this manner for each step progress, step is called
!**       3 or 4 times. however overlay swap is reduced
!**       tremendously.  in this way per step progress of icore
!**       equations requires 3 or 4 overlay swaps.  if the step
!**       code had not been not modified, then for the same step
!**       progress overlay step would be increased by a factor
!**       of icore.
!**        ofcourse this requires excessive amount of data
!**       saving but we feel that it is worth it.
!**
!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
      dimension dumst(3,icore), stmln(7,numptx)
      dimension y(neqn),  p(neqn), yp(neqn),                            &
     &    phi(neqn,mxorp2), alpha(mxordx),                              &
     &    beta(mxordx), sig(mxorp1), v(mxordx), w(mxordx),              &
     &    g(mxorp1), psi(mxordx)
      dimension ipts1(icore), ipts2(icore)
!**
      dimension gstr(13), two(13)
      logical start, crash, phase1
!**
      data twou / 1.5d-14 /
      data fouru / 3.d-14 /
      data two/2.d0,4.d0,8.d0,16.d0,32.d0,64.d0,128.d0,256.d0,512.d0,   &
     &         1024.d0, 2048.d0, 4096.d0, 8192.d0/
!**
      data gstr /0.500d0, 0.0833d0, 0.0417d0,0.0264d0,0.0188d0,0.0143d0,&
     &  0.0114d0, 0.00936d0, 0.00789d0, 0.00679d0, 0.00592d0, 0.00524d0,&
     &           0.00468d0/
      data icrash/0/
!**
!**       go to different locations depending on icomp
!**
      go to(1000, 2000, 3000, 4000 ), icomp
!**
!**       new step
!**
 1000 continue
!**
!**       *** begin block 0 ***
!**       check if step size or error tolerance is too smal for
!**       machine precision. if first step, initialize phi array and
!**       estimate a starting step size
!**
!**       if step size too small compute an acceptable one.
!**
      crash = .true.
      if(abs(h).ge. fouru*abs(x))  go to 1005
        h = sign(fouru*abs(x), h)
        return
 1005 p5eps = 0.5d0 * eps
!**
!**        if error tolerance too small, increase it to an acceptable
!**        one
!**
      round = 0.d0
      do 1010 l = 1, neqn
        round = round + y(l) * y(l)
 1010 continue
      round = twou * sqrt(round)
      if(p5eps .ge. round) go to 1015
        eps = 2.d0 * round * (1.d0 + fouru)
        return
 1015 crash = .false.
      g(1) = 1.d0
      g(2) = 0.5d0
      sig(1) = 1.d0
      if(.not.start) go to 2099
!**
!**       initialize compute appropriate step size for first step.
!**       because of call to f in original code, icomp is set = 2
!**       and in next call icomp = 2 bring transfer directly to
!**       2000.
!**
      icomp = 2
        return
!**
!**           f computed
!**
 2000 continue
!**
!**     print out initial values
!**
      ipts2(iptr) = ipts2(iptr) + 1
      kk = 0
      iabc = ipts1(iptr)
      write (ntsmln) ipts1(iptr),ipts2(iptr),x,y(1),y(2),y(3),          &
     &     yp(1), yp(2), yp(3), poten, kk, stmln(7,iabc)
!**
!**          progress further
!**
      sum = 0.d0
      do 2020 l = 1,neqn
        phi(l,1) = yp(l)
        phi(l,2) = 0.d0
        sum = sum + yp(l) * yp(l)
 2020 continue
      sum = sqrt(sum)
      absh = abs(h)
      if(eps.lt.16.d0*sum*h*h) absh = 0.25d0 * sqrt(eps/sum)
      h = sign( max (absh,fouru*abs(h)),h)
      hold = 0.d0
      k = 1
      kold = 0
      start = .false.
      phase1 = .true.
 2099 continue
      ifail = 0
!**
!**       ***  end  block 0 ***
!**
!**       ***  begin block 1 ***
!**
!**       compute coefficients of formulas for this step. avoid
!**       computing those quantities not changed when step size is
!**       not changed.
!**
 2100 kp1 = k + 1
      kp2 = k + 2
      km1 = k - 1
      km2 = k - 2
!**
!**        ns is the number of steps taken with size h, including the
!**        current one. when k.lt.ns no coefficients change
      if(h.ne.hold) ns = 0
      ns = min (ns+1,kold+1)
      nsp1 = ns + 1
      if(k.lt.ns) go to 2199
!**
!**       compute those components of alpha, beta, psi, sig, which
!**       are changed.
!**
      beta(ns) = 1.d0
      realns = ns
      alpha(ns) = 1.d0 / realns
      temp1 = h*realns
      sig(nsp1) = 1.d0
      temp1 = h*realns
      sig(nsp1) = 1.d0
      if(k.lt.nsp1) go to 2110
      do 2105  i = nsp1,k
        im1 = i-1
        temp2 = psi(im1)
        psi(im1) = temp1
        beta(i) = beta(im1) * psi(im1) / temp2
        temp1  = temp2 + h
        alpha(i) = h / temp1
        reali = i
      sig(i+1)  = reali * alpha(i) * sig(i)
 2105 continue
 2110 psi(k) = temp1
!**
!**         compute coefficients g(*)
!**         initialize v(*) and set w(*). g(2) is set above
!**
      if(ns.gt.1) go to 2120
        do 2115 iq = 1, k
          temp3 = iq * (iq + 1)
          v(iq) = 1.d0 / temp3
         w(iq) = v(iq)
 2115   continue
        go to 2140
!**
!**         if order was raised update diagonal part of v(*)
!**
 2120 continue
      if(k.le.kold) go to 2130
      temp4 = k*kp1
      v(k) = 1.d0 / temp4
      nsm2 = ns - 2
      if(nsm2.lt.1) go to 2130
        do 2125 j = 1,nsm2
          i = k - j
          v(i) = v(i) - alpha(j+1) * v(i+1)
 2125   continue
!**
!**       update v(*) and set w(*)
!**
 2130 continue
      limit1 = kp1 - ns
      temp5 = alpha(ns)
      do 2135 iq = 1, limit1
        v(iq) = v(iq) - temp5 * v(iq+1)
        w(iq) = v(iq)
 2135 continue
      g(nsp1) = w(1)
!**
!**       compute g(*) in the work vector w(*)
!**
 2140 nsp2 = ns + 2
      if(kp1.lt.nsp2)  go to 2199
        do 2150 i = nsp2,kp1
          limit2 = kp2 - i
          temp6 = alpha(i-1)
          do 2145 iq = 1,limit2
            w(iq) =  w(iq) - temp6*w(iq+1)
 2145     continue
          g(i) = w(1)
 2150   continue
 2199 continue
!**
!**     *** end block 1   ***
!**
!**     *** begin block 2 ***
!**
!**       predict a solution p(*). evaluate derivatives using predicted
!**       solution. estimate local error at order k and at orders k-1,
!**       k-2 as if constant step sizes were used
!**
!**       change phi to phi star
!**
      if(k.lt.nsp1) go to 2215
        do 2210 i = nsp1,k
          temp1 = beta(i)
          do 2205 l = 1, neqn
            phi(l,i) = temp1 * phi(l,i)
 2205     continue
 2210   continue
 2215 continue
!**
!**       predict solution and differences
!**
      do 2220 l = 1,neqn
        phi(l,kp2) = phi(l,kp1)
        phi(l,kp1) = 0.d0
        p(l) = 0.d0
 2220 continue
      do 2230 j = 1,k
        i = kp1 - j
        ip1 = i + 1
        temp2 = g(i)
        do 2225 l = 1, neqn
          p(l) = p(l) + temp2*phi(l,i)
          phi(l,i) = phi(l,i) + phi(l,ip1)
 2225   continue
 2230 continue
!**
 2240 continue
      do 2245 l = 1,neqn
        p(l) = y(l) + h*p(l)
 2245 continue
 2250 xold = x
      x = x + h
      absh = abs(h)
!**
!**       the call to f in setup1 is made with x,y,and yp. store
!**       y values in yinp and p in y. on return values are restored.
!**
      do 2252 l = 1, neqn
        abc = y(l)
        y(l) = p(l)
        p(l) = abc
 2252 continue
!**
!**       set icomp and return
!**
      icomp = 3
      return
!**
!**         control comes here after computing f. restore values of
!**         p and y.
!**
 3000 continue
      do 3254 l = 1,neqn
        abc = p(l)
        p(l) = y(l)
        y(l) = abc
 3254 continue
!**
!**        estimate errors at k,k-1,k-2
!**
      erkm2 = 0.d0
      erkm1 = 0.d0
      erk   = 0.d0
      km1 = k - 1
      km2 = k - 2
      kp1 = k + 1
      kp2 = k + 2
      absh = abs(h)
      xold = x - h
      p5eps = 0.5d0 * eps
      do 3265 l = 1, neqn
        temp3 = 1.d0
        temp4 = yp(l) - phi(l,1)
        if(km2) 3265, 3260, 3255
 3255   erkm2 = erkm2 + ((phi(l,km1) + temp4) * temp3)**2
 3260   erkm1 = erkm1 + ((phi(l,k) + temp4) * temp3) **2
 3265   erk = erk + (temp4 * temp3) ** 2
      if(km2) 3280, 3275, 3270
 3270 erkm2 = absh * sig(km1) * gstr(km2) * sqrt(erkm2)
 3275 erkm1 = absh * sig(k) * gstr(km1) * sqrt(erkm1)
 3280 temp5 = absh * sqrt(erk)
      err = temp5 * (g(k) - g(kp1))
      erk = temp5 * sig(kp1) * gstr(k)
      knew = k
!**
!**         test if order should be lowered
!**
      if(km2) 3299, 3290, 3285
 3285 continue
      if(max(erkm1,erkm2)  .le. erk) knew = km1
      go to 3299
 3290 continue
      if(erkm1.le.0.5d0*erk) knew = km1
!**
!**       test if step successful
!**
 3299 continue
      if(err.le.eps) go to 3400
!**
!**     *** end block 2 ***
!**
!**     *** begin block 3 ***
!**       the step is unsuccessful. restore x, phi(*,*) psi(*).
!**       if third consecutive failure set order to one. if step
!**       fails more than three times consider an optimal step size.
!**       double error tolerance and return if estimated step size is
!**       too small for machine precision.
!**
!**       restore x, phi(*,*) and psi(*)
!**
      phase1 = .false.
      x = xold
      do 3310  i = 1,k
        temp1 = 1.d0 / beta(i)
        ip1 = i + 1
        do 3305 l = 1,neqn
          phi(l,i) = temp1 * (phi(l,i) - phi(l,ip1))
 3305   continue
 3310 continue
      if(k.lt.2) go to 3320
        do 3315 i = 2,k
          psi(i-1) = psi(i) - h
 3315   continue
!**
!**       on third failure set order to one. thereafter use optimal
!**         step size
!**
 3320 continue
      ifail = ifail + 1
      temp2 = 0.5d0
      if(ifail - 3)  3335, 3330, 3325
 3325   if(p5eps.lt.0.25d0*erk) temp2 = sqrt(p5eps/erk)
 3330   knew = 1
 3335 continue
      h =  temp2 * h
      if(abs(h).lt.abs(hmin)) h = sign(hmin,h)
      if(abs(h).gt.abs(hmax)) h = sign(hmax,h)
      k =  knew
      if(abs(h).ge.fouru*abs(x)) go to 3340
        crash = .true.
        h = sign(fouru*abs(x),h)
       if(abs(h).lt.abs(hmin)) h = sign(hmin,h)
       if(abs(h).gt.abs(hmax)) h = sign(hmax,h)
        eps = eps + eps
        icomp = 1
        iflag = 3
        return
 3340 continue
      if( abs(h) .gt. abs(hmin) .and. ifail .le. 5 ) go to 2100
      if( icrash .ge. 4 ) crash = .true.
      if( icrash .ge. 4 ) icrash = -1
      if( .not. crash  ) go to 3375
        icomp = 9
 3375 icrash = icrash + 1
       if( crash ) return
      go to 2100
!**
!**        *** end block 3  ***
!**
!**        *** begin block 4 ***
!**       the step is successful. correct the predicted solution.
!**       evaluate the derivatives using the corrected solution and
!**       update the differences. determine best order and step size
!**       for next step
!**
 3400 kold = k
      hold = h
!**
!**       correct and evaluate
!**
      temp1 = h * g(kp1)
 3410 continue
      do 3415  l = 1,neqn
        y(l) = p(l) + temp1 * (yp(l) - phi(l,1))
 3415 continue
 3420 continue
!**
!**         store erk and erkm1 in yinp so that they can be used
!**         later.
!**
      dumst(1,iptr) = erk
      dumst(2,iptr) = erkm1
      dumst(3,iptr) = erkp1
      icomp = 4
      return
!**
!**          control returns here after f is called for icore equations
!**          in the main program.
!**
!**
!**          store back some of the parameters stored and
!**          restore some of the values of other arrays. this
!**          is for restoring data between overlay swaps.
!**
 4000 continue
      kp1 = k + 1
      kp2 = k + 2
      km1 = k - 1
      km2 = k - 2
      erk = dumst(1,iptr)
      erkm1 = dumst(2,iptr)
      erkp1 = dumst(3,iptr)
      absh = abs(h)
      p5eps = 0.5d0*eps
!**
!**         update differences for next step
!**
      do 4425 l = 1,neqn
        phi(l,kp1) = yp(l) - phi(l,1)
        phi(l,kp2) = phi(l,kp1) - phi(l,kp2)
 4425 continue
      do 4435 i = 1,k
        do 4430 l = 1,neqn
          phi(l,i) = phi(l,i) + phi(l,kp1)
 4430   continue
 4435 continue
!**
!**       estimate error at order k+1 unless:
!**        in first phase when always raise order
!**        already decided to lower order
!**        step size not constant so estimate unreliable
!**
      erkp1 = 0.d0
      if(knew.eq.km1  .or. k.eq.mxordr) phase1 = .false.
      if(phase1) go to 4450
        if(knew.eq.km1) go to 4455
          if(kp1.gt.ns) go to 4460
           do 4440 l = 1,neqn
             erkp1 = erkp1+ phi(l,kp2) * phi(l,kp2)
 4440      continue
           erkp1 = absh * gstr(kp1) * sqrt(erkp1)
!**
!**        using estimated error at order k + 1, determine
!**       appropriate order for next step
!**
           if(k.gt.1) go to 4445
           if(erkp1.ge.0.5d0*erk) go to 4460
            go to 4450
 4445      if(erkm1.le. min (erk,erkp1)) go to 4455
            if(erkp1.ge.erk .or. k.eq.mxordr) go to 4460
!**
!**            here erkp1.lt.erk.lt.amax1(erkm1,erkm2) else order
!**            would have lowered in block 2. thus order is to be
!**            raised.         raise order
!**
 4450 continue
      k = kp1
      erk = erkp1
      go to 4460
!**
!**        lower order
!**
 4455 k = km1
      erk = erkm1
!**
!**       with new order determine appropriate step size for next step
!**
 4460 hnew = h + h
      if(phase1) go to 4465
        if(p5eps.ge. erk*two(k+1))  go to 4465
          hnew = h
          if(p5eps.ge.erk) go to 4465
            temp2 = k + 1
            r = (p5eps/erk) ** (1.d0 / temp2)
            hnew = absh * max(0.5d0,min(0.9d0,r))
            hnew = sign( max (hnew,fouru*abs(x)),h)
 4465 continue
      h = hnew
      if(abs(h).lt.abs(hmin)) h = sign(hmin,h)
      if(abs(h).gt.abs(hmax)) h = sign(hmax,h)
      icomp = 5
      iflag = 2
!**
!**       *** end block 4 ***
!**
!**
!**           **  format statements **
!**
!**
      return
      END subroutine step
! **deck stmln2
      subroutine stmln2 (iwrk,arr1,zof,pzof)
      implicit double precision (a-h,o-z)
      dimension iwrk(100), arr1(10000)
      dimension zof(3000), pzof(4000)
!**
!**        the overlay for streamline computation is written so that
!**        all the pertinent information is stored in arrays iwrk and
!**        arr1  .  the iwrk array contains two type of information.
!**        first type of information pertains to the problem size
!**        such as number of equations, maximum order,used while
!**        integrating equations using adams-moulton method. the
!**        second type of inpormation deals with breaking up array
!**        computation, there will be excessive overlay swaps.
!**        arr1.  this is done so that the no. of streamlines
!**        that can be worked on asynchronously depending on
!**        array arr1 is computed by the program.
!**
!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
!**
!**     initialize some constants.  later these values will be
!**     passed from subroutine input.
!**
      tpoff=tpsl
      neqn = 3
      iwrk(1) = mxarr1
      iwrk(3) = neqn
      iwrk(53) = numpts
      iwrk(54) = mxordr
      call setup(iwrk( 1), iwrk( 2), iwrk( 3), iwrk( 4), iwrk( 5),      &
     &           iwrk( 6), iwrk( 7), iwrk( 8), iwrk( 9), iwrk(10),      &
     &           iwrk(11), iwrk(12), iwrk(13), iwrk(14), iwrk(15),      &
     &           iwrk(16), iwrk(17), iwrk(18), iwrk(19), iwrk(20),      &
     &           iwrk(21), iwrk(22), iwrk(23), iwrk(24), iwrk(25),      &
     &           iwrk(26), iwrk(27), iwrk(28), iwrk(29), iwrk(30),      &
     &           iwrk(31), iwrk(32), iwrk(33), iwrk(34), iwrk(35),      &
     &           iwrk(36), iwrk(37), iwrk(38), iwrk(39), iwrk(40),      &
     &           iwrk(41), iwrk(42), iwrk(43), iwrk(44), iwrk(45),      &
     &           iwrk(46), iwrk(47), iwrk(48), iwrk(49), iwrk(50),      &
     &           iwrk(51), iwrk(52), iwrk(53), iwrk(54),                &
     &           arr1, zof,pzof)
!**
!**
      return
      END subroutine stmln2
! **deck stmlne
      subroutine stmlne
      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 rrwi
      common /rrwi/ nrdq, ntr, npanr
!end  rrwi
!call slstat
      common /slstat/ tpvcal, tpivv, npicsl(7), npvcal, nphvsl
!end  slstat
!call solstr
      common /solstr/ iastr(600), iaxstr(200), ivzof(200)
!end  solstr
!ca 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 skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
      nw      =  300000
      call setcor ('stmlne')
      call igtcor ('iwrk',lliwrk,100)
      call getcor ('arr1',llarr1,10000)
      call getcor ('zof', llzof, 3000)
      call getcor ('pzof',llpzof,4000)
!
      open (unit=ntsmln,file='ft33',form='unformatted',status='unknown')
      call jzero (npicsl,7)
      tpvcal  =  0.d0
      tpivv   =  0.d0
      npvcal  =  0
      nphvsl  =  0
      call bmark('streaml ')
      call stmln2 (w(lliwrk),w(llarr1),w(llzof),w(llpzof))
      call cstprt ('s-l comp')
      call stmout
      write (6,6001)
 6001 format (1h1)
      write (6,6002) npicsl, tpvcal, tpivv, npvcal, nphvsl
 6002 format ('0    *****  s/l velocity evaluation statistics  *****'   &
     &  ,//, '    no influence    ',i10                                 &
     &  ,/,  '    monopole        ',i10                                 &
     &  ,/,  '    dipole          ',i10                                 &
     &  ,/,  '    quadrupole      ',i10                                 &
     &  ,/,  '    quasi-far field ',i10                                 &
     &  ,/,  '    quasi-near field',i10                                 &
     &  ,/,  '    near field      ',i10                                 &
     &  ,//, '    time in pvcal     ',f12.6                             &
     &  ,/,  '    time in pivv      ',f12.6                             &
     &  ,/,  '    no. calls to pvcal',i12                               &
     &  ,/,  '    phi/v evaluations ',i12  )
      call frecor ('stmlne')
      call cstprt ('s-l sort')
      return
      END subroutine stmlne
! **deck stmout
      subroutine stmout
      implicit double precision (a-h,o-z)
!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 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 fmcof
      common/fmcof/xref,yref,zref,sref,bref,cref,dref,nprcof
!end  fmcof
!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
!call boundl
!                                                           /boundl/
      common /boundl/ itapbl, ivcorr
!end  boundl
!ca cinout
!                                                           /cinout/
      common /cinout/ ntsin, ntsout
!end  cinout
!call titles
      common /titles/ title1(20),title2(20)
      character*4 title1, title2
!end  titles
!call solstr
      common /solstr/ iastr(600), iaxstr(200), ivzof(200)
!end  solstr
      dimension xyz(3), vw(3), cp(5), pv(3), wt(3), vt(3), pw(3)
      common /scrch1/ posvel(10,1000)
  INTEGER:: intpnt
      character*10 slname
      character*1 slcase
      character*2 slnumb
      character*10 lablsl(2)
      character*16 cplabl(4)
      character*6 fslout
      character*1 ch
      character*3 cpname(4)
      data cpname /'lin', 'sln', '2nd', 'isn'/
      data fslout /'fslout'/
      data nslout / 71 /
      data lablsl / ' mass flux', '  velocity' /
      data cplabl / '     linear     ',                                 &
     &              '  slender body  ',                                 &
     &              '   2nd order    ',                                 &
     &              '   isentropic   '/
      data impx /77/
!
!
!
      call mspnt1
!
      open (unit=nslout,file='fslout',form='unformatted')
!
      call bmark ('streaml ')
      itypsl  =  1
      if ( tpsl .ne. 0.d0 ) itypsl = 2
      ch      =  'w'
      if ( tpsl .ne. 0.d0 ) ch = 'v'
!                                  write out each streamline, rereading
!                                  unit  ntsmln  for each.
      nsltot  =  numpts*ncassl
      do 100 isl = 1,nsltot
      rewind ntsmln
      ia      =  53
!                                  get start pt index indsl, and case nu
      call mnmod (isl,numpts,  indsl,icassl)
      isol    =  indvsl(icassl)
      iacase  =  isol
!                                  read all data from unit  ntsmln
!                                  selecting only data for the current
!                                  streamline and quitting at the eof
   50 continue
      read (ntsmln,end=100) jsl, intpnt, svar, xyz, vw, phip, korder,   &
     &                      fwdbk
      if ( jsl.ne.isl ) go to 50
!                                  as needed, put out a page header
      if ( ia .lt. 52 ) go to 80
          if ( ia .eq. 52 ) write (ntsout,6003)
          if ( ia .eq. 53 )                                             &
     &         write (ntsout,6001) lablsl(itypsl),indsl,iacase          &
     &                            ,fwdbk,cplabl(nprcof)
          ia      =  0
          write (ntsout,6002) ch,ch,ch,cpname(nprcof)
   80 continue
      ia      =  ia + 1
!                                  apply the velocity correction and get
      call vadd (vw,-1.d0,fsv(1,isol),pv,3)
      if ( tpsl.ne.0.d0 ) goto 85
!                                       tpsl = 0., mass flux was calcula
          call dcopy (3,  vw,1,  wt,1)
          call cmpscl ( 1.d0/betams, compd, pv, pv)
          call vadd (fsv(1,isol), 1.d0, pv, vt, 3)
          goto 90
!                                       tpsl # 0., velocity was calculat
   85 continue
      call cmpscl (betams,compd,pv,pw)
      call vadd (fsv(1,isol),1.d0,pw,wt,3)
      call dcopy (3,  vw,1,  vt,1)
      if ( ivcorr.eq.0 ) goto 90
      call mag (fsv(1,isol),fsvmag)
      call velcor (ivcorr,fsv(1,isol),fsvmag,compd,amach,wt,vw)
      call vadd (vw,-1.d0,fsv(1,isol),pv,3)
      call dcopy (3,  vw,1,  vt,1)
!                                  write  s/l  info  to  units  ntsout
!                                  and  nslout.
   90 continue
      kmat    =  0
      call cpcal (kmat,pv,fsv(1,isol),betams,compd,cp)
      call mxm (vt,1,wt,3,amloc,1)
      amloc = amach * sqrt(max(0.d0,amloc)/(fsvm(isol)*fsvm(isol))/     &
     &        max(1.d-10, 1.d0 + .7d0*amach*amach*cp(nprcof)))
      amloc = min(1.d3,amloc)
      amloc   =  sqrt( cpfmat(kmat) )*amloc
!---- call machvl (kmat,pv,amloc)
!
      write(ntsout,6004) intpnt,svar,xyz,vw,phip,cp(nprcof),amloc,korder
      write (nslout)  jsl,intpnt,svar,xyz,vw,phip,   korder,fwdbk       &
     &              ,amloc,cp(nprcof),isol,indsl
      go to 50
!
  100 continue
!
      endfile nslout
      rewind nslout
      close(unit=ntsmln)
      open (unit=ntsmln,file='stmlin',form='formatted',status='unknown')
      write (ntsmln,3000) (title1(i),i=1,18), (title2(i),i=1,18)
 3000 format ( '(f6.0,10e12.5,f3.1)'                                    &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$title ',18a4                                            &
     &  ,/,   '$      ','flow-field streamline properties'              &
     &  ,/,   '*dupt'                                                   &
     &  ,/,   '*dup'                                                    &
     &   )
 3002 format ('*eof')
 3003 format (4x,'pt' ,11x,'s' ,11x,'x' ,11x,'y' ,11x,'z'               &
     &       ,10x,a1,'x'  ,10x,a1,'y'  ,10x,a1,'z'  ,8x,'ppot'          &
     &       ,6x,'cp/',a3   ,8x,'mach',  2x,'c'                         &
     &       )
 3004 format (1x,i5,1p,10e12.5,0p,i3)
 3005 format ('s',i2.2,'c',i1)
!
      jslprv  =  -100
      intprv  =  -100
      ksl     =  0
!
!                                  copy file  *nslout*  to  *ntsmln*
!
  200 continue
      read ( nslout ,end=300) jsl,intpnt,svar,xyz,vw,phip,korder,fwdbk  &
     &              ,amloc,cp(nprcof),iacase,indsl
      if ( jsl.eq.jslprv ) goto 240
!                                  new streamline
          ksl     =  ksl + 1
          if ( ksl.eq.1 ) goto 220
!                                  save streamline (ksl-1) when (ksl-1)
          aintpt  =  intprv
          anum2   =  2.d0
          write (slcase,'(i1)') iaprv
          write (slnumb,'(i2.2)') indprv
!                     1234567890
          slname  =  's..c.     '
          slname(2:3) = slnumb
          slname(5:5) = slcase
          write (impx,4000) aintpt,anum2,slname
          write (impx,4001) ((posvel(i,k),i=1,3),k=1,intprv)
          write (impx,4001) ((posvel(i,k),i=1,3),k=1,intprv)
  220     continue
          iaprv   =  iacase
          indprv  =  indsl
          jslprv  =  jsl
!                                  put out *eof for previous streamline
          if ( ksl.gt.1 ) write (ntsmln,3002)
          write (ntsmln,3005) indsl,iacase
          if ( ksl.eq.1 ) write (ntsmln,3003) ch,ch,ch,cpname(nprcof)
  240 continue
!                                  save integration pt index, position,
      intprv  =  intpnt
      call dcopy (3,  xyz,1,  posvel(1,intpnt),1)
      call dcopy (3,   vw,1,  posvel(4,intpnt),1)
!                                  compute cp and mach
 6005 format ('  streamline #',i4,'  case:',i5)
!                                  pv =  pert. v, vt = total v, wt = tot
  280 continue
      ifwbk   =  fwdbk
      write (ntsmln,3004) intpnt,svar,xyz,vw,phip,cp(nprcof),amloc,ifwbk
      go to 200
!
!
  300 continue
      write (ntsmln,3002)
      rewind ntsmln
!                                  save the last streamline
      aintpt  =  intprv
      anum2   =  2.d0
      write (slcase,'(i1)') iaprv
      write (slnumb,'(i2.2)') indprv
!                 1234567890
      slname  =  's..c.     '
      slname(2:3) = slnumb
      slname(5:5) = slcase
      write (impx,4000) aintpt,anum2,slname
      write (impx,4001) ((posvel(i,k),i=1,3),k=1,intprv)
      write (impx,4001) ((posvel(i,k),i=1,3),k=1,intprv)
      call emark ('streaml ')
!
 6001 format                                                            &
     & (/,1x,a10,' streamline number',i3,' for case',i2,6x              &
     & ,'forward/back =',f6.2, 29x, a16, 'local' )
 6002 format                                                            &
     &  (                                                               &
     &    '  int.    indep.          streamline location         dire'  &
     &   ,'ction(-v/-w, backward int)     poten.          cp       '    &
     &   ,' mach   order'                                               &
     & ,/,                                                              &
     &    '   pt.   variable   ------------------------------    ----'  &
     &   ,'-------------------------     -------      ---------    '    &
     &   ,'-----   -  '                                                 &
     & ,/,                                                              &
     &  '            s            x         y         z           ',a1  &
     &  ,'x        ',a1,'y        ',a1,'z            ppot        cp/'   &
     &  ,a3,'      mach   k  '                                          &
     &  )
 6003 format (1h1)
 6004 format(1x,i4,f10.4,3x,3f10.4,3x,3f10.4,4x,f10.4,4x,2f10.4,i4)
 4000 format (2f10.4,50x,a10)
 4001 format (6f10.4)
      return
      END subroutine stmout
! **deck strmfn
      subroutine strmfn
      implicit double precision (a-h,o-z)
!
!     streamfunction due to single panel
!
      common /pan1/ yl,yr,zl,zr,ycp,zcp
      common /pan2/ xiil,xiir,psip
!
!     yl,yr,zl,zr = panel corner points in global coordinates
!     ycp,zcp     = control point where streamfunction is calculated
!     xiil,xiir   = vorticity at panel corner points
!     psip        = streamfunction due to single panel at (ycp,zcp)
!
!     geometry parameters
!
      dely  = yr - yl
      delz  = zr - zl
      delyc = ycp - yl
      delzc = zcp - zl
!
      pi     = 4.d0*atan(1.d0)
!
      c      = sqrt (dely**2 + delz**2)
      eta    = (dely*delyc + delz*delzc)/c
      zet    = (-delyc*delz + dely*delzc)/c
!
      if (ycp.eq.yl.and.zcp.eq.zl) then
         c2     = c**2
         tlog   = c*log(c)
         psic   = 2.d0*tlog - 2.d0*c
         psil   = c*tlog - 0.5d0*c2
!
      else if (ycp.eq.yr.and.zcp.eq.zr) then
         c2     = c**2
         tlog   = c*log(c)
         psic   = 2.d0*tlog - 2.d0*c
         psil   = c*tlog - 1.5d0*c2
!
      else
!
         azet   = abs (zet)
         szet   = sign (1.d0,zet)
!
         ttan    = atan2 (eta,azet)*szet - atan2 (eta-c,azet)*szet
         t1      = eta**2 + zet**2
         t2      = (eta-c)**2 + zet**2
!
         psic    = eta*log(t1) -(eta-c)*log(t2) -2.d0*c +2.d0*zet*ttan
         psil    = psic*eta + 0.5d0*(t2*log(t2) -t2 -t1*log(t1) +t1)
!
      end if
!
      psip    = -(xiil*psic + (xiir - xiil)*psil/c)/(4.d0*pi)
!
      return
      END subroutine strmfn
! **deck strns
      subroutine  strns(ip,pdq)
      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 retrieve the panel and singularity strength defining      *
!     *  quantities                                                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the information is retrieved via readms                      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   ip        argument  input     index identifying given panel *
!     *                                                               *
!     *   nis       /srwi/    input     index array for nts           *
!     *                                                               *
!     *   nns       /srwi/    input     length of nis                 *
!     *                                                               *
!     *   nsdq      /srwi/    input     number of panel defining      *
!     *                                 quantities per block          *
!     *                                                               *
!     *   nts       /srwi/    input     file on which panel defining  *
!     *                                 quantity blocks are stored    *
!     *                                                               *
!     *   pdq       argument  output    panel defining quantity block *
!     *                                 for given panel ip            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 srwi
      common/srwi/nsdq,nss,nrs,nts,nns,nis(maxpan+1)
!end  srwi
      dimension pdq(1)
!c
!     *  the information is retrieved via readms                      *
!
      call readms(nts,pdq,nsdq,ip)
      return
      END subroutine strns
! **deck stunpk
      subroutine stunpk (strbuf)
      implicit double precision (a-h,o-z)
      dimension strbuf(1)
!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 strpak
      common /strpak/ cpw(3,4), enw(3,5), aqw(9), aqiw(9)               &
     &              , strcw(2,3), c1w, c2w, c3w, diamw                  &
     &              , rcw(9,3)                                          &
     &              , iisw(9), iidw(25), iisgpw(9), iidgpw(25)          &
     &              , insw, indw, itsw, icsw, ipnw, kpw, isqnw          &
     &              , nzastd, astsw(27)                                 &
     &                          ,astdnz(100), istdnz(100)
!end  strpak
      common /zpandq/ zpan(455),izpan(44),zpan2(6),izpan2(34),zdum(1)
!                                  generate far field data
      nwf    =  locfcn(indrqf) - locfcn(cpfz)
      call dlocfx (nwf)
      call jzero (cpfz,nwf)
      call ffdqg
      call ifera (iisgp,iisf,ins)
      call ifera (iidgp,iidf,ind)
      indff   =  0
      call ffdqgx (indff)
      indrqf =  0
!
      return
      END subroutine stunpk
! **deck subpqr
      subroutine subpqr(cp,ar,p,alam,pp,qq,rr,ic)
      implicit double precision (a-h,o-z)
      common/skrch4/d(10,7),e(3,3),f(6,9),g(3,3),h(6,6)
      dimension pp(3,3),rr(3,3),qq(6,9),alam(9),ar(9),cp(3,9),p(3,4)
      icp0=mod(ic+3,4)+1
      icp1=mod(ic,4)+1
      icp2=mod(ic+1,4)+1
      icp3=mod(ic+2,4)+1
      if(ic.gt.4) go to 300
      ic0=icp0
      ic1=icp0+4
      ic2=icp3+4
      ice1=icp1
      ice2=icp3
      icf1=icp3+4
      icf2=icp0
      icf3=icp3
      icf4=icp0+4
      icf5=icp0
      icf6=icp1
      e(1,2)=p(1,icp0)
      e(1,3)=p(2,icp0)
      go to 500
  300 continue
      ic0=9
      ic1=icp3+4
      ic2=icp0+4
      ice1=icp3
      ice2=icp1
      icf1=9
      icf2=icp0+4
      icf3=icp2+4
      icf4=9
      icf5=icp3+4
      icf6=icp1+4
      e(1,2)=.25d0*(p(1,1)+p(1,2)+p(1,3)+p(1,4))
      e(1,3)=.25d0*(p(2,1)+p(2,2)+p(2,3)+p(2,4))
  500 continue
      e(1,1)=1.d0
      e(2,1)=1.d0
      e(3,1)=1.d0
      e(2,2)=.5d0*(p(1,icp0)+p(1,ice1))
      e(2,3)=.5d0*(p(2,icp0)+p(2,ice1))
      e(3,2)=.5d0*(p(1,icp0)+p(1,ice2))
      e(3,3)=.5d0*(p(2,icp0)+p(2,ice2))
      call zero(f,54)
      f(1,ic0)=1.d0
      f(2,ic1)=1.d0
      f(3,ic2)=1.d0
      do 600 i=1,9
  600 f(4,i)=alam(i)
      f(5,icf1)=1.d0
      f(5,icf2)=.25d0
      f(5,icf3)=-.25d0
      f(6,icf4)=1.d0
      f(6,icf5)=.25d0
      f(6,icf6)=-.25d0
      pp(1,1)=0.d0
      pp(2,1)=0.d0
      pp(3,1)=0.d0
      call unipan(ar,cp(1,ic0),cp(1,ic1),pp(1,2))
      call unipan(ar,cp(1,ic0),cp(1,ic2),pp(1,3))
      call tcof(pp,g,h,d)
      call mxm (g,3,e,3,rr,3)
      call mxm (h,6,f,6,qq,9)
  900 return
      END subroutine subpqr
! **deck subpwm
      subroutine subpwm (ics,is,cp  ,ens,as,ajs,ws  ,enm,am             &
     &                  ,wsm,wscc,almsm,almscc                          &
     &                  ,qd)
      implicit double precision (a-h,o-z)
      dimension cp(3,9)
      dimension ens(3), as(3,3), ws(3,3)
      dimension enm(3), am(3,3)
      dimension wsm(3,3,6,4), wscc(3,6,3,4)
      dimension almsm(3,3,4), almscc(3,3,4)
      dimension qd(3,9)
!
!     compute the contribution of subpanel 'is' to the panel moment
!     integrals,
!
!     integral  g/alpha (xi,eta) [ n dS x ( w x dq/dt ) ]
!      panel
!
!     where  w  is a perturbation mass flux vector specified in ws
!     by the its values at the three corners of the triangle.
!
!     Numbering Scheme for points within a subpanel
!
!       1-----5-----2
!       |1  2/|\3  1|
!       |   /3|2\   |
!       |  /  |  \  |
!       |3/   |   \2|
!       |/2  1|1  3\|
!       8-----9-----6
!       |\3  1|1  2/|
!       |2\   |   /3|
!       |  \  |  /  |
!       |   \2|3/   |
!       |1  3\|/2  1|
!       4-----7-----3
!
!
!     ics     i   i*4  index of collapsed side
!     is      i   i*4  subpanel index
!     cp      i   r*8  panel corner points
!     cpm     i   r*8  panel corner points, mean panel local coords
!     ens     i   r*8  subpanel normal
!     as      i   r*8  reference to local transformation, subpanel is
!     ajs     i   r*8  dS/dS' for subpanel is
!     ws      i   r*8  pert massflux vectors at panel's 3 corner points
!     enm     i   r*8  mean plane panel normal
!     am      i   r*8  reference to local transformation, mean plane
!     wsm     i/o r*8  the subpanel's contribution to the panel moment
!                      integrals, wsm('vec','q-vec',alpha,'4 corners')
!     wscc    o   r*8  wscc('vec',alpha,qd-vec,4 corners), the coeffs of
!                      n x [ w x qdot ] in an expansion in g/alpha in
!                      terms of 4 panel corner q-dot values
!     almsm   i/o r*8
!     almcc   o   r*8  almcc( [1,xi',eta'], 'qd-vec', 4 corners ),
!                      coeffs of alm expansion in terms of q-dot values
!
      dimension cm(6,6), isx(3), cpl(3,6), cpm(3,3), xfm(3,3)
      dimension aloc(3,3), bloc(6,6)
      dimension gab(6,6), enwsxy(3)
      dimension facg(6), incg(6), jncg(6)
      dimension wsxy(3,3)
      dimension dmdq(3,3,6,3), dmdqx(3,3,6,3), dmdqz(3,3,6,4)
      dimension dmdqy(3,3,6,4)
      dimension cdep(9), indep(16), ipdep(10)
      dimension chvl(6,4)
      dimension wsccx(3,6,3,4), enws(6), wst(3,6)
      dimension almccx(3,3,3), dqs(3), dqt(3), dws(3), dwt(3)
      dimension almccy(3,3,3)
      dimension qtxws(3), qsxwt(3), dqwts(3), dq(3), wsxdq(3), qsxqt(3)
      dimension almsmx(3,3,4), almsmy(3,3,4)
!
      data ipdep/ 1,2,3,4,  5,7,9,11,  13,17 /
      data  cdep/ 1.d0,1.d0,1.d0,1.d0,.5d0,.5d0,.5d0,.5d0,.25d0 /
      data indep/  1    ,2     ,3     ,4                                &
     &          ,1,2  ,2,3   ,3,4   ,4,1                                &
     &          ,1,2,3,4 /
      data incg / 0,1,0,2,1,0 /
      data jncg / 0,0,1,0,1,2 /
      data facg / 1.d0,  1.d0,1.d0,  .5d0,1.d0,.5d0 /
!                                  clear output arrays that are set
!                                  rather than incremented
      call dcopy (3*6*3*4, 0.d0,0,  wscc,1)
      call dcopy (3*3*4,  0.d0,0,  almscc,1)
!                                  check for null subpanel
      icsp1    =  mod(ics,4) + 1
      if ( ics.ne.0 .and. ( is.eq.ics .or. is.eq.icsp1 ) ) goto 900
!                                  get the local coordinates of the
!                                  subpanel's 3 corners
      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 local coords of 3 corners
      do 100 j = 1,3
         call unipan (as,cp(1,isx(1)), cp(1,isx(j)), cpl(1,j))
         call unipan (am,cp(1,9),      cp(1,isx(j)), cpm(1,j))
  100 continue
!                                  compute subpanel panel moments
      icsl    =  0
      call ccaln (cpl,icsl,cm,  3,  6)
!                                  get transformation for coefficients
!                                  of linearfcns psi/beta (sg,tau) to
!                                  fcns g/alfa (xi',eta').
!                   xi/2 *  eta/3  -    xi/3 *  eta/2
      detxy   =  cpl(1,2)*cpl(2,3) - cpl(1,3)*cpl(2,2)
      deti    =  1.d0/detxy
!              [  eta/3   -eta/2  ] [ xi/2  eta/2 ] = detxy * [ 1  0 ]
!              [  -xi/3     xi/2  ] [ xi/3  eta/3 ]           [ 0  1 ]
      alxx    =  deti*cpl(2,3)
      alxy    =                  -deti*cpl(2,2)
      alyx    = -deti*cpl(1,3)
      alyy    =                   deti*cpl(1,2)
!
      aloc(1,1) =  1.d0
      aloc(1,2) =                0.d0
      aloc(1,3) =                               0.d0
!
      aloc(2,1) = -(alxx+alxy)
      aloc(2,2) =                alxx
      aloc(2,3) =                               alxy
!
      aloc(3,1) = -(alyx+alyy)
      aloc(3,2) =                alyx
      aloc(3,3) =                               alyy
!                                  generate transformation between
!                                  subpanel local coords and mean plane
!                                  local coords
      call hsmmp1 (3,3,3,  aloc,1,3,  cpm,3,1,  xfm,1,3)
!                                  generate transformation from g-fcns
!                                  of (xi',eta') (subpanel local) to
!                                  g-fcns of (xi,eta) (meanplane local)
!
!     g/alpha = [ 1, xi, eta, xi^2/2, xi*eta, eta^2/2 ]
!     incg    = [ 0,  1,   0,      2,      1,       0 ]
!     jncg    = [ 0,  0,   1,      0,      1,       2 ]
!     facg    = [ 1,  1,   1,     .5,      1,      .5 ]
!
      xiz     =  xfm(1,1)
      a1      =  xfm(2,1)
      a2      =  xfm(3,1)
!
      etaz    =  xfm(1,2)
      b1      =  xfm(2,2)
      b2      =  xfm(3,2)
!
      gab(1,1) =  1.d0
      gab(1,2) =       0.d0
      gab(1,3) =            0.d0
      gab(1,4) =                 0.d0
      gab(1,5) =                      0.d0
      gab(1,6) =                           0.d0
!
      gab(2,1) =  xiz
      gab(2,2) =       a1
      gab(2,3) =            a2
      gab(2,4) =                 0.d0
      gab(2,5) =                      0.d0
      gab(2,6) =                           0.d0
!
      gab(3,1) =  etaz
      gab(3,2) =       b1
      gab(3,3) =            b2
      gab(3,4) =                 0.d0
      gab(3,5) =                      0.d0
      gab(3,6) =                           0.d0
!
      gab(4,1) =  .5d0*xiz*xiz
      gab(4,2) =       a1*xiz
      gab(4,3) =            a2*xiz
      gab(4,4) =                 a1*a1
      gab(4,5) =                      a1*a2
      gab(4,6) =                           a2*a2
!
      gab(5,1) =  xiz*etaz
      gab(5,2) =       a1*etaz+b1*xiz
      gab(5,3) =            a2*etaz+b2*xiz
      gab(5,4) =                 2.d0*a1*b1
      gab(5,5) =                      a1*b2+a2*b1
      gab(5,6) =                           2.d0*a2*b2
!
      gab(6,1) =  .5d0*etaz*etaz
      gab(6,2) =       b1*etaz
      gab(6,3) =            b2*etaz
      gab(6,4) =                 b1*b1
      gab(6,5) =                      b1*b2
      gab(6,6) =                           b2*b2
!
!                                  get q/sg, q/tau; w/sg, w/tau
      call vadd (cp(1,isx(2)), -1.d0, cp(1,isx(1)), dqs, 3)
      call vadd (cp(1,isx(3)), -1.d0, cp(1,isx(1)), dqt, 3)
      call vadd (ws(1,2),      -1.d0, ws(1,1),      dws, 3)
      call vadd (ws(1,3),      -1.d0, ws(1,1),      dwt, 3)
!                                  generate alm coefficients wrt sg,tau
      call cross (dqt,dws, qtxws)
      call cross (dqs,dwt, qsxwt)
      call vadd (qtxws,  -1.d0,  qsxwt,  dqwts, 3)
      call dcopy (27,  0.d0,0,  almccx,1)
      do 120 igm = 1,3
         igm1    =  mod(igm,3) + 1
         igm2    =  mod(igm1,3)+ 1
         ibt     =  igm
         call daxpy (3,  1.d0,  dqwts,1,  almccx(ibt,1,igm),3)
!
         call vadd (cp(1,isx(igm2)), -1.d0, cp(1,isx(igm1)), dq, 3)
         do 110 ibt = 1,3
            call cross (ws(1,ibt),dq,wsxdq)
            call daxpy (3,  1.d0,  wsxdq,1,  almccx(ibt,1,igm),3)
  110    continue
  120 continue
      call cross (dqs,dqt,qsxqt)
      sfac    =  1.d0/sqrt( ddot(3, qsxqt,1, qsxqt,1) )
      call dscal (27,  sfac,  almccx,1)
!                                  transform alm coefficients from
!                                  (sg,tau) to (xi',eta') dependence
      call hsmmp1 (3,3,9,  aloc,1,3,  almccx,1,3,  almccy,1,3)
!                                   get increments to almsm moments
      call dcopy (3*3*3,  0.d0,0,  almsmx,1)
      do 130 ibt = 1,3
         do 125 igm = 1,3
            ival    =  1 + incg(ibt) + incg(igm)
            jval    =  1 + jncg(ibt) + jncg(igm)
            gint    =  ajs*facg(ibt)*facg(igm)*cm(ival,jval)
            call daxpy (9, gint, almccy(igm,1,1),3,  almsmx(ibt,1,1),3)
  125    continue
  130 continue
!+++      call hsmmp1 (3,3,9,  gab,1,6,  almsmx,1,3,  almsmy,1,3)
!                                   coeffs of w as fcn of xi', eta'
      call hsmmp1 (3,3,3,  aloc,1,3,  ws,3,1,  wsxy,3,1)
      call hsmmp1 (3,3,1,  wsxy,3,1, ens,1,3,  enwsxy,1,3)
!
      call dcopy (6*3*3*3,  0.d0,0,  dmdq,1)
      do 400 ialf = 1,6
         do 300 jq = 1,3
            incq    =  incg(jq)
            jncq    =  jncg(jq)
            do 200 kw = 1,3
               incw    =  incg(kw)
               jncw    =  jncg(kw)
               ival    =  1 + incg(ialf) + incq + incw
               jval    =  1 + jncg(ialf) + jncq + jncw
               gint    =  ajs*facg(ialf)*cm(ival,jval)
               do 150 j = 1,3
               do 140 i = 1,3
                  dmdq(i,j,ialf,jq) = dmdq(i,j,ialf,jq)                 &
     &                              + gint*wsxy(i,kw)*ens(j)
  140          continue
  150          continue
               wnfac   =  enwsxy(kw)*gint
               do 160 i = 1,3
                  dmdq(i,i,ialf,jq) = dmdq(i,i,ialf,jq) - wnfac
  160          continue
  200       continue
  300    continue
  400 continue
!                                  transform dmdq into dependency upon
!                                  triangles 3 corners
      call hsmmp1 (54,3,3,  dmdq,1,54,  aloc,1,3,  dmdqx,1,54)
!                                  transform dmdqx from moments for
!                                  functions of (xi',eta') to (xi,eta)
!+++      do 500 jq = 1,3
!+++         call hsmmp1 (9,6,6,  dmdqx(1,1,1,jq),1,9,  gab,6,1
!+++     x               ,dmdq(1,1,1,jq),1,9)
!+++ 500  continue
!                                  accumulate moments into wsm.  Also,
!                                  determine dependence of 6 canonical
!                                  subpanel points on the 4 corner pts
      call dcopy (24,  0.d0,0,  chvl,1)
      call dcopy (3*3*4,  0.d0,0,  almsmy,1)
      call dcopy (3*3*6*4,  0.d0,0,  dmdqz,1)
      do 600 jq = 1,3
         ic      =  isx(jq)
         jdep1   =  ipdep(ic)
         jdep2   =  ipdep(ic+1)-1
         cc      =   cdep(ic)
!                                  wsm(i,j,ialf,kdep) <-- +
!                                      <-- + cc*dmdqx(i,j,ialf,jq)
         do 550 jdep = jdep1,jdep2
            kdep    =  indep(jdep)
!+++          call daxpy (54, cc,  dmdq(1,1,1,jq),1,  wsm(1,1,1,kdep),1)
            call daxpy (54,cc, dmdqx(1,1,1,jq),1,  dmdqz(1,1,1,kdep),1)
            chvl(jq,kdep) = cc
            call daxpy (9,  cc,  almccy(1,1,jq),1,  almscc(1,1,kdep),1)
            call daxpy (9,  cc,  almsmx(1,1,jq),1,   almsmy(1,1,kdep),1)
  550    continue
  600 continue
!                                  evaluate (n,w) at triangle corners
      call hsmmp1 (1,3,3,  ens,1,1,  ws,1,3,  enws,1,1)
      call dcopy (9,  ws,1,  wst,1)
      do 620 ibt = 1,3
         jbt      =  mod(ibt,3) + 1
         kbt      =  mod(jbt,3) + 1
!                                  express 6 canonical basis fcns in
!                                  terms of g/alpha (xi',eta'):
!                                    th/bt   =  psi/bt ( 2 psi/bt - 1)
!                                    th/bt+3 =  4 psi/[bt+1] psi/[bt+2]
         call qudlxl (aloc(1,ibt),aloc(1,ibt),  bloc(1,ibt))
         call dscal (6,  2.d0,  bloc(1,ibt),1)
         call daxpy (3, -1.d0,  aloc(1,ibt),1,  bloc(1,ibt),1)
         call qudlxl (aloc(1,jbt),aloc(1,kbt),  bloc(1,ibt+3))
         call dscal (6,  4.d0,  bloc(1,ibt+3),1)
!                                  interpolate  (n,w), w  to tri-midpts
         enws(ibt+3) = .5d0*( enws(jbt) + enws(kbt) )
         do 605 i = 1,3
            wst(i,ibt+3) = .5d0*( ws(i,jbt) + ws(i,kbt) )
  605    continue
!                                  depedence of tri-midpts on 4 corners
         do 610 idlt = 1,4
            chvl(ibt+3,idlt) = .5d0*( chvl(jbt,idlt) + chvl(kbt,idlt) )
  610    continue
  620 continue
!
      do 700 ibt = 1,6
         do 680 idlt = 1,4
            chx     =  chvl(ibt,idlt)
            do 640 j = 1,3
            do 630 i = 1,3
               wsccx(i,ibt,j,idlt) = chx*wst(i,ibt)*ens(j)
  630       continue
  640       continue
            do 650 i = 1,3
               wsccx(i,ibt,i,idlt) = wsccx(i,ibt,i,idlt) - chx*enws(ibt)
  650       continue
  680    continue
  700 continue
!                                    transform function values into
!                                    derivatives for output to wscc
      do 720 i = 1,3
         call hsmmp1 (6,6,12,  bloc,1,6,  wsccx(i,1,1,1),3,3*6          &
     &               ,wscc(i,1,1,1),3,3*6)
  720 continue
!                                     transform to fcns (xi,eta)
      call hsmmp1 (3,3,12,  gab,1,6,  almsmy,1,3,  almsmx,1,3)
      do 820 ialf = 1,4
      call hsmmp1 (9,6,6,  dmdqz(1,1,1,ialf),1,9,  gab,6,1              &
     &            ,dmdqy(1,1,1,ialf),1,9)
  820 continue
!                                    accumulate into moment integrals
      call daxpy (36,   1.d0,  almsmx,1,   almsm,1)
!                                    add in to wsm(i,j,ialf,idlt)
      call daxpy (216,  1.d0,  dmdqy,1,  wsm,1)
!
  900 continue
      return
      END subroutine subpwm
! **deck subsbi
      subroutine subsbi(p,ics,ns,its,x,aj,ne,nf,du,dv)
      implicit double precision (a-h,o-z)
!call ncons
      common /ncons/ pi,pi2,pi4i,twopi,pio2
!end  ncons
      dimension p(3,4),x(3),du(ne,6),dv(ne,10)
      dimension b(13)
  DOUBLE PRECISION:: det
      h=x(3)
      signh=0.d0
      if(h.gt.0.d0) signh=1.d0
      if(h.lt.0.d0) signh=-1.d0
      hh=h*h
      hm=abs(h)
      call zero(b,13)
      do 600 is=1,ns
      if(is.eq.ics) go to 600
      isp1=mod(is,ns)+1
      if(isp1.eq.ics) isp1=mod(isp1,ns)+1
      aks1=p(1,is)-x(1)
      aet1=p(2,is)-x(2)
      aks2=p(1,isp1)-x(1)
      aet2=p(2,isp1)-x(2)
      dks=aks2-aks1
      det=aet2-aet1
      drm=sqrt(dks*dks+det*det)
      drmi=1.d0/drm
      ank=drmi*det
      ane=-drmi*dks
      a=aks1*ank+aet1*ane
      aa=a*a
      gg=aa+hh
      el1=aet1*ank-aks1*ane
      el2=aet2*ank-aks2*ane
      el12=el1*el2
      el1s=el1*el1
      el2s=el2*el2
      s1=sqrt(el1s+gg)
      s2=sqrt(el2s+gg)
      s12=s1*s2
      s1p2=s1+s2
      s=drm*(el1+el2)/s1p2
      si=-s/s12
      if(el12.gt.0.d0) go to 530
      els=el2*s1-el1*s2
      elsp=el2*s2-el1*s1
      elgs=els/(gg*s12)
      sina=a*(gg*drm+hm*els)
      cosa=(gg+hm*s1)*(gg+hm*s2)+aa*el12
      ratio=(s1-el1)*(s2+el2)/gg
      go to 550
  530 elgs=-si*s1p2/(el2*s1+el1*s2)
      elsp=drm*(el1+el2)*(gg+el1s+el2s)/(el2*s2+el1*s1)
      sina=a*(drm+hm*s12*elgs)
      cosa=gg+hm*s1p2+el12+hh*(gg+el1s+el2s)/(s12+el12)
      if(el2.gt.0.d0) go to 540
      ratio=(s1-el1)/(s2-el2)
      go to 550
  540 ratio=(s2+el2)/(s1+el1)
  550 continue
      hh113=signh*atan2(sina,cosa)
      f111=log(ratio)
      f121=a*ane*f111+ank*s
      f211=a*ank*f111-ane*s
      b(1)=b(1)+hh113
      b(2)=b(2)+ank*f111
      b(3)=b(3)+ane*f111
      b(4)=b(4)+a*f111
      b(5)=b(5)+ank*f121
      b(6)=b(6)+ane*f121
      b(7)=b(7)+a*f211
      b(8)=b(8)+a*f121
      if(nf.le.6) go to 600
      f221=.5d0*ank*ane*(gg+2.d0*aa)*f111+a*(ank+ane)*(ank-ane)*s       &
     &-.5d0*ank*ane*elsp
      b(9)=b(9)+ank*f221
      b(10)=b(10)+ane*f221
      if(its.eq.2) go to 600
      b(11)=b(11)+.5d0*a*(3.d0*a*ank*f211-(aa+ane*ane*hh)*f111          &
     &-ane*(a*ank*s-ane*elsp))
      b(12)=b(12)+.5d0*a*(3.d0*a*ane*f121-(aa+ank*ank*hh)*f111          &
     &+ank*(a*ane*s+ank*elsp))
      b(13)=b(13)+a*f221
  600 continue
      du(1,1)=-b(4)+h*b(1)
      du(1,2)=-.5d0*(b(7)+hh*b(2))
      du(1,3)=-.5d0*(b(8)+hh*b(3))
      if((nf.le.6).or.(its.eq.2)) go to 625
      du(1,4)=-(hh*(h*b(1)-b(6))+b(11))/3.d0
      du(1,5)=-(hh*b(5)+b(13))/3.d0
      du(1,6)=-(hh*(h*b(1)-b(4)+b(6))+b(12))/3.d0
  625 if(its.eq.1) go to 650
      dv(1,1)=b(1)
      dv(1,2)=-h*b(2)
      dv(1,3)=-h*b(3)
      dv(1,4)=h*(b(6)-h*b(1))
      dv(1,5)=-h*b(5)
      dv(1,6)=-h*(b(6)+du(1,1))
      if(nf.le.6) go to 650
      dv(1,7)=h*(b(10)+hh*b(2))
      dv(1,8)=-h*(b(9)+du(1,3))
      dv(1,9)=-h*(b(10)+du(1,2))
      dv(1,10)=h*(b(9)+hh*b(3))
  650 if(ne.eq.1) go to 700
      du(2,1)=b(2)
      du(2,2)=h*b(1)-b(6)
      du(2,3)=b(5)
      du(3,1)=b(3)
      du(3,2)=b(5)
      du(3,3)=b(6)+du(1,1)
      du(4,1)=b(1)
      du(4,2)=-h*b(2)
      du(4,3)=-h*b(3)
      if(nf.le.6) go to 675
      du(2,4)=-b(10)-hh*b(2)
      du(2,5)=b(9)+du(1,3)
      du(2,6)=b(10)+du(1,2)
      du(3,4)=du(2,5)
      du(3,5)=du(2,6)
      du(3,6)=-b(9)-hh*b(3)
      du(4,4)=-h*du(2,2)
      du(4,5)=-h*b(5)
      du(4,6)=-h*du(3,3)
  675 if(its.eq.1)  go to 700
      dv(2,1)=0.d0
      dv(2,2)=b(1)
      dv(2,3)=0.d0
      dv(2,4)=2.d0*du(4,2)
      dv(2,5)=du(4,3)
      dv(2,6)=0.d0
      dv(3,1)=0.d0
      dv(3,2)=0.d0
      dv(3,3)=b(1)
      dv(3,4)=0.d0
      dv(3,5)=du(4,2)
      dv(3,6)=2.d0*du(4,3)
      dv(4,1)=0.d0
      dv(4,2)=-b(2)
      dv(4,3)=-b(3)
      dv(4,4)=-2.d0*du(2,2)
      dv(4,5)=-2.d0*b(5)
      dv(4,6)=-2.d0*du(3,3)
      if(nf.le.6) go to 700
      dv(2,7)=3.d0*du(4,4)
      dv(2,8)=2.d0*du(4,5)
      dv(2,9)=du(4,6)
      dv(2,10)=0.d0
      dv(3,7)=0.d0
      dv(3,8)=du(4,4)
      dv(3,9)=dv(2,8)
      dv(3,10)=3.d0*du(4,6)
      dv(4,7)=-3.d0*du(2,4)
      dv(4,8)=-3.d0*du(2,5)
      dv(4,9)=-3.d0*du(3,5)
      dv(4,10)=-3.d0*du(3,6)
  700 continue
      pi8i=.5d0*pi4i
      pi4aj=pi4i*aj
      pi8aj=pi8i*aj
      pi24i=pi8i/3.d0
      x2=.5d0*x(1)
      y2=.5d0*x(2)
      x3=x(1)/3.d0
      y3=x(2)/3.d0
      if (its.eq.2) go to 750
      ng=3
      if (nf.eq.10) ng=6
      neg=ne*ng
      call vmul (du,pi4aj,du,neg)
      if ( ng.lt.6 ) goto 731
      do 730 i = 1,ne
      du(i,4)=.5*du(i,4) + x(1)*(   x2*du(i,1) + du(i,2) )
      du(i,5)=du(i,5) + x(2)*( x(1)*du(i,1) + du(i,2) ) + x(1)*du(i,3)
      du(i,6)=.5*du(i,6) + x(2)*(   y2*du(i,1) + du(i,3) )
  730 continue
  731 continue
      do 740 i = 1,ne
          du(i,2) = du(i,2) + x(1)*du(i,1)
          du(i,3) = du(i,3) + x(2)*du(i,1)
  740 continue
  750 continue
      if (its.eq.1) go to 790
      ne6 = ne * 6
      call vmul (dv,pi4i,dv,ne6)
      do 780 i = 1,ne
          dv(i,2) = dv(i,2) + x(1)*dv(i,1)
          dv(i,3) = dv(i,3) + x(2)*dv(i,1)
          dvx     = dv(i,2) - x2  *dv(i,1)
          dv(i,4) = 0.5d0*dv(i,4) + x(1)*dvx
          dvy     = dv(i,3) -y2   *dv(i,1)
          dv(i,6) = 0.5d0*dv(i,6) + x(2)*dvy
          dv(i,5) = dv(i,5) + x(1)*dvy + x(2)*dvx
  780 continue
  790 continue
      if(nf.le.6) go to 800
      if ( its.eq.1 ) goto 800
      do 799 i = 1,ne
      dvy=dv(i,3)-y3*dv(i,1)
      dvx=dv(i,2)-x3*dv(i,1)
      dvxx=dv(i,4)-x2*dvx
      dvxy=dv(i,5)-x2*dvy-y2*dvx
      dvyy=dv(i,6)-y2*dvy
      dv(i,7)=pi24i*dv(i,7)+x(1)*dvxx
      dv(i,8)=pi8i*dv(i,8)+x(1)*dvxy+x(2)*dvxx
      dv(i,9)=pi8i*dv(i,9)+x(1)*dvyy+x(2)*dvxy
      dv(i,10)=pi24i*dv(i,10)+x(2)*dvyy
  799 continue
  800 continue
  900 continue
      return
      END subroutine subsbi
! **deck supsbi
      subroutine supsbi(p,ics,ns,its,x,aj,ne,nf,du,dv)
      implicit double precision (a-h,o-z)
!call ncons
      common /ncons/ pi,pi2,pi4i,twopi,pio2
!end  ncons
      dimension p(3,4),x(3),du(ne,6),dv(ne,10)
      dimension b(13)
  DOUBLE PRECISION:: det
      data dltmch /1.d2/
      data deltbt /.01d0/
      h=x(3)
      hh=h*h
      call zero(b,13)
      do 600 is=1,ns
      if(is.eq.ics) go to 600
      isp1=mod(is,ns)+1
      if(isp1.eq.ics) isp1=mod(isp1,ns)+1
      aks1=p(1,is)-x(1)
      aet1=p(2,is)-x(2)
      aks2=p(1,isp1)-x(1)
      aet2=p(2,isp1)-x(2)
      dks=aks2-aks1
      det=aet2-aet1
      drm=sqrt(dks*dks+det*det)
      drmi=1.d0/drm
      ank=drmi*det
      ane=-drmi*dks
      a=aks1*ank+aet1*ane
      aa=a*a
      bet=(ank-ane)*(ank+ane)
      gg=aa-bet*hh
      sbet=sqrt(abs(bet))
      el1=aks1*ane+aet1*ank
      el2=aks2*ane+aet2*ank
      hh113=0.d0
      rr1=aks1*aks1-aet1*aet1-hh
      rr2=aks2*aks2-aet2*aet2-hh
      r1=0.d0
      r2=0.d0
      if((rr1.gt.0.d0).and.(aks1.lt.0.d0)) r1=sqrt(rr1)
      if((rr2.gt.0.d0).and.(aks2.lt.0.d0)) r2=sqrt(rr2)
      if((r1.gt.0.d0).or.(r2.gt.0.d0)) go to 300
      if ( (bet.le.0.d0)  .or.  (el1*el2.ge.0.d0)  .or.                 &
     &     (gg.le.0.d0)   .or.  (a*ank.ge.0.d0)  )                      &
     &go to 600
      if(h.ne.0.d0) hh113=sign(pi,h*ank)
      f111=pi/sbet
      f121=-a*ane*f111/bet
      f211=a*ank*f111/bet
      f221=-ank*ane*f111*(gg+2.d0*aa)/(2.d0*bet*bet)
      go to 500
  300 continue
      gg=abs(gg)
      g=sqrt(gg)
      if(r1.eq.0.d0) el1=-g
      if(r2.eq.0.d0) el2=g
      if(bet.gt.0.d0) fact1=(el1*r2-el2*r1)/gg
      if(bet.gt.0.d0) fact2=(bet*r1*r2+el1*el2)/gg
      if(bet.le.0.d0) fact1=(r2-r1)*(r2+r1)/(el1*r2+el2*r1)
      if(bet.le.0.d0) fact2=(gg-el1*el1-el2*el2)/(bet*r1*r2-el1*el2)
      if(h.ne.0.d0) hh113=atan2(h*a*fact1,r1*r2+hh*fact2)
      if(abs(fact2).lt.dltmch*abs(sbet*fact1)) go to 400
      sig=fact1/fact2
      sigs=sig*sig
      seris = sig*sigs*                                                 &
     &          (1.d0/3.d0-bet*sigs/5.d0+(bet*sigs)*(bet*sigs)/7.d0)
      f111=-sig+bet*seris
      f121=(el2*r1*aet1-el1*r2*aet2-ank*r1*r2*(r2-r1))/(gg*fact2)       &
     &-a*ane*seris
      f211=ank*(a*f111-2.d0*ane*f121)-ane*(r2-r1)
      if(sbet.gt.deltbt)                                                &
     &f221=(3.d0*a*(ank*f121-ane*f211)+ane*(r2*aet2-r1*aet1)            &
     &-ank*(r2*aks2-r1*aks1)+2.d0*hh*ank*ane*f111)/(4.d0*bet)
      zet1=ank*aet1-ane*aks1
      zet2=ank*aet2-ane*aks2
      if(sbet.le.deltbt)                                                &
     &f221=-.5d0*a*(r2-r1)+a*(hh*hh*(r2-r1)-2.d0*hh*ank*ane*a*          &
     &(zet2*r2-zet1*r1)+1.5d0*aa*(zet2*zet2*r2-zet1*zet1*r1))/          &
     &                                                   (15.d0*gg*gg)
      go to 500
  400 continue
      if(bet.lt.0.d0) f111=                                             &
     &-sign(1.d0,ane)*log((sbet*r1+abs(el1))/(sbet*r2+abs(el2)))/sbet
      if(bet.gt.0.d0) f111=                                             &
     &-atan2(sbet*fact1,fact2)/sbet
      f121=-(ank*(r2-r1)+a*ane*f111)/bet
      f211=ank*(a*f111-2.d0*ane*f121)-ane*(r2-r1)
      f221=(3.d0*a*(ank*f121-ane*f211)+ane*(r2*aet2-r1*aet1)            &
     &-ank*(r2*aks2-r1*aks1)+2.d0*hh*ank*ane*f111)/(4.d0*bet)
  500 continue
      b(1)=b(1)+hh113
      b(2)=b(2)+ank*f111
      b(3)=b(3)+ane*f111
      b(4)=b(4)+a*f111
      b(5)=b(5)+ank*f121
      b(6)=b(6)+ane*f121
      b(7)=b(7)+a*f211
      b(8)=b(8)+a*f121
      if(nf.le.6) go to 600
      b(9)=b(9)+ank*f221
      b(10)=b(10)+ane*f221
      if(its.eq.2) go to 600
      fact1=(aa+.5d0*gg)*f111-4.d0*ank*ane*f221-.5d0*(el2*r2-el1*r1)
      fact2=a*(ank*f211-ane*f121)
      b(11)=b(11)+a*(ane*ane*fact1+fact2)
      b(12)=b(12)+a*(ank*ank*fact1-fact2)
      b(13)=b(13)+a*f221
  600 continue
      du(1,1)=-b(4)-h*b(1)
      du(1,2)=-.5d0*(b(7)-hh*b(2))
      du(1,3)=-.5d0*(b(8)+hh*b(3))
      if((nf.le.6).or.(its.eq.2)) go to 625
      du(1,4)=-(hh*(b(6)+h*b(1))+b(11))/3.d0
      du(1,5) = (hh*b(5)-b(13))/3.d0
      du(1,6)=-(hh*(b(6)-h*b(1)-b(4))+b(12))/3.d0
  625 if(its.eq.1) go to 650
      dv(1,1)=-b(1)
      dv(1,2)=h*b(2)
      dv(1,3)=-h*b(3)
      dv(1,4)=-h*(b(6)+h*b(1))
      dv(1,5)=h*b(5)
      dv(1,6)=-h*(b(6)+du(1,1))
      if(nf.le.6) go to 650
      dv(1,7)=h*(hh*b(2)-b(10))
      dv(1,8)=h*(b(9)+du(1,3))
      dv(1,9)=-h*(b(10)+du(1,2))
      dv(1,10)=h*(b(9)+hh*b(3))
  650 if(ne.eq.1) go to 700
      du(2,1)=b(2)
      du(2,2)=-b(6)-h*b(1)
      du(2,3)=b(5)
      du(3,1)=b(3)
      du(3,2)=-b(5)
      du(3,3)=b(6)+du(1,1)
      du(4,1)=-b(1)
      du(4,2)=h*b(2)
      du(4,3)=-h*b(3)
      if(nf.le.6) go to 675
      du(2,4)=hh*b(2)-b(10)
      du(2,5)=b(9)+du(1,3)
      du(2,6)=-b(10)-du(1,2)
      du(3,4)=-b(9)-du(1,3)
      du(3,5)=-du(2,6)
      du(3,6)=-b(9)-hh*b(3)
      du(4,4) = h*du(2,2)
      du(4,5)=h*b(5)
      du(4,6)=-h*du(3,3)
  675 if(its.eq.1)  go to 700
      dv(2,1)=0.d0
      dv(2,2)=-b(1)
      dv(2,3)=0.d0
      dv(2,4)=2.d0*du(4,2)
      dv(2,5)=du(4,3)
      dv(2,6)=0.d0
      dv(3,1)=0.d0
      dv(3,2)=0.d0
      dv(3,3)=-b(1)
      dv(3,4)=0.d0
      dv(3,5)=du(4,2)
      dv(3,6)=2.d0*du(4,3)
      dv(4,1)=0.d0
      dv(4,2)=b(2)
      dv(4,3)=-b(3)
      dv(4,4)=2.d0*du(2,2)
      dv(4,5)=2.d0*b(5)
      dv(4,6)=-2.d0*du(3,3)
      if(nf.le.6) go to 700
      dv(2,7) = 3.d0*du(4,4)
      dv(2,8)=2.d0*du(4,5)
      dv(2,9)=du(4,6)
      dv(2,10)=0.d0
      dv(3,7)=0.d0
      dv(3,8) = du(4,4)
      dv(3,9)=dv(2,8)
      dv(3,10)=3.d0*du(4,6)
      dv(4,7)=3.d0*du(2,4)
      dv(4,8)=3.d0*du(2,5)
      dv(4,9)=-3.d0*du(3,5)
      dv(4,10)=-3.d0*du(3,6)
  700 continue
      pi2i=2.d0*pi4i
      pi2aj=pi2i*aj
      pi4aj=pi4i*aj
      pi12i=pi4i/3.d0
      x2=.5d0*x(1)
      y2=.5d0*x(2)
      x3=x(1)/3.d0
      y3=x(2)/3.d0
      do 800 i=1,ne
      if(its.eq.2) go to 750
      du(i,1)=pi2aj*du(i,1)
      du(i,2)=pi2aj*du(i,2)+x(1)*du(i,1)
      du(i,3)=pi2aj*du(i,3)+x(2)*du(i,1)
      if(nf.le.6) go to 750
      dux=du(i,2)-x2*du(i,1)
      duy=du(i,3)-y2*du(i,1)
      du(i,4)=pi4aj*du(i,4)+x(1)*dux
      du(i,5)=pi2aj*du(i,5)+x(1)*duy+x(2)*dux
      du(i,6)=pi4aj*du(i,6)+x(2)*duy
  750 if(its.eq.1) go to 800
      dv(i,1)= pi2i*dv(i,1)
      dv(i,2)= pi2i*dv(i,2)+x(1)*dv(i,1)
      dv(i,3)= pi2i*dv(i,3)+x(2)*dv(i,1)
      dvx=dv(i,2)-x2*dv(i,1)
      dvy=dv(i,3)-y2*dv(i,1)
      dv(i,4)=pi4i*dv(i,4)+x(1)*dvx
      dv(i,5)= pi2i*dv(i,5)+x(1)*dvy+x(2)*dvx
      dv(i,6)=pi4i*dv(i,6)+x(2)*dvy
      if(nf.le.6) go to 800
      dvx=dv(i,2)-x3*dv(i,1)
      dvy=dv(i,3)-y3*dv(i,1)
      dvxx=dv(i,4)-x2*dvx
      dvxy=dv(i,5)-x2*dvy-y2*dvx
      dvyy=dv(i,6)-y2*dvy
      dv(i,7)=pi12i*dv(i,7)+x(1)*dvxx
      dv(i,8)=pi4i*dv(i,8)+x(1)*dvxy+x(2)*dvxx
      dv(i,9)=pi4i*dv(i,9)+x(1)*dvyy+x(2)*dvxy
      dv(i,10)=pi12i*dv(i,10)+x(2)*dvyy
  800 continue
  900 return
      END subroutine supsbi
! **deck supspi
      subroutine supspi (pn,ics,ns,its,xp,sfac,ne,nfx,dvs,dvd)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   supspi acts as an interface between the calling program     *
!     *   and aicsup for the computation of aic*s for supersonic      *
!     *   flows with superinclined panels.   the routine aicsup uses  *
!     *   a near field evaluation procedure (closed form integrals)   *
!     *   to generate the aic-s                                       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   supspi simply takes the user data and uses it to generate   *
!     *   the appropriate aicsup input data in the common block       *
!     *   /supdta/.  it then rearranges the answers generated by      *
!     *   aicsup and applies some sign factors so that appropriate    *
!     *   care is taken of the situation in which the control point   *
!     *   lies below (but still downstream) 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                   *
!     *                                                               *
!     *   btinv     /supdta/  - - - -   the area factor for the global*
!     *                                 to local transformation       *
!     *                                                               *
!     *   doublet   /supdta/  - - - -   true if doublet aic-s are to  *
!     *                                 be computed.  otherwise, false*
!     *                                                               *
!     *   dvd       argument  output    doublet aic-s                 *
!     *                                                               *
!     *   dvs       argument  output    source aic-s                  *
!     *                                                               *
!     *   dvdp      /skrch3/  scratch   region used by aicsup for the *
!     *                                 computation of doublet aic-s  *
!     *                                                               *
!     *   dvds      /skrch3/  scratch   region used by aicsup for the *
!     *                                 computation of source aic-s   *
!     *                                                               *
!     *   infs      /nffcnt/  in/out    counter for nf source aic-s   *
!     *                                                               *
!     *   infd      /nffcnt/  in/out    counter for nf doublet aic-s  *
!     *                                                               *
!     *                                                               *
!     *   iprsup    /supflg/  - - - -   a vector of print flags       *
!     *                                                               *
!     *   its       argument  input     source/doublet indicator      *
!     *                                                               *
!     *   mits      local     - - - -   local version of mits, 1 or 2 *
!     *                                                               *
!     *   n         local     - - - -   number of corners on the panel*
!     *                                                               *
!     *   ics       argument  input     ics = 0 for quadrilaterals,   *
!     *                                 ics = number of excluded      *
!     *                                       corner for triangles    *
!     *                                                               *
!     *   ne        argument  input     row dimension of dvs, dvd     *
!     *                                                               *
!     *   p         /supdta/  - - - -   projection of the control     *
!     *                                 point on the plane of the     *
!     *                                 panel, local coordinates      *
!     *                                                               *
!     *   pn        argument  input     panel corner points, local    *
!     *                                 coordinates                   *
!     *                                                               *
!     *   q         /supdta/  - - - -   projection of panel corner    *
!     *                                 points                        *
!     *                                                               *
!     *   sfac      argument  input     the area factor for the global*
!     *                                 to local transformation       *
!     *   sgnx      /norx/    input     sign of the x-component of the*
!     *                                 panel normal, compressibility *
!     *                                 axis coordinate system        *
!     *                                                               *
!     *   x         /supdta/  - - - -   radius of the domain of       *
!     *                                 dependance, local coords      *
!     *                                                               *
!     *   xp        argument  input     local coordinates of the      *
!     *                                 control point                 *
!     *                                                               *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!c
!     *                            declare input                      *
!
!call norx
!                                                            /norx/
      common /norx/ sgnx, diamx
!end  norx
      dimension     dvsp(4,6), dvdp(4,10)
      dimension pn(3,4),xp(3),     dvs(ne,3),dvd(ne,6)
      integer  mits, ics
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                            input definitions                  *
!     *                                                               *
!     *   its       =1, source aic-s ony                              *
!     *             =2, source and doublet aic-s                      *
!     *                                                               *
!     *   ics       =0, use all four corner points (panel is a quadri-*
!     *                 lateral                                       *
!     *             =1,2,3 or 4,  ignore corner point ics,            *
!     *                           (panel is a triangle)               *
!     *                                                               *
!     *   ne        row dimension of dvs and dvd                      *
!     *                                                               *
!     *   pn(*,i)   coordinates of the panel corner in the local      *
!     *             coordinate system  ( see ics ) (assume p(3,i)=0)  *
!     *                                                               *
!     *   sfac      factor associated with transformation of source   *
!     *             integrals from global to local coordinates.       *
!     *             sfac  =  sqrt ( cosh(psi)**2 + sinh(psi)**2 ) (ftj*
!     *                   =  1/beta   (me)                            *
!     *                                                               *
!     *   sgnx      the sign of the x component of the panel normal   *
!     *             in free stream oriented coordinates               *
!     *                                                               *
!     *   xp(*)     coordinates of the field point, local coords      *
!     *                                                               *
!     *                            output definitions                 *
!     *                                                               *
!     *   dvs(ne,3) source aic-s - (ph,vx,vy,vz) x (s0,sx,sy)         *
!     *                                                               *
!     *   dvd(ne,6) doublet aic-s  -                                  *
!     *                    (ph,vx,vy,vz) x (m0,mx,my,mxx,mxy,myy)     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!c
!     *                            common region for communication    *
!     *                            with aicsup                        *
!
!call supdta
!                                                            /supdta/
      common /supdta/ p(2), x, n, doublt, btinv, nf
!end  supdta
      dimension q(2,16)
      logical  doublt
!c
!     *             do some bookkeeping chores                        *
!
      nf      =  nfx
      mits=min (2,its)
!c    *                                                               *
!     *   store panel corners in q,  also, count corner points (n)    *
!     *                                                               *
      n       =  0
      do 100 i = 1,ns
          if ( i.eq.ics ) go to 100
               n       =  n + 1
               q(1,n)  =  pn(1,i)
               q(2,n)  =  pn(2,i)
  100 continue
!                                  factor for change of coordinates,
!                                  source aic-s
      btinv   =  sfac
!                                  downstream distance of field point
      x=sgnx*xp(3)
!                                  position of center of mach cone,
!                                  local coordinates
      p(1)    =  xp(1)
      p(2)    =  xp(2)
!                                  determine if doublet aic*s are
!                                  desired
      doublt  =  mits.eq.2
!c
!     *                            call aicsup to get answers         *
!
      call aicsup(q,dvsp,dvdp)
!c
!     *   rearrange answers and apply sign factors                    *
!
      do 400 i = 1,nf
      if(ne.eq.1) go to 400
      dvd(2,i)=dvdp(2,i)*sgnx
      dvd(3,i)=dvdp(3,i)*sgnx
      dvd(4,i)=dvdp(1,i)
  400 dvd(1,i)=dvdp(4,i)*sgnx
      ng      =  3*(1+nf/10)
      do 500 i = 1,ng
      if(ne.eq.1) go to 500
      dvs(2,i)=dvsp(2,i)
      dvs(3,i)=dvsp(3,i)
      dvs(4,i)=dvsp(1,i)*sgnx
  500 dvs(1,i)=dvsp(4,i)
      return
      END subroutine supspi
! **deck surfit
      subroutine surfit(cp,ar,art)
      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 transformation matrix (and inverse) from reference   *
!     *  (global) system to panel near plane system. the latter       *
!     *  system is defined uniquely by specifying the three vectors in*
!     *  the reference coordinate system which are mapped into        *
!     *  (1,0,0), (0,1,0), and (0,0,1). these vectors are respectively*
!     *  v1,v2 and v3 where v1 is the vector from the panel midpoint  *
!     *  to the midpoint of the 4th side, v2 is the vector from the   *
!     *  panel midpoint to the 1st side, and v3 has the direction     *
!     *  v1 cross v2 with magnitude equal to the square root of the   *
!     *  magnitude of v1 cross v2.                                    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  compute v1 and store in art(1),art(2),art(3).                *
!     *  compute v2 and store in art(4),art(5),art(6).                *
!     *  compute v3 as v1 cross v2  and store in art(7),art(8),art(9).*
!     *  art is now correct inverse transformation matrix.            *
!     *  now invert art to find the actual transformation matrix.     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   ar        argument  output    transformation matrix from    *
!     *                                 reference to panel near plane *
!     *                                 coordinate system             *
!     *                                                               *
!     *   art       argument  output    inverse of ar                 *
!     *                                                               *
!     *   cp        argument  input     panel corner points in global *
!     *                                 or reference coordinates      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension cp(3,4),ar(9),art(9)
      do 50 i=1,3
!c
!     *  compute v1 and store in art(1),art(2),art(3).                *
!
      art(i)=.25d0*(cp(i,1)+cp(i,4)-cp(i,2)-cp(i,3))
!c
!     *  compute v2 and store in art(4),art(5),art(6).                *
!
      art(i+3)=.25d0*(cp(i,1)+cp(i,2)-cp(i,3)-cp(i,4))
   50 continue
!c
!     *  compute v3 as v1 cross v2  and store in art(7),art(8),art(9).*
!
      call cross(art(1),art(4),art(7))
      call mag(art(7),artm)
      artm=sqrt(artm)
      artmi=1.d0/artm
      art(7)=artmi*art(7)
      art(8)=artmi*art(8)
      art(9)=artmi*art(9)
      af=artmi**3
      ar(1)=af*(art(5)*art(9)-art(6)*art(8))
      ar(2)=af*(art(8)*art(3)-art(9)*art(2))
      ar(3)=af*artm*art(7)
      ar(4)=af*(art(6)*art(7)-art(4)*art(9))
      ar(5)=af*(art(9)*art(1)-art(7)*art(3))
      ar(6)=af*artm*art(8)
      ar(7)=af*(art(4)*art(8)-art(5)*art(7))
      ar(8)=af*(art(7)*art(2)-art(8)*art(1))
      ar(9)=af*artm*art(9)
      return
      END subroutine surfit
! **deck surpro
      subroutine surpro(z,zp,ic)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  project given point onto segmented flat panel surface and    *
!     *  identify sub-panel of projection. projection is in direction *
!     *  of near plane normal.                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  compute panel near plane coordinates of given point (see     *
!     *  subroutine surfit). use in-plane coordinates to determine    *
!     *  sub-panel of projection. then subtract height above sub-panel*
!     *  and transform coordinates of projection back to global       *
!     *  system.                                                      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   aq        /pandq/   input     transformation matrix from    *
!     *                                 global to near plane          *
!     *                                 coordinate system             *
!     *                                                               *
!     *   aqi       /pandq/   input     inverse of aq                 *
!     *                                                               *
!     *   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        *
!     *                                                               *
!     *   ic        argument  output    sub-panel of zp               *
!     *                                                               *
!     *   ics       /pandq/   input     =0 - panel is quadrilateral   *
!     *                                 =1 thru 4 - panel is triangle *
!     *                                     because edge ics is       *
!     *                                    collapsed                  *
!     *                                                               *
!     *   z         argument  input     given point                   *
!     *                                                               *
!     *   zp        argument  output    projection of given point     *
!     *                                 onto segmented flat panel in  *
!     *                                 direction of near plane normal*
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!+
!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),zp(3),zq(3)
      call dcopy (3,z,1,zq,1)
!c
!     *  compute panel near plane coordinates of given point          *
!
      call unipan(aq,cp(1,9),z,zp)
!c
!     *  use in-plane coordinates to determine sub-panel of projection*
!
      m=1
      n=1
      if(zp(1).ne.0.d0) m=sign(1.d0,zp(1))
      if(zp(2).ne.0.d0) n=sign(1.d0,zp(2))
      if(abs(zp(1))+abs(zp(2))-1.d0) 300,300,500
  300 continue
!c
!     *  projection lies on inner parallelogram                       *
!
      zp(3)=0.d0
      ic=6-n+iabs(n-m)/2
      go to 900
  500 continue
!c
!     *  projection lies on one of corner triangles                   *
!
      ic=2-n+iabs(n-m)/2
      icp3=mod(ic+2,4)+1
!c
!     *  project onto inner parallelogram if triangle is collapsed    *
!
      if((ic.eq.ics).or.(icp3.eq.ics)) go to 300
      do 600 i=1,3
  600 zq(i)=zq(i)-cp(i,ic)
      call mxm (zq,1,en(1,ic),3,fn,1)
      call mxm (aqi(7),1,en(1,ic),3,fd,1)
!c
!     *  subtract height above subpanel                               *
!
      zp(3)=zp(3)-fn/fd
  900 continue
!c
!     *  transform coordinates of projection back to global system    *
!
      call panuni(aqi,cp(1,9),zp,zp)
      return
      END subroutine surpro
! **deck sutput
      subroutine sutput
      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 and print output                                *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 vrwi
      common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp)
!end  vrwi
!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 chkpnt
      common /chkpnt/  nckaic, nckusp
!end  chkpnt
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
!                                  get max panels, doublet parms
      mxxpan  =  0
      mxxdbl  =  0
      mxxfg   =  0
      do 100 knet = 1,nnett
         mxxpan  =  max ( mxxpan, (nm(knet)-1)*(nn(knet)-1) )
         mxxdbl  =  max ( mxxdbl, (nm(knet)+1)*(nn(knet)+1) )
         mxxfg   =  max ( mxxfg,  (2*nm(knet)-1) * (2*nn(knet)-1)   )
  100 continue
!                                  allocate memory
      call setcor ('sutput')
!
      call getcor ('dvdfs',lldvdf,4*nsngt)
      call getcor ('pres', llpres,3*mxxpan)
      call getcor ('za',   llza,  3*mxxpan)
      call getcor ('s',    lls,     nsngt)
      call getcor ('scas', llscas,4*nsngt)
      call getcor ('smat', llsmat,  mxxpan)
      call getcor ('dmat', lldmat,  mxxfg)
      call getcor ('dblm', lldblm,4*mxxdbl)
      call getcor ('rv',   llrv,  6*mxxpan)
!
      call openms (ntv,niv,nnv,0)
      if ( nckaic.eq.1 ) call readms (ntv,nwv,nctrt,nctrt+1)
      call output (mxxpan,    mxxdbl,    mxxfg                          &
     &            ,w(lldvdf), w(llpres), w(llza),   w(lls)              &
     &            ,w(llscas), w(llsmat), w(lldmat), w(lldblm)           &
     &            ,w(llrv)                                              &
     &            )
      call closms (ntv)
!c
!     *  print out job status and cost for step just completed        *
!
      call cstprt ('output  ')
      call frecor ('sutput')
      return
      END subroutine sutput
! **deck svinfc
      subroutine svinfc
      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 potential and velocity influence 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                   *
!     *                                                               *
!     *   iedgep    /prnt/    input     =1 if edge matching diagnostic*
!     *                                 printout is desired           *
!     *                                                               *
!     *   ipraic    /prnt/    input     =0   if no pic diagnostic     *
!     *                                      printout is desired      *
!     *                                 =k   if pic diagnostic print- *
!     *                                      out is desired for kth   *
!     *                                      control point            *
!     *                                                               *
!     *   ncalg     /iomag/   -local-   number of storage requests for*
!     *                                 generating influence          *
!     *                                 coefficient matrix blocks     *
!     *                                                               *
!     *   ncalt     /iomag/   -local-   number of storage requests for*
!     *                                 transposing blocks of ifluence*
!     *                                 coefficients                  *
!     *                                                               *
!     *   npic      /piccnt/  -local-   pic counter array             *
!     *                                                               *
!     *   nwrdg     /iomag/   -local-   number of words read and      *
!     *                                 written when generating       *
!     *                                 influence coefficient blocks  *
!     *                                                               *
!     *   nwrdt     /iomag/   -local-   number of words read and      *
!     *                                 written when transposing      *
!     *                                 influence coefficient blocks  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call iomag
!                                                            /iomag/
      common /iomag/ncalg,ncalt,nwrdg,nwrdt
!end  iomag
      character*72 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 vrwi
      common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp)
!end  vrwi
!call piccnt
!                                                     /piccnt/
      common /piccnt/ npic(4,7), n56chg(0:3)
!end  piccnt
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!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
!                                                  ...  mxxscr = 295 000
      parameter (mxxscr=295000)
!                                                  ...  mxxcls = 512
      parameter (mxxcls=512)
!                                                  ...  mxxrws = 300
      parameter (mxxrws=300)
!
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
      nw      =  300000
      call setcor ('svinfc')
      nnscr   =  mxxscr
! -----      call getcor ('scr',llscr,nnscr)
      nncls   =  mxxcls
      nnrws   =  mxxrws
      call igtcor ('nwvx',llnwvx,4*nctrt+40)
!c
!     *  initialize potential and velocity influence coefficient      *
!     *  generation i/o counters                                      *
!
      ncalg   =  0
      ncalt   =  0
      nwrdg   =  0
      nwrdt   =  0
      call jzero (npic,28)
      call jzero (n56chg,4)
!c
!     *  write header for edge matching diagnostic printout if desired*
!
!c
!     *  write header for panel influence coefficient calculation     *
!     *  diagnostic printout if desired                               *
!
      if(ipraic.ne.0) write(6,6077) ipraic
 6077 format(///50x,26hpics for control point no.,i5,///)
!c
!     *  compute potential and velocity influence coefficients        *
!
      call wopen (4,15,0,ierr)
      call openms (ntv,niv,nnv,0)
      call vinfcc (w(llnwvx))
      call closms (ntv)
      write (line,9001) ntv,maxcp+1,nctrt,nctrt+1
      call remarx (line)
 9001 format (' ft',i2.2,' (pic file) done.  index lth-',i5             &
     &  ,'  cp count-',i5,'  nwv recd-',i5)
!                                  adjust the pic counts
!                                  n56chg: (1,2,3) <==> (S,D,S+D)
      n56chg(1) = n56chg(1) + n56chg(3)
      n56chg(2) = n56chg(2) + n56chg(3)
!                                  adjust source influence counts
      npic(1,5+1) = npic(1,5+1) + n56chg(1)
      npic(1,6+1) = npic(1,6+1) - n56chg(1)
!                                  adjust double influence counts
      npic(2,5+1) = npic(2,5+1) + n56chg(2)
      npic(2,6+1) = npic(2,6+1) - n56chg(2)
      write (6,1000)
      write (6,2000) npic
 1000 format ( ///,4x, 10hpic counts, 31x,                              &
     & 60h   panel/source  panel/doublet   block/source  block/doublet)
 2000 format ( /,                                                       &
     &  4x, 15hno influence                       , 24x,4i15,/,         &
     &  4x, 25hmonopole far field                 , 14x,4i15,/,         &
     &  4x, 25hdipole far field                   , 14x,4i15,/,         &
     &  4x, 25hquadrupole far field               , 14x,4i15,/,         &
     &  4x, 35hone sub-panel intermediate field   ,  4x,4i15,/,         &
     &  4x, 35htwo sub-panel intermediate field   ,  4x,4i15,/,         &
     &  4x, 35height sub-panel near field         ,  4x,4i15,/,         &
     &    /)
      write(6,3000) ncalg,nwrdg,ncalt,nwrdt
 3000 format(///20x,42hinfluence coefficient generation i/o count,/     &
     &3x,6hncalg=,i9,3x,6hnwrdg=,i12,3x,6hncalt=,i9,3x,6hnwrdt=,i12)
      call outvci ('n56chg:',4,n56chg)
      call frecor ('svinfc')
      call cstprt ('pic cost')
      return
      END subroutine svinfc
! **deck tcntrl
      subroutine tcntrl (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)
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to generate control point defining quantities for all        *
!     *  control points                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the routine calls contrl for each network to calculate       *
!     *  control point 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                   *
!     *                                                               *
!     *   icontp    /prnt/    input     control point diagnostic      *
!     *                                 print flag                    *
!     *                                                               *
!     *   k         -local-   - - - -   index for network             *
!     *                                                               *
!     *   nc        /index/   output    array containing number of    *
!     *                                 control points in each network*
!     *   nca       /index/   output    array containing running sum  *
!     *                                 of nc                         *
!     *                                                               *
!     *   nctrt     /index/   output    total number of control points*
!     *                                                               *
!     *   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      *
!     *                                                               *
!     *   npa       /index/   input     array containing running      *
!     *                                 sum of np                     *
!     *                                                               *
!     *   ntd       /index/   input     array containing network      *
!     *                                 doublet types                 *
!     *                                                               *
!     *   nza       /index/   input     array containing running      *
!     *                                 sum of nz                     *
!     *                                                               *
!     *   zm        /mspnts/  input     array containing panel corner *
!     *                                 points (x,y,z coordinates)    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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
!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 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 mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!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 xtrns (9,nedmpa,nx9)
      call xtrns (8,nfsga,nx8)
      call xtrns ( 7,kfdseg,nx7)
      nfdseg  =  nx7/4
      call xtrns (16,nedaba,nabtp1)
      call xtrns (2,ifsgai,nx2)
      call xtrns (3,mcmpai,naicp)
      call xtrns (17,mtchab,nx17)
      call xtrns (10,kempec,nedmp)
      call xtrns (1,nbraia,nmpec1)
      call xtrns (6,kfdsgn,nx6)
      call xtrns (13,tauemp,nx13)
      nedmp   =  nx13/kklr2i
      call xtrns (18,iedgtp,nx18)
      nabt    =  nabtp1 - 1
      nmpec   =  nmpec1 - 1
!
      nbca(1) =  0
      nca(1)  =  0
      nmapca(1)= 0
      do 200 k = 1,nnett
      call cmngrd (k,mcpnet,ncpnet)
      nxspk   =  nxspa(k+1) - nxspa(k)
      nbca(k+1) =  nbca(k) + mcpnet*ncpnet
      nmapca(k+1) =  nmapca(k) + mcpnet*ncpnet + nxspk
      lzknet  =  nza(k) + 1
      ntk     =  ntd(k)
      call contrl (k,ntk,nm(k),nn(k),nc,nca(k),nbca(k),nmapca(k),npa(k) &
     &            ,mcpnet,ncpnet,zm(1,lzknet)                           &
     &            ,za,tauemp,ia,mapbc,mapc                              &
     &            ,locfg,iamapc,key,keyinv                              &
     &            ,nedmpa,nfsga,kfdseg,nedaba,ifsgai                    &
     &            ,mcmpai,mtchab,kempec,nbraia,kfdsgn,iedgtp            &
     &            )
      nca(k+1)=  nca(k) + nc
  200 continue
      nctrt   =  nca(nnett+1)
      nctrn   =  nbca(nnett+1)
      nctrnx  =  nmapca(nnett+1)
      if ( icontp.lt.2 ) go to 950
      call outvci ('nca',nnett+1,nca)
      call outvci ('nbca',nnett+1,nbca)
      call outvci ('nmapca',nnett+1,nmapca)
  950 continue
      call ixtrns (31,mapbc,nctrn)
      call ixtrns (32,mapc,nctrnx)
      return
      END subroutine tcntrl
! **deck tcof
      subroutine tcof(p,b,c,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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  compute transformation matrices relating taylor series       *
!     *  coefficients of linear, quadratic and cubic distributions    *
!     *  on a triangle to values of distribution at vertices and (in  *
!     *  the quadratic case) values of edge lamdas and (in the cubic  *
!     *  case) the value at the triangle center. the taylor series    *
!     *  coefficients are defined in terms of the coordinate system   *
!     *  in which the triangle corner points are expressed. an edge   *
!     *  lamda is defined as the value of the distribution at the     *
!     *  edge midpoint minus one-eighth the second derivative of the  *
!     *  distribution along the edge times the square of the edge     *
!     *  length. the triangle center is defined as the average of the *
!     *  three vertices and the cubic is assumed to be quadratic along*
!     *  each edge.                                                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  express distributions in terms of values and lamdas using    *
!     *  triangle coordinates el1,el2,and el3 where el1 is 1 at the   *
!     *  first vertex and zero at the other two, and similarly for    *
!     *  el2,el3. for a linear distribution s we have                 *
!     *  s=el1*s1+el2*s2+el3*s3 where s1,s2 and s3 are the values of  *
!     *  s at the vertices respectively. for a quadratic distribution *
!     *  s we have s=el1*el1*s1+el2*el2*s2+el3*el3(s3+                *
!     *  2.*el2*el3*lamda1+2.*el3*el1*lamda2+2.*el1*el2*lamda3 where  *
!     *  lamda1,lamda2 and lamda3 are the edge lamdas of s            *
!     *  respectively. for the cubic distribution s we have s=        *
!     *  quadratic distribution + 27.*el1*el2*el3*(s4-(s1+s2+s3)/9.   *
!     *  -2.*(lamda1+lamda2+lamda3)/9.) , where s4 is the value of s  *
!     *  at the triangle center. the taylor series coefficients in    *
!     *  terms of the vertex values, edge lamdas and center value can *
!     *  now be achieved by differentiating the distributions so      *
!     *  expressed.                                                   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   b         argument  output    matrix relating taylor series *
!     *                                 coefficients of linear distri-*
!     *                                 bution to values at vertices  *
!     *                                                               *
!     *   c         argument  output    matrix relating taylor series *
!     *                                 coefficients of quadratic     *
!     *                                 distribution to values at     *
!     *                                 vertices and edge lamdas      *
!     *                                                               *
!     *   d         argument  output    matrix relating taylor series *
!     *                                 coefficients of cubic (which  *
!     *                                 is quadratic along edges)  to *
!     *                                 values at vertices, edge      *
!     *                                 lamdas and value at center    *
!     *                                                               *
!     *   p         argument  input     array whose columns are the   *
!     *                                 triangle vertices expressed   *
!     *                                 in a coordinate system whose  *
!     *                                 first two coordinate axes lie *
!     *                                 in plane of triangle          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension p(3,3),b(3,3),c(6,6),d(10,7)
  DOUBLE PRECISION:: det
!c
!     *  compute linear distribution matrix b                         *
!
      det=(p(1,2)-p(1,1))*(p(2,3)-p(2,1))-(p(1,3)-p(1,1))*(p(2,2)       &
     &-p(2,1))
      do 100 i=1,3
      ip1=mod(i,3)+1
      ip2=mod(ip1,3)+1
      b(1,i)=(p(1,ip1)*p(2,ip2)-p(1,ip2)*p(2,ip1))/det
      b(2,i)=(p(2,ip1)-p(2,ip2))/det
      b(3,i)=(p(1,ip2)-p(1,ip1))/det
  100 continue
!c
!     *  compute quadratic distribution  matrix c                     *
!
      do 200 i=1,3
      ip1=mod(i,3)+1
      ip2=mod(ip1,3)+1
      c(1,i)=b(1,i)**2
      c(2,i)=2.d0*b(1,i)*b(2,i)
      c(3,i)=2.d0*b(1,i)*b(3,i)
      c(4,i)=2.d0*b(2,i)**2
      c(5,i)=2.d0*b(2,i)*b(3,i)
      c(6,i)=2.d0*b(3,i)**2
      c(1,i+3)=2.d0*b(1,ip1)*b(1,ip2)
      c(2,i+3)=2.d0*(b(1,ip1)*b(2,ip2)+b(2,ip1)*b(1,ip2))
      c(3,i+3)=2.d0*(b(1,ip1)*b(3,ip2)+b(3,ip1)*b(1,ip2))
      c(4,i+3)=4.d0*b(2,ip1)*b(2,ip2)
      c(5,i+3)=2.d0*(b(2,ip1)*b(3,ip2)+b(3,ip1)*b(2,ip2))
      c(6,i+3)=4.d0*b(3,ip1)*b(3,ip2)
  200 continue
!c
!     *  compute cubic distribution matrix d                          *
!
      d(1,7)=27.d0*b(1,1)*b(1,2)*b(1,3)
      d(2,7)=27.d0*(b(1,1)*b(2,2)*b(1,3)+b(2,1)*b(1,2)*b(1,3)           &
     &+b(1,1)*b(1,2)*b(2,3))
      d(3,7)=27.d0*(b(1,1)*b(3,2)*b(1,3)+b(3,1)*b(1,2)*b(1,3)           &
     &+b(1,1)*b(1,2)*b(3,3))
      d(4,7)=54.d0*(b(1,1)*b(2,2)*b(2,3)+b(2,1)*b(1,2)*b(2,3)           &
     &+b(2,1)*b(2,2)*b(1,3))
      d(5,7)=27.d0*(b(1,1)*(b(2,2)*b(3,3)+b(3,2)*b(2,3))+b(1,2)*(b(2,1) &
     &*b(3,3)+b(3,1)*b(2,3))+b(1,3)*(b(2,1)*b(3,2)+b(2,2)*b(3,1)))
      d(6,7)=54.d0*(b(1,1)*b(3,2)*b(3,3)+b(1,2)*b(3,1)*b(3,3)           &
     &+b(1,3)*b(3,1)*b(3,2))
      d(7,7)=162.d0*b(2,1)*b(2,2)*b(2,3)
      d(8,7)=54.d0*(b(2,1)*b(2,2)*b(3,3)+b(2,1)*b(3,2)*b(2,3)           &
     &+b(3,1)*b(2,2)*b(2,3))
      d(9,7)=54.d0*(b(3,1)*b(3,2)*b(2,3)+b(2,1)*b(3,2)*b(3,3)           &
     &+b(3,1)*b(2,2)*b(3,3))
      d(10,7)=162.d0*b(3,1)*b(3,2)*b(3,3)
      do 500 j=1,3
      do 300 i=1,6
      d(i,j)=c(i,j)-d(i,7)/9.d0
  300 d(i,j+3)=c(i,j+3)-2.d0*d(i,7)/9.d0
      do 400 i=7,10
      d(i,j)=-d(i,7)/9.d0
  400 d(i,j+3)=-2.d0*d(i,7)/9.d0
  500 continue
      return
      END subroutine tcof
! **deck tgeomc
      subroutine tgeomc
      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 panel defining quantities                            *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the routine calls geomc for each network to calculate panel  *
!     *  geometry defining quantities (cf subroutine geomc).          *
!     *  in addition the routine prints diagnostic geometry           *
!     *  information if desired                                       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   igeomp    /prnt/    input     panel geometry diagnostic     *
!     *                                 print flag                    *
!     *                                                               *
!     *   iza       -local-   - - - -   running index of grid points  *
!     *                                                               *
!     *   k         -local-   - - - -   index over networks           *
!     *                                                               *
!     *   m         -local-   - - - -   index over rows in each       *
!     *                                 network corner point          *
!     *                                                               *
!     *   mmax      -local-   - - - -   number of rows in each        *
!     *                                 network corner point grid     *
!     *                                                               *
!     *   n         -local-   - - - -   index over columns in each    *
!     *                                 network corner point grid     *
!     *                                                               *
!     *   nmax      -local-   - - - -   number of columns in each     *
!     *                                 network corner point grid     *
!     *                                                               *
!     *   nm        /index/   input     array containing number of    *
!     *   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             *
!     *                                                               *
!     *   npa       /index/   output    array containing running      *
!     *                                 sum of np                     *
!     *                                                               *
!     *   npant     /index/   output    total number of panels        *
!     *                                                               *
!     *   np        /index/   output    array containing number of    *
!     *                                 panels in each network        *
!     *                                                               *
!     *   nz        /index/   output    array containing number of    *
!     *                                 grid points in each network   *
!     *                                                               *
!     *   nzmpt     /index/   output    total number of grid points   *
!     *                                                               *
!     *                                                               *
!     *   zm        /mspnts/  input     array containing panel corner *
!     *                                 points (x,y,z coordinates)    *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!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 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 prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!call irwi
      common /irwi/ nidq(21), nsi, nri, nti, nni, nii(21)
!end  irwi
!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 symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!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 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 kutflg
!                                                            /kutflg/
      common /kutflg/ kutta(150), kttype(150)
!end  kutflg
!call ofbod
!**
!**       nof is the total number of offbody points generated by $xyz
!**       and $grids.
!**
      common /ofbod/ nof
!end  ofbod
!call slofbd
!         information about off-body input and streamline input is
!         stored in  /slofbd/.  the array  zof(1:5000)  contains up
!         the coordinates of up to  1666  off-body points.   the
!         array  stmln(7,1:500)  contains the following information
!         about the streamline start points (up to 500 in all):
!              stmln(1,i) = starting x value
!              stmln(2,i) = starting y value
!              stmln(3,i) = starting z value
!              stmln(4,i) = max value of del(x) along the streamline
!              stmln(5,i) = max value of del(y) along the streamline
!              stmln(6,i) = max value of del(z) along the streamline
!              stmln(7,i) = forward/backward indicator. (0 ==> forward,
!                                nonzero ==> backward integration )
      common /slofbd/ zof(5000), stmln(7,500)
!end  slofbd
!call iduser
      character*10  iduser
      common /iduser/ iduser(150)
!end  iduser
!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 nwlst
      common /cnwlst/ nwname(mxnett)
      character*10 nwname
      common /anwlst/ nnwlst
!end  nwlst
      character*30 kutmsg(4)
!call datchk
!                                                            /datchk/
      common/datchk/ndtchk
!end  datchk
!call prtnor
!                                                            /prtnor/
      common /prtnor/ nprten
!end  prtnor
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!c
!     *  if requested, print out the geometry data                    *
!call narmsg
!                                                            /narmsg/
      common /narmsg/ nasrat
!end  narmsg
!
 1010 format(1h1)
 1000 format(////60x,13hgeometry data,////)
 3000 format(//58x,15hmesh point data,///,2x,6hnumber,6x,3hrow,         &
     &5x,6hcolumn,3x,8hnet. no.,16x,1hx,29x,1hy,29x,1hz,//)
!                  123456789012345678901234567890
      kutmsg(1) = 'doublet matching only         '
      kutmsg(2) = 'vorticity matching            '
      kutmsg(3) = '2nd order pressure matching   '
      kutmsg(4) = 'isentropic pressure matching  '
      iza=0
      nza(1)=0
!c
!     *  loop ranges over the networks                                *
!
      do 100 k=1,nnett
      nz=nm(k)*nn(k)
  100 nza(k+1)=nza(k)+nz
      nzmpt=nza(nnett+1)
      if( nzmpt .le. maxpts ) go to 25
      write (6,5000) nzmpt, maxpts
      go to 400
!c
!     *  calculate abutments and abutment intersections               *
!
   25 continue
!
      ica     =  1
      indhd   =  0
      do 20 k = 1,nnett
          kutta(k) =  0
          call cmngrd (k,mcp,ncp)
          if( ntd(k).ne.6 .and. ntd(k).ne.8 .and. ntd(k).ne.18 ) goto 15
          ic      =  ica
          do 12 j = 2,ncp-1
               ic      =  ic + mcp
               call btrns (ic,cu1)
               if ( nlopt1.eq.15 .or. nlopt2.eq.15 ) kutta(k) = 1
               if ( nlopt1.eq.16 .or. nlopt2.eq.16 ) kutta(k) = 2
               if ( nlopt1.eq.17 .or. nlopt2.eq.17 ) kutta(k) = 3
   12     continue
          if ( indhd.eq.0 ) write (6,6005)
          indhd   =  1
          ktyp    =  max(1, min(4, kutta(k)+1  ))
          write (6,6004) k, nwname(k), kutmsg(ktyp)
 6005 format (//,10x,'leading edge conditions on wake networks'         &
     &       ,/, 10x                                                    &
     &       ,/, 10x,'nw-id',2x,'   nw-name',4x,'     condition '       &
     &       ,/, 10x,'-----',2x,'----------',4x,'----------------------'&
     &        )
 6004 format (10x,    i3,2x  ,2x,a10        ,4x,a30)
   15     continue
          ica     =  ica + mcp*ncp
   20 continue
!
      xpidnt  =  .not. newabt
!
!                                  define epsgeo and jsympa for the
!                                  call to  abtidn  which will identify
!                                  abutments and abutment intersections
!                                  and adjust the geometry.
   30 continue
      call bmark ('libgeoab')
      write (6,6003)
 6003 format (1h1,10x,'*****  liberalized geometry abutment analysis  **&
     &***')
      call abtdim (nnett,nm,nn,zm,ntd,  diamin,diamax)
      epsmax  =  .1d0*diamin
      epsdef  =  .001d0*diamin
      if ( epsgeo .eq. 0.d0 ) epsgeo = epsdef
      if ( epsgeo .gt. epsmax ) write (6,6001) epsgeo,epsmax
 6001 format ('0 *** warning ***      specified geometry tolerance of ' &
     & ,e12.4,' is greater than  .03*(min panel diameter.'              &
     & ,/,    '                       value will be adjusted down to '  &
     & ,e12.4 )
      if ( epsgeo .gt. epsmax ) epsgeo = epsmax
      epsgeo  =  abs( epsgeo )
!         compute the panair symmetry condition index
      jsympa  =  1
      if ( misym.lt.0 .and. nsymm.ge.1 ) jsympa = 2
      if ( mjsym.lt.0 .and. nsymm.ge.2 ) jsympa = 4
      if ( misym.lt.0 .and. mjsym.lt.0 .and. nsymm.ge.2 ) jsympa = 3
      write (6,6002) epsgeo, diamin, jsympa
 6002 format ('0 edge abutment tolerance   = ', 1pe12.4                 &
     &  ,/,   '  minimum panel diameter    = ', 1pe12.4                 &
     &  ,/,   '  symmetry condition index  = ',   i12                   &
     &  ,/,   '        1 ==> phi(s-s)  '                                &
     &  ,/,   '        2 ==> phi(a-s)  '                                &
     &  ,/,   '        3 ==> phi(a-a)  '                                &
     &  ,/,   '        4 ==> phi(s-a)  '                                &
     &  ,//)
!
      call CPU_TIME (ta)
      call setcor ('abtidn')
!
      call igtcor ('mn2f',llmn2f,2*maxcp)
      call igtcor ('mb2n',llmb2n,2*maxcp)
      call igtcor ('mn2b',llmn2b,2*maxcp)
      call igtcor ('mb2f',llmb2f,2*maxcp)
      call igtcor ('kb2f',llkb2f,2*maxcp)
!
      call getcor ('zsv' ,llzsv ,3*maxpts)
!
      call igtcor ('kpeq',llkpeq,  mxempt)
      call igtcor ('kmeq',llkmeq,  mxempt)
      call getcor ('wgeq',llwgeq,  mxempt)
      call igtcor ('nfsa',llnfsa,4*mxnett+1)
      call igtcor ('kpfg',llkpfg,4*mxempt)
!
      call igtcor ('kmpc',llkmpc,  mxempt)
      call igtcor ('kpmp',llkpmp,  mxempt)
      call igtcor ('kmky',llkmky,  mxempt)
      call getcor ('taue',lltaue,  mxempt)
      call igtcor ('mpai',llmpai,  mxempt+1)
!
!!      call abtidn (nnett,nm,nn,zm,ntd,compd,epsgeo,nsymm,jsympa         & ! Removed by Martin Hegedus, 4/21/09
      call abtidn (nnett,nm,nn,zm,ntd,compd,epsgeo,nisym,njsym,jsympa   & ! Added by Martin Hegedus, 4/21/09
     &            ,w(llmn2f),w(llmb2n),w(llmn2b),w(llmb2f),w(llkb2f)    &
     &            ,w(llzsv)                                             &
     &            ,w(llkpeq),w(llkmeq),w(llwgeq),w(llnfsa),w(llkpfg)    &
     &            ,w(llkmpc),w(llkpmp),w(llkmky),w(lltaue),w(llmpai)    &
     &            )
      call frecor ('abtidn')
      call CPU_TIME (tb)
      write (6,'(1x,a10,1x, f12.6)')                                    &
     & 't/abtidn',tb-ta
!                                  define the standard pilot code data
!                                  structures for abutments and
!                                  abutment intersections
      call CPU_TIME (ta)
      call CPU_TIME (tb)
      write (6, '(1x,a10,1x, f12.6)' )                                  &
     & 'abtcal/anl',tb-ta
      call emark  ('libgeoab')
!                                  check for any untoward intersections
!                                  that may have been induced.
      if ( .not. xtrint ) go to 32
      call CPU_TIME (ta)
      call triint (nnett,nm,nn,nza,zm,  intcnt)
      call CPU_TIME (tb)
      write (6,'(1x,a10,1x,  f12.6)')                                   &
     & 't/triint',tb-ta
   32 continue
!                                  compare old and new p.c. data structu
   40 continue
!                                  print network normals on a datacheck
      if ( nprten.eq.0 ) goto 130
      call bmark ('netnorml')
      lz      =  1
      do 120 k = 1,nnett
      write (6,6101) k, iduser(k)
 6101 format ('  === panel normals for nw # ',i3,', ',a)
      mnpan   =  (nm(k)-1)*(nn(k)-1)
      call setcor ('norprt')
      call getcor ('enk',llenk,3*mnpan)
      call norprt ( zm(1,lz), nm(k),nn(k),  w(llenk),nm(k)-1,nn(k)-1)
      call frecor ('norprt')
      lz      =  lz + nm(k)*nn(k)
      write (6,6006)
 6006 format (' ')
  120 continue
      call emark ('netnorml')
  130 continue
!                                   put in various other checks
      npa(1)  =  0
      do 140 k = 1,nnett
         np      =(nm(k)-1)*(nn(k)-1)
         npa(k+1)= npa(k) + np
         if( np .gt. mxntpn ) then
            write(6,6000) np,k,mxntpn
            go to 400
         endif
  140 continue
      npant   =  npa(nnett+1)
      if( npant.gt.maxpan ) then
         write(6,7000) npant,maxpan
         go to 400
      endif
!                                   move any offbody points lying on a
!                                   subpanel boundary into the interior
!                                   of the subpanel, elevate slightly.
      if ( nof.gt.0 ) then
         nof3    =  nidq(16)
         call readmd (nti,zof,nof3,16)
!!         call offchk (nof,zof,  nsymm,nnett,npant,nm,nn,nza,npa,zm)       ! Removed by Martin Hegedus, 4/21/09
         call offchk (nof,zof,nisym,njsym,nnett,npant,nm,nn,nza,npa,zm)   ! Added by Martin Hegedus, 4/21/09
         call writmd (nti,zof,nof3,16,  -1,0)
      endif
!                                   for type 3 datacheck, run geomc and
!                                   ffdqg style geometry checks.
      if ( ndtchk.ge.2 ) then
         call geodtc (nnett,nm,nn,zm)
         return
      endif
!
!c
!     *  write header if panel diagnostic data is requested (igeomp=1)*
!
      if(igeomp.eq.1) write(6,2000)
 2000 format(////60x,10hpanel data//)
!c
!     *  loop cycles over the networks to compuate the panel          *
!     *  defining quantities                                          *
!
      npa(1)=0
      nasrat  =  0
      do 200 k=1,nnett
!c
!     *  set up the arguments for geomc                               *
!
      np=(nm(k)-1)*(nn(k)-1)
      if( np .le. mxntpn ) go to 150
      write(6,6000) np,k,mxntpn
      go to 400
  150 nzmpa1 = nza(k) + 1
!c
!     *  generate the defining quantities via geomc                   *
!
      call geomc(k,nm(k),nn(k),npa(k),nza(k),zm(1,nzmpa1))
      npa(k+1)=npa(k)+np
  200 continue
      if ( nasrat.ne.0 ) call emark ('asprmsg ')
      npant=npa(nnett+1)
      if( npant .le. maxpan ) go to 250
      write(6,7000)npant,maxpan
      go to 400
  250 continue
      call ixtrns (51,zm,3*kklr2i*nzmpt)
      call ixtrns (52,nm,nnett)
      call ixtrns (53,nn,nnett)
      return
 5000 format(1h ,36(2h *),/,'   -execution terminated-',/,              &
     &       '   total no. of mesh points = ',i6,/,                     &
     &       '   exceeds max. allowable (',i6,' )',/,36(2h *))
 6000 format(1h ,36(2h *),/,'   -execution terminated-',/,              &
     &       '   no. of panels = ',i6,'   in network no. ',i4,/,        &
     &       '   exceeds max. allowable (',i6,' )',/,36(2h *))
 7000 format(1h ,36(2h *),/,'   -execution terminated-',/,              &
     &       '   total no. of panels = ',i6,/,                          &
     &       '   exceeds max. allowable (',i6,' )',/,36(2h *))
  400 stop
      END subroutine tgeomc
! **deck trace
      subroutine trace (zk,nmk,nnk,npa,npagp,array                      &
     &                 ,xcn,ycn,zcn,pdist,intsec)
      implicit double precision (a-h,o-z)
!
!     --------------------- purpose of routine ------------------------
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     * trace across network for entry and exit points of cut plane   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * *  m e t h o d  * * *                   *
!     *                          - - - - - -                          *
!     *                                                               *
!     *     array is constructed to contain trace information of      *
!     *     dimensions array( k, panel number) where k in this        *
!     *     routine ranges over:                                      *
!     *         1  network number                                     *
!     *         2  global data x entry                                *
!     *         3  global data y entry                                *
!     *         4  global data z entry                                *
!     *         5  global data x exit                                 *
!     *         6  global data y exit                                 *
!     *         7  global data z exit                                 *
!     *         8  mean plane x entry                                 *
!     *         9  mean plane y entry                                 *
!     *         10 mean plane x exit                                  *
!     *         11 mean plane y exit                                  *
!     *         12 panel normal vector x                              *
!     *         13 panel normal vector y                              *
!     *         14 panel normal vector z                              *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     --------------------- formal parameter list ---------------------
!
!
!     zm : corner point coordinates
      dimension zk(3,nmk,nnk)
!
      logical intsec
!
      dimension array(21,*)
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   array     /secprp/  output    sectional properties for cut  *
!     *                                                               *
!     *   cutdat    /secprp/  output    data about the cut within     *
!     *                                 a group                       *
!     *                                                               *
!     *   intsec              output    tells whether the cutting     *
!     *                                 plane actually cuts the net   *
!     *                                 .true. - intersection found   *
!     *                                 .false. - no intersection     *
!     *   igrps     /secprp/  output    group number (often used as an*
!     *                                 index)                        *
!     *                                                               *
!     *   netdat    /secprp/  output    data about the network's part *
!     *                                 in the group                  *
!     *                                                               *
!     *   netwrk    /secprp/  output    network number (an index)     *
!     *                                                               *
!     *   nmk                 input     number of rows                *
!     *                                                               *
!     *   nnk                 input     number of columns             *
!     *                                                               *
!     *   npa                 input     total number of panels in     *
!     *                                 previous networks             *
!     *                                                               *
!     *   npagp               input     total number of panels in     *
!     *                                 previous networks in this     *
!     *                                 group                         *
!     *                                                               *
!     *   numcut    /secprp/  output    number of cuts in the group   *
!     *                                                               *
!     *   numgrp    /secprp/  output    number of groups of data      *
!     *                                                               *
!     *   numnet    /secprp/  output    number of networks in a group *
!     *                                                               *
!     *   numscd              output    number of pressure surface    *
!     *                                 conditions                    *
!     *                                                               *
!     *   pdist               input     constant in equation of plane *
!     *                                 x*xcn+y*ycn+z*zcn - pdist = 0 *
!     *                                                               *
!     *   xcn                 input     x-component of cut normal     *
!     *                                                               *
!     *   ycn                 input     y-component of cut normal     *
!     *                                                               *
!     *   zcn                 input     z-component of cut normal     *
!     *                                                               *
!     *   zk                  input     array of network geom points  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     --------------------- labelled common blocks --------------------
!
!
!
!
!     panel defining quantities
!
!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
!
!      igrps  : group number (often used as an index)
!      numgrp : number of groups of sectional properties
!
!      actfx :
!      cutdat : data about the cut within  a group
!      isecpr : turns on diagnostic printout if '1.0'
!      ixyzop : option for use of x or y or z for chord calculation
!      netdat : data about the network's part in the group
!      numcut : number of cuts in the group
!      numnet : number of networks in a group
!      numscd : output number of pressure surface conditions
!      optcrd :  option for chord value
!      optmrp : option for moment reference point
!      xyzlim : x,y,z minimum and maximum values
!
!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
!
!
!     scratch common block used in sectional properties.
!
!      igrps  : group number (often used as an index)
!      netwrk : network number (an index)
!call secscr
      common/secscr/ netwrk, netdum, xrmin, xrmax, yrmin, yrmax, zrmin  &
     &             , zrmax, chrd, refrac, xr, yr, zr, xyzlim(150,3,2)
!end  secscr
!
!
!     --------------------- local array declarations ------------------
!
!
      dimension q(3, 4)
      dimension ptside(4,3), dif(4,3), ptint(3,2), qtint(3,2)
      dimension plan(4), dnorm(4), costh(4)
      dimension tau(4)
!
      logical edgflg(4)
!
      data tol / 1.0d-6 /
!
!     --------------------- executable code ---------------------------
!
      intsec = .false.
!
!     loop on panels
      do 1000 jcol = 1,nnk-1
        do 1000 irow = 1,nmk-1
!
!         get panel corner points (in global coordinates)
!         with the following indexing scheme
!           zk( 3, row  ,   col)
!           point q1( . ) is obtained from zk( . , row  , col  )
!                 q2( . )                    ( . , row  , col+1)
!                 q3( . )                    ( . , row+1, col+1)
!                 q4( . )                    ( . , row+1, col  )
!
          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
!
!         diagnostic printout ***
! ---     if( isecpr(igrps) .ne. 1) go to 105
! ---     write(nout,4000) (q(i,1), i=1,3)
!4000     format(1h ,4hqx= ,e15.6,5h qy= ,e15.6,5h qz= ,e15.6)
! ---     write(nout,4000) (q(i,2), i=1,3)
! ---     write(nout,4000) (q(i,3), i=1,3)
! ---     write(nout,4000) (q(i,4), i=1,3)
!105      continue
! ---     end diagnostic printout ***
!
!         fill common block /pandq/
          ip = irow + (nmk-1)*( jcol - 1 ) + npa
          ipgp = irow + (nmk-1)*( jcol - 1 ) + npagp
          call strns(ip,cp)
!                                  ACTIVATE PSDDQG CALL (m.e.)
          call psddqg
!
!         get normal vector for panel (in global coordinates)
!         the unit normal is available in /pandq/ as en(1,5)
!
!         check whether panel lies in plane of the cut
          cutnrm = en(1,5)*xcn + en(2,5)*ycn + en(3,5)*zcn
! ---     diagnostic printout ***
! ---     if( isecpr(igrps) .eq. 1)
! ---1    write(nout,2000) en(1,5),en(2,5),en(3,5),cutnrm
!2000     format(1x ,13hnorm,cutnrm: ,4e15.6)
! ---     end diagnostic printout ***
!
!         when panel parallel to cutting plane ignore the panel
          if( abs( abs( cutnrm) - 1.0d0 ) .le. tol ) go to 1000

!         loop on edges
!         if edge in cutting plane and not collapsed edge
!         then trace is edge; record; go to next panel
!
          do 200 i=1,3
            dif(1, i) = q(i, 2) - q(i, 1)
            dif(2, i) = q(i, 3) - q(i, 2)
            dif(3, i) = q(i, 4) - q(i, 3)
            dif(4, i) = q(i, 1) - q(i, 4)
  200     continue
!
          do 202 j=1,4
            plan(j)  = dif(j, 1)*xcn + dif(j, 2)*ycn + dif(j, 3)*zcn
            dnorm(j) = sqrt(dif(j, 1)**2 + dif(j, 2)**2 + dif(j, 3)**2)
            costh(j) = abs(plan(j) /  max (1.d-9,dnorm(j)))
  202     continue
!
!
! ---     diagnostic printout ***
! ---     if( isecpr(igrps) .eq. 1 )
! ---1    write(nout,5000) (plan(j),j=1,4)
!5000     format(1h ,9hplan(j): ,4e15.6)
! ---     end diagnostic printout ***
!
!
! ---     diagnostic printout ***
! ---     if( isecpr(igrps) .eq. 1 )
! ---1    write(nout,5500) (dnorm(j),j=1,4)
!5500     format(1h ,10hdnorm(j): ,4e15.6)
! ---     end diagnostic printout ***
!
          do 205 i=1,4
            j = i+1
            if ( j .eq. 5) j=1
            if( .not. ( costh(i) .le. tol ))go to 205
            if(.not.((abs(q(1,i)*xcn+q(2,i)*ycn+q(3,i)*zcn-pdist)       &
     &                .le. tol) .and.                                   &
     &               (abs(q(1,j)*xcn+q(2,j)*ycn+q(3,j)*zcn-pdist)       &
     &                .le. tol) ) )  go to 205
            if( dnorm(i) .le. tol)                go to 205
!
!     the following test is to eliminate double bookkeeping when a
!     panel is cut on its edge.  the test accepts panels which lie
!     'outboard' of the cutting plane but rejects all others.  the
!     test considers the edge in question as a vector.   the cross
!     product of this vector with the panel normal vector produces
!     a new vector. this is dotted with the cutting  plane  normal
!     and forms the basis for the test.
!
        tstarg =                                                        &
     &           ( dif(i,2)*en(3,5) - dif(i,3)*en(2,5) )*xcn            &
     &     +     ( dif(i,3)*en(1,5) - dif(i,1)*en(3,5) )*ycn            &
     &     +     ( dif(i,1)*en(2,5) - dif(i,2)*en(1,5) )*zcn
!
        if( tstarg .gt. 0.d0 ) go to 1000
!
!           project coordinates into mean plane
            call unipan( ar(1,5), cp(1,9), q(1, j), qtint(1,1) )
            call unipan( ar(1,5), cp(1,9), q(1, i), qtint(1,2) )
            xnetno = netwrk
!
! ---       diagnostic printout ***
! ---       aloop = 1.0
! ---       if( isecpr(igrps) .eq. 1 ) write (nout,3000) ip, xnetno, alo
!3000       format(1h ,4hip= ,i5,9h xnetno= ,f10.0,8h aloop= ,f4.0)
! ---       end diagnostic printout ***
!
            intsec = .true.
            array(1 ,ipgp) = xnetno
            array(2 ,ipgp) = q(1,j)
            array(3 ,ipgp) = q(2,j)
            array(4 ,ipgp) = q(3,j)
            array(5 ,ipgp) = q(1,i)
            array(6 ,ipgp) = q(2,i)
            array(7 ,ipgp) = q(3,i)
            array(8 ,ipgp) = qtint(1,1)
            array(9 ,ipgp) = qtint(2,1)
            array(10,ipgp) = qtint(1,2)
            array(11,ipgp) = qtint(2,2)
            array(12,ipgp) = en(1,5)
            array(13,ipgp) = en(2,5)
            array(14,ipgp) = en(3,5)
            go to 480
  205     continue
!
!         end loop on edges
!
!         initialize counter to zero and edgflg to 'false'
          iedgct = 0
          do 305 i=1,4
            edgflg(i) = .false.
  305     continue
!
!         loop on edges
!           compute intersection with edge
!           if valid intersection then increment counter and save edge i
          do 310 i=1,4
            if( dnorm(i) .le. tol ) go to 310
            if( costh(i) .le. tol ) go to 310
      tau(i) = ( pdist - ( q(1, i)*xcn + q(2, i) *ycn + q(3, i) *zcn))/ &
     &         (          plan(i)                                    )
      if( .not. ( tau(i) .le. 1.0d0+tol .and. tau(i) .ge. -tol ))       &
     &                           go to 310
            if( abs( tau(i) - 1.0d0 ) .le. tol ) tau(i) = 1.0d0
            if( abs( tau(i)       ) .le. tol ) tau(i) = 0.d0
            iedgct = iedgct + 1
            edgflg(i) = .true.
            ptside(i,1) = q(1, i) + tau(i) * dif(i, 1)
            ptside(i,2) = q(2, i) + tau(i) * dif(i, 2)
            ptside(i,3) = q(3, i) + tau(i) * dif(i, 3)
  310     continue
!
!         end loop on edges
!
          if( iedgct .eq. 0 ) go to 1000
!
!         "first point" is first edge with valid intersection
          do 350 i=1,4
            if( .not. (edgflg(i)) ) go to 350
            do 349 j=1,3
              ptint(j,1) = ptside(i, j)
  349       continue
            edgflg(i) = .false.
            go to 360
  350     continue
!
  360     continue
!
!         loop on edges to find second point of intersection
!           "second point" is next available intersection such that
!           (absolute("first point"-"second point") greater than toleran
!           in which case:
!             "exit  point"  is "second point"
!             "entry point"  is "first  point"
!             record
!             return
!
          do 460 i=1,4
            if( .not. (edgflg(i)) ) go to 450
            do 449 j=1,3
              ptint(j,2) = ptside(i, j)
  449       continue
            edgflg(i) = .false.
            pintnm = sqrt( (ptint(1,1)-ptint(1,2))**2 +                 &
     &                     (ptint(2,1)-ptint(2,2))**2 +                 &
     &                     (ptint(3,1)-ptint(3,2))**2   )
            if( pintnm .le. tol ) go to 450
!
!           project coordinates into mean plane
            call unipan( ar(1,5), cp(1,9), ptint(1, 1), qtint(1,1) )
            call unipan( ar(1,5), cp(1,9), ptint(1, 2), qtint(1,2) )
            xnetno = netwrk
!
!           diagnostic printout ***
! ---       aloop = 2.0
! ---       if( isecpr(igrps) .eq. 1 ) write (nout,3000) ip, xnetno, alo
! ---       end diagnostic printout ***
!
            intsec = .true.
            array(1 ,ipgp) = xnetno
            array(2 ,ipgp) = ptint(1,1)
            array(3 ,ipgp) = ptint(2,1)
            array(4 ,ipgp) = ptint(3,1)
            array(5 ,ipgp) = ptint(1,2)
            array(6 ,ipgp) = ptint(2,2)
            array(7 ,ipgp) = ptint(3,2)
            array(8 ,ipgp) = qtint(1,1)
            array(9 ,ipgp) = qtint(2,1)
            array(10,ipgp) = qtint(1,2)
            array(11,ipgp) = qtint(2,2)
            array(12,ipgp) = en(1,5)
            array(13,ipgp) = en(2,5)
            array(14,ipgp) = en(3,5)
            go to 480
  450     continue
!
  460   continue
!       end loop on edges
!
  480   continue
!
!       reorder entry and exit points if necessary
        if( array(1,ipgp) .eq. 0.d0  ) go to 1000
      if( ixyzop(igrps) .eq. 1 ) go to 490
      if( ixyzop(igrps) .eq. 2 ) go to 491
      if( ixyzop(igrps) .eq. 3 ) go to 492
  490 if( array(2,ipgp) .le. array(5,ipgp) ) go to 500
      go to 493
  491 if( array(3,ipgp) .le. array(6,ipgp) ) go to 500
      go to 493
  492 if( array(4,ipgp) .le. array(7,ipgp) ) go to 500
  493 continue
            t1          = array(2,ipgp)
            t2          = array(3,ipgp)
            t3          = array(4,ipgp)
            array(2,ipgp) = array(5,ipgp)
            array(3,ipgp) = array(6,ipgp)
            array(4,ipgp) = array(7,ipgp)
            array(5,ipgp) = t1
            array(6,ipgp) = t2
            array(7,ipgp) = t3
!
  500     continue
!
!         determine minimum point on cut
      if( ixyzop(igrps) .eq. 1 ) go to 510
      if( ixyzop(igrps) .eq. 2 ) go to 520
      if( ixyzop(igrps) .eq. 3 ) go to 530
  510 if( array(2,ipgp) .gt. xrmin ) go to 600
      go to 540
  520 if( array(3,ipgp) .gt. yrmin ) go to 600
      go to 540
  530 if( array(4,ipgp) .gt. zrmin ) go to 600
  540 continue
            xrmin = array(2,ipgp)
            yrmin = array(3,ipgp)
            zrmin = array(4,ipgp)
  600     continue
!
!         determine maximum point on cut
      if( ixyzop(igrps) .eq. 1 ) go to 610
      if( ixyzop(igrps) .eq. 2 ) go to 620
      if( ixyzop(igrps) .eq. 3 ) go to 630
  610 if( array(5,ipgp) .lt. xrmax ) go to 1000
      go to 640
  620 if( array(6,ipgp) .lt. yrmax ) go to 1000
      go to 640
  630 if( array(7,ipgp) .lt. zrmax ) go to 1000
  640 continue
            xrmax = array(5,ipgp)
            yrmax = array(6,ipgp)
            zrmax = array(7,ipgp)
!
 1000 continue
!     end loop on panels
!
      return
!
      END subroutine trace
! **deck tran
      subroutine tran
      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 translate the networks position
!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 inp3
      common /inp3/ ntsin,ntsout
!end  inp3
      read(ntsin,5000)ak1,ak2
      k1=ak1
      k2=ak2
      read(ntsin,5000)xp,yp,zp
!
      do 20 kk=k1,k2
      n=nn(kk)
      m=nm(kk)
      l=nza(kk)
      do 15 i=1,n
      do 10 j=1,m
      ix=j+l
      zm(1,ix)=zm(1,ix)+xp
      zm(2,ix)=zm(2,ix)+yp
      zm(3,ix)=zm(3,ix)+zp
   10 continue
      l=l+m
   15 continue
   20 continue
      return
! *** format statements ***
 5000 format (6e10.0)
      END subroutine tran
! **deck trans
      subroutine trans(a,at,m,n)
      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 transpose a matrix                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   at        argument  output    transposed matrix             *
!     *                                                               *
!     *   a         argument  input     matrix to transpose           *
!     *                                                               *
!     *   m         argument  input     number rows [a]               *
!     *                                                               *
!     *   n         argument  input     number columns [a]            *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension a(m,n),at(n,m)
      do 100 i=1,m
      do 50 j=1,n
      at(j,i)=a(i,j)
   50 continue
  100 continue
      return
      END subroutine trans
! **deck trfftz
      subroutine trfftz (nw,nwsymm,nwlst,s,misym,mjsym,  cl,cdi,eff     &
     &                  ,title,fsymm,sref,asprat,npn                    &
     &                  ,ylef,yrit, zlef,zrit, dylef,dyrit, dzlef,dzrit &
     &                  ,psi,dcd,    xil,xir                            &
     &                  )
      implicit double precision (a-h,o-z)
      character*(*) title
      dimension npn(nwsymm), nwlst(nwsymm), s(1:*)
      dimension ylef(nwsymm,200), zlef(nwsymm,200)                      &
     &        ,dylef(nwsymm,200),dzlef(nwsymm,200)
      dimension yrit(nwsymm,200), zrit(nwsymm,200)                      &
     &        ,dyrit(nwsymm,200),dzrit(nwsymm,200)
      dimension  psi(nwsymm,201), dcd(nwsymm,200)                       &
     &        ,  xil(nwsymm,200), xir(nwsymm,200)
!
!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 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 acase
      common /acase/ alpha(4), beta(4), fsvm(4), fsv(3,4)               &
     &             , iacase, nacase, fsvhat(3,4), pvdry(3,4)
!end  acase
!
      dimension tsc(5)
      dimension atrf(3,3), xtrf(3), xltrf(3), gdmu(3), gdmul(3)
      dimension fsvl(3)
      dimension dvsrc(3,3), dvdbl(3,9), amu(9)
!
      pi      =  4.d0*atan(1.d0)
      radf    =  pi/180.d0
      aarg    =  radf*alpha(iacase)
      barg    =  radf* beta(iacase)
      call rotate (atrf,aarg,barg)
      call outvcx ('fsv',3,fsv(1,iacase))
      write (6,'( '' aarg, barg:'',2f12.6)') aarg, barg
      call outmat ('atrf',3,3,3,atrf)
      call mxm (atrf,3,fsvhat(1,iacase),3,fsvl,1)
      call outvcx ('fsvhat-loc',3,fsvl)
!                                   loop over selected wake networks
!                                   with free trailing edges
      do 500 knw = 1,nw
         knet    =  nwlst(knw)
         mk      =  nm(knet)
         nk      =  nn(knet)
         npn(knw)=  nk-1
!                                   loop over trailing edge panels along
!                                   edge 3 in positive order
         do 400 jj = 1,(nk-1)
            jpan    =  nk - jj
            jpan    =  jj
            ijpan   =  jpan*(mk-1)
            ip      =  ijpan + npa(knet)
            call strns (ip,cp)
!                                   compute the 9 canonical doublet vals
            call dcopy (9,  0.d0,0,  amu,1)
            do 250 jmu = 1,ind
               lmu     =  1 + (jmu-1)*9
               js      =  iid(jmu)
               call daxpy (9,  s(js),  astd(lmu),1,  amu,1)
  250       continue
!                                   count the trailing edge panels
!                                   loop over left (ilr=2) and
!                                   right (ilr=1) points of wake T.E.
!                                   the reversal of the natural logical
!                                   order has been performed in order
!                                   to correct a sign error in the
!                                   original code/derivation
            do 300 ilr = 1,2
               is      =  ilr + 2
               tc      =  -1.d0
               sc      =  -1.d0
               if ( is.eq.4 ) sc = 1.d0
               alfa    =  - ddot(3, cp(1,is),1,  fsvhat(1,iacase),1)
               call vadd (cp(1,is),alfa,fsvhat(1,iacase),xtrf,3)
               call mxm  (atrf,3,xtrf,3,xltrf,1)
!                                   compute grad(mu) and transform.
               call sngcal (cp(1,is),s,tsc)
               call dcopy (3,  tsc(3),1,  gdmu,1)
!                                   computing grad(mu) using dvcalc
!                                   gives identical results at corners
!                                   because the quadratic variation of
!                                   mu along the local s and t traject-
!                                   ories completely determines the
!                                   gradient.  Also the H-P normal at
!                                   the panel corners agrees exactly
!                                   with the 8-subpanel normal there
!=====               call dvcalc (cp(1,is),sc,tc,  dvsrc,dvdbl)
!=====               call mxm (dvdbl,3,amu,9,gdmu,1)
!                                   apply the freestream rotation matrix
               call mxm  (atrf,3,gdmu,3,gdmul,1)
!                                   put coordinates and grad(mu) into
!                                   appropriate positions
               if ( ilr.eq.1 ) then
                  yrit(knw,jj) = xltrf(2)
                  zrit(knw,jj) = xltrf(3)
                  dyrit(knw,jj)= gdmul(2)
                  dzrit(knw,jj)= gdmul(3)
               else
                  ylef(knw,jj) = xltrf(2)
                  zlef(knw,jj) = xltrf(3)
                  dylef(knw,jj)= gdmul(2)
                  dzlef(knw,jj)= gdmul(3)
               endif
  300       continue
  400    continue
  500 continue
!                                   impose symmetry conditions
      nwx     =  nw
!                                   symmetry wrt y axis (x-z plane)
      if ( misym.eq.0 ) goto 610
      sgni     =  1.d0
      if ( misym.lt.0 ) sgni = -1.d0
      do 600 knw = 1,nwx
         knet    =  nwlst(knw)
         npan    =  npn(knw)
         mk      =  nm(knet)
         nk      =  nn(knet)
         knwp    =  knw + nwx
         nwlst(knwp) = knet
         npn  (knwp) = npn(knw)
         do 580 jj = 1,npan
            jjp     =  nk - jj
            yrit(knwp,jjp) =  -ylef(knw,jj)
            ylef(knwp,jjp) =  -yrit(knw,jj)
            zrit(knwp,jjp) =   zlef(knw,jj)
            zlef(knwp,jjp) =   zrit(knw,jj)
            dyrit(knwp,jjp)=  -sgni*dylef(knw,jj)
            dylef(knwp,jjp)=  -sgni*dyrit(knw,jj)
            dzrit(knwp,jjp)=   sgni*dzlef(knw,jj)
            dzlef(knwp,jjp)=   sgni*dzrit(knw,jj)
  580    continue
  600 continue
      nwx     =  2*nwx
  610 continue
!                                   symmetry wrt z axis (x-y plane)
      if ( mjsym.eq.0 ) goto 710
      sgj     =  1.d0
      if ( mjsym.lt.0 ) sgj = -1.d0
      do 700 knw = 1,nwx
         knet    =  nwlst(knw)
         npan    =  npn(knw)
         mk      =  nm(knet)
         nk      =  nn(knet)
         knwp    =  knw + nwx
         nwlst(knwp) = knet
         npn  (knwp) = npn(knw)
         do 680 jj = 1,npan
            jjp     =  nk - jj
            yrit(knwp,jjp) =   ylef(knw,jj)
            ylef(knwp,jjp) =   yrit(knw,jj)
            zrit(knwp,jjp) =  -zlef(knw,jj)
            zlef(knwp,jjp) =  -zrit(knw,jj)
            dyrit(knwp,jjp)=   sgj*dylef(knw,jj)
            dylef(knwp,jjp)=   sgj*dyrit(knw,jj)
            dzrit(knwp,jjp)=  -sgj*dzlef(knw,jj)
            dzlef(knwp,jjp)=  -sgj*dzrit(knw,jj)
  680    continue
  700 continue
      nwx     =  2*nwx
  710 continue
!
      gsymm   =  0.d0
!
      call indrag (nwx,title,gsymm,sref,asprat,npn,  cl,cdi,eff         &
     &            ,ylef,yrit, zlef,zrit, dylef,dyrit, dzlef,dzrit       &
     &            ,psi,dcd,    xil,xir                                  &
     &            )
!
      return
      END subroutine trfftz
! **deck triint
      subroutine triint (nnett,nm,nn,nza,zm,   intcnt)
      implicit double precision (a-h,o-z)
!
!     purpose: given networks of panels, subdivide the panels into
!              subpanel triangles and determine whether the triangles
!              intersect
!
!     inputs:  nnett  number of networks
!              nm     array containing number of rows in each network
!                     corner point grid
!              nn     array containing number of columns in each network
!                     corner point grid
!              nza    array containing running sum of nz
!              zm     coordinates of grid points of all networks in the
!                     global coordinate system
!
!     outputs: intcnt counts the number of intersections
!
!call netbnd
      common / netbnd / bndlim(150,3,2)
!end  netbnd
      dimension nm(150), nn(150)
      dimension nza(151), zm(3,4000)
      dimension p1(3), p2(3), p3(3)
      dimension q1(3), q2(3), q3(3)
      dimension ptarp(3,3,8), ptarq(3,3,8)
      dimension cp(4), cq(4)
      dimension avgp(3), avgq(3)
      dimension tranp1(3),tranp2(3),tranp3(3)
      dimension tranq1(3),tranq2(3),tranq3(3)
      dimension xhat(3),yhat(3)
      logical   intf, colinp, colinq, insidf
      logical   paralf
      data tol / 1.0d-6 /
!
      dis(pt1,pt2,pt3,cf1,cf2,cf3,cf4) =                                &
     &       pt1*cf1 + pt2*cf2 + pt3*cf3 - cf4
!
      intcnt = 0
!
!     write 'checking intersections'
      write(6,5000)
      write(6,5500)
!
!     determine the max and min limits for every network
      do 5, k= 1, nnett
        nzk = nza(k) + 1
        nmk = nm(k)
        nnk = nn(k)
        do 4, icoor= 1, 3
          call valnet( k, zm( 1, nzk), nmk, nnk, icoor)
    4   continue
    5 continue
!
!     cycle on kth network
      do 10 k   = 1,nnett
      nzk = nza(k) + 1
!
!     generate subpanels for ptarp for kth network
      nmk = nm(k)
      nnk = nn(k)
      do 20 ik  = 2, nmk
      do 20 jk  = 2, nnk
      call gensub(zm(1,nzk),nmk,nnk,ik,jk,   ptarp)
      call genpan(zm(1,nzk),nmk,nnk,ik,jk,   avgp,rp)
!
!     cycle on lth network
      do 30 l   = k,nnett
!     test whether intersection can ever occur between two networks.
!     it cannot occur if one network is outside the limit box of the oth
!
      if(   ( bndlim(l,1,1) .gt. bndlim(k,1,2) ) .or.                   &
     &      ( bndlim(l,1,2) .lt. bndlim(k,1,1) )      ) go to 30
      if(   ( bndlim(l,2,1) .gt. bndlim(k,2,2) ) .or.                   &
     &      ( bndlim(l,2,2) .lt. bndlim(k,2,1) )      ) go to 30
      if(   ( bndlim(l,3,1) .gt. bndlim(k,3,2) ) .or.                   &
     &      ( bndlim(l,3,2) .lt. bndlim(k,3,1) )      ) go to 30
      nzl = nza(l) + 1
!
!     generate subpanels for ptarq for lth network
      nml = nm(l)
      nnl = nn(l)
      do 40 il  = 2, nml
      do 40 jl  = 2, nnl
!
!     ignore identical panel of same network
      if ( ( k.eq.l) .and. ( ik .eq. il ) .and.                         &
     &                     ( jk .eq. jl ) ) go to 40
!
!     check whether the panels can ever intersect
!
      call genpan(zm(1,nzl),nml,nnl,il,jl,   avgq,rq)
      delpan = sqrt((avgp(1)-avgq(1))**2 +                              &
     &              (avgp(2)-avgq(2))**2 +                              &
     &              (avgp(3)-avgq(3))**2  )
      if( .not. (delpan .le. (rp+rq) )  ) go to 40
      call gensub(zm(1,nzl),nml,nnl,il,jl,   ptarq)
!
      do 1000 itrip = 1,8
!
      do 1050 ip = 1,3
      p1(ip) = ptarp(ip,1,itrip)
      p2(ip) = ptarp(ip,2,itrip)
      p3(ip) = ptarp(ip,3,itrip)
 1050 continue
!
!     find coefficients of planes
!
!
!     purpose: given three points, find the coefficients of a plane in
!              normal form.  a point  (x,y,z)  in the plane will then
!              satisfy       c(1)*x + c(2)*y + c(3)*z = c(4)
!
!     inputs:  p1,p2,p3 three points in space
!
!     outputs: c        coefficients of the plane through p1, p2, p3,
!                       where c(1), c(2), c(3) are direction cosines
!                       of the normal to the plane and
!                       c(4) is (+ve) distance from the origin to the
!                       plane in the direction of the normal
!              colinf   flag to indicate points are colinear or
!                       coincident
!
!     note *** the following calculations have been placed in-line
!              for speed reasons ***
!
!     initialize the colinear flag, colinf, to .false. where,
!       colinf = .true.    means points are colinear or coincident
!       colinf = .false.   means points not colinear or coincident
!
!     get coefficients of first plane
!
      colinp = .false.
!
!     initialize coefficients of plane
!
      x1   = p1(1)
      y1   = p1(2)
      z1   = p1(3)
!
      x2   = p2(1)
      y2   = p2(2)
      z2   = p2(3)
!
      x3   = p3(1)
      y3   = p3(2)
      z3   = p3(3)
!
      abar   = (   (y2-y1)*(z3-z2) - (z2-z1)*(y3-y2)   )
      bbar   = (   (z2-z1)*(x3-x2) - (x2-x1)*(z3-z2)   )
      cbar   = (   (x2-x1)*(y3-y2) - (y2-y1)*(x3-x2)   )
!
      absmag = sqrt (  abar*abar + bbar*bbar + cbar*cbar  )
!
!     test whether points are colinear or coincident
!
      if ( .not. ( absmag .le. tol ) ) go to 444
      colinp = .true.
      go to 445
!
!     compute the coefficients of the plane
!
  444 cp(1)   = abar/absmag
      cp(2)   = bbar/absmag
      cp(3)   = cbar/absmag
      cp(4)   = x1*cp(1) + y1*cp(2) + z1*cp(3)
!
!     if the sign of c(4) is negative, correct the
!     signs so that it is positive
!
      if ( .not.(  cp(4) .lt. 0.d0  ) )  go to 445
      cp(1)   = - cp(1)
      cp(2)   = - cp(2)
      cp(3)   = - cp(3)
      cp(4)   = - cp(4)
!
  445 continue
!
!
      do 1100 itriq = 1,8
!
      do 1150 ip = 1,3
      q1(ip) = ptarq(ip,1,itriq)
      q2(ip) = ptarq(ip,2,itriq)
      q3(ip) = ptarq(ip,3,itriq)
 1150 continue
!
!
!     get coefficients of second plane
!
      colinq = .false.
!
!     initialize coefficients of plane
!
      x1   = q1(1)
      y1   = q1(2)
      z1   = q1(3)
!
      x2   = q2(1)
      y2   = q2(2)
      z2   = q2(3)
!
      x3   = q3(1)
      y3   = q3(2)
      z3   = q3(3)
!
      abar   = (   (y2-y1)*(z3-z2) - (z2-z1)*(y3-y2)   )
      bbar   = (   (z2-z1)*(x3-x2) - (x2-x1)*(z3-z2)   )
      cbar   = (   (x2-x1)*(y3-y2) - (y2-y1)*(x3-x2)   )
!
      absmag = sqrt (  abar*abar + bbar*bbar + cbar*cbar  )
!
!     test whether points are colinear or coincident
!
      if ( .not. ( absmag .le. tol ) ) go to 447
      colinq = .true.
      go to 448
!
!     compute the coefficients of the plane
!
  447 cq(1)   = abar/absmag
      cq(2)   = bbar/absmag
      cq(3)   = cbar/absmag
      cq(4)   = x1*cq(1) + y1*cq(2) + z1*cq(3)
!
!     if the sign of c(4) is negative, correct the
!     signs so that it is positive
!
      if ( .not.(  cq(4) .lt. 0.d0  ) )  go to 448
      cq(1)   = - cq(1)
      cq(2)   = - cq(2)
      cq(3)   = - cq(3)
      cq(4)   = - cq(4)
!
  448 continue
!
      if ( .not. ( colinp .or. colinq ) )  go to 100
!
!     one or more of these points is colinear or coincident
!     generate a warning message
!
!     test if points are only a collapsed edge.
!     if they are, then ignore them.  otherwise
!     print out the coordinates
!
!
      tstp12 = (p1(1)-p2(1))**2 + (p1(2)-p2(2))**2 + (p1(3)-p2(3))**2
      tstp13 = (p1(1)-p3(1))**2 + (p1(2)-p3(2))**2 + (p1(3)-p3(3))**2
      tstp23 = (p2(1)-p3(1))**2 + (p2(2)-p3(2))**2 + (p2(3)-p3(3))**2
!
      testp =  min (tstp12,tstp13,tstp23)
!
      tstq12 = (q1(1)-q2(1))**2 + (q1(2)-q2(2))**2 + (q1(3)-q2(3))**2
      tstq13 = (q1(1)-q3(1))**2 + (q1(2)-q3(2))**2 + (q1(3)-q3(3))**2
      tstq23 = (q2(1)-q3(1))**2 + (q2(2)-q3(2))**2 + (q2(3)-q3(3))**2
!
      testq =  min (tstq12,tstq13,tstq23)
!
!     note that the largest acceptable difference is .001, absolute
!                                                          --------
      if( (abs(testp) .le. tol)  .or.                                   &
     &    (abs(testq) .le. tol)  )  go to 1100
!
!
!     write (6,...) point data, 'edge may be collapsed
!                                or points colinear'
      write(6,6000)
 6000 format(' warning--edge may be collapsed'/                         &
     &       '          or points colinear')
      go to 799
!
!
  100 continue
!
!     are planes parallel?
      paralf = .false.
!
!     test1 = cp(2)*cq(3) - cp(3)*cq(2)
!     test2 = cp(3)*cq(1) - cp(1)*cq(3)
!     test3 = cp(1)*cq(2) - cp(2)*cq(1)
!
!     if ( (abs(test1) .le. tol) .and.
!    2     (abs(test2) .le. tol) .and.
!    3     (abs(test3) .le. tol)      ) paralf = .true.
!
      test1 = cp(1)*cq(1) + cp(2)*cq(2) + cp(3)*cq(3)
      test1 = abs(test1) - 1.d0
      if (abs(test1) .le. tol)  paralf = .true.
!
!--------------------------------------------------------------
!     check for intersection between triangle p in kth network
!     and triangle q in lth network
!
      if( paralf ) go to 500
      insidf = .false.
      intf   = .false.
!
      call abvblw(q1,q2,q3,cp,   intf)
      if( intf) call abvblw(p1,p2,p3,cq,   intf)
      if( .not. intf ) go to 234
!
      call fndpts(p1,p2,p3,cp,q1,q2,q3,cq,   insidf)
!
  234 continue
!
      go to 699
!
  500 continue
      d = dis(p1(1),p1(2),p1(3),cq(1),cq(2),cq(3),cq(4))
      if( .not. ( abs(d) .le. tol ) ) go to 1100
      call samep(p1,p2,p3,cp,q1,q2,q3,cq,   insidf)
  699 if ( .not. ( insidf ) ) go to 1100
      intcnt = intcnt + 1
!     write (6,...) (network nos, panel nos, subpanel nos)
      write(6,7000)intcnt
      if(paralf) write(6,7100)
 7100 format(1x,23htriangles in same plane)
  799 continue
!     compute unit vector connecting p2 and p1, called xhat
      xhatdn = sqrt ( (p2(1)-p1(1))**2                                  &
     &              + (p2(2)-p1(2))**2                                  &
     &              + (p2(3)-p1(3))**2  )
      xhat(1)= (p2(1)-p1(1))/xhatdn
      xhat(2)= (p2(2)-p1(2))/xhatdn
      xhat(3)= (p2(3)-p1(3))/xhatdn
!
!     compute unit vector formed as : yhat =  n x xhat
      yhat(1) = cp(2)*xhat(3) - cp(3)*xhat(2)
      yhat(2) = cp(3)*xhat(1) - cp(1)*xhat(3)
      yhat(3) = cp(1)*xhat(2) - cp(2)*xhat(1)
!
!     compute points of triangle p
      tranp1(1) = 0.d0
      tranp1(2) = 0.d0
      tranp1(3) = 0.d0
!
      tranp2(1) = (p2(1)-p1(1))*xhat(1)                                 &
     &          + (p2(2)-p1(2))*xhat(2)                                 &
     &          + (p2(3)-p1(3))*xhat(3)
      tranp2(2) = 0.d0
      tranp2(3) = 0.d0
!
      tranp3(1) = (p3(1)-p1(1))*xhat(1)                                 &
     &          + (p3(2)-p1(2))*xhat(2)                                 &
     &          + (p3(3)-p1(3))*xhat(3)
      tranp3(2) = (p3(1)-p1(1))*yhat(1)                                 &
     &          + (p3(2)-p1(2))*yhat(2)                                 &
     &          + (p3(3)-p1(3))*yhat(3)
      tranp3(3) = 0.d0
!
!     compute points of triangle q
      tranq1(1) = (q1(1)-p1(1))*xhat(1)                                 &
     &          + (q1(2)-p1(2))*xhat(2)                                 &
     &          + (q1(3)-p1(3))*xhat(3)
      tranq1(2) = (q1(1)-p1(1))*yhat(1)                                 &
     &          + (q1(2)-p1(2))*yhat(2)                                 &
     &          + (q1(3)-p1(3))*yhat(3)
      tranq1(3) = (q1(1)-p1(1))*cp(1)                                   &
     &          + (q1(2)-p1(2))*cp(2)                                   &
     &          + (q1(3)-p1(3))*cp(3)
!
      tranq2(1) = (q2(1)-p1(1))*xhat(1)                                 &
     &          + (q2(2)-p1(2))*xhat(2)                                 &
     &          + (q2(3)-p1(3))*xhat(3)
      tranq2(2) = (q2(1)-p1(1))*yhat(1)                                 &
     &          + (q2(2)-p1(2))*yhat(2)                                 &
     &          + (q2(3)-p1(3))*yhat(3)
      tranq2(3) = (q2(1)-p1(1))*cp(1)                                   &
     &          + (q2(2)-p1(2))*cp(2)                                   &
     &          + (q2(3)-p1(3))*cp(3)
!
      tranq3(1) = (q3(1)-p1(1))*xhat(1)                                 &
     &          + (q3(2)-p1(2))*xhat(2)                                 &
     &          + (q3(3)-p1(3))*xhat(3)
      tranq3(2) = (q3(1)-p1(1))*yhat(1)                                 &
     &          + (q3(2)-p1(2))*yhat(2)                                 &
     &          + (q3(3)-p1(3))*yhat(3)
      tranq3(3) = (q3(1)-p1(1))*cp(1)                                   &
     &          + (q3(2)-p1(2))*cp(2)                                   &
     &          + (q3(3)-p1(3))*cp(3)
!
      irowk = ik - 1
      icolk = jk - 1
      irowl = il - 1
      icoll = jl - 1
!
      write(6,5400) k, irowk, icolk, itrip,                             &
     &              l, irowl, icoll, itriq
!
      write(6,5500)p1(1),p2(1),p3(1),tranp1(1),tranp2(1),tranp3(1),     &
     &             q1(1),q2(1),q3(1),tranq1(1),tranq2(1),tranq3(1),     &
     &             p1(2),p2(2),p3(2),tranp1(2),tranp2(2),tranp3(2),     &
     &             q1(2),q2(2),q3(2),tranq1(2),tranq2(2),tranq3(2),     &
     &             p1(3),p2(3),p3(3),tranp1(3),tranp2(3),tranp3(3),     &
     &             q1(3),q2(3),q3(3),tranq1(3),tranq2(3),tranq3(3)
!
!
!--------------------------------------------------------------
!
 1100 continue
!
 1000 continue
!
   40 continue
!
   30 continue
!     end of cycle on lth network
!
   20 continue
!
   10 continue
!     end of cycle on kth network
!
      if ( .not. ( intcnt .eq. 0 ) ) go to 999
!     write (6,...) 'no intersections found'
      write (6,8000)
 8000 format(1x,/,1x,22hno intersections found,/)
!
!     formats
!
 5000 format(' checking intersections of triangular sub-panels',//,     &
     &       '   notes- *triangles are shown in global and local ',     &
     &                  'coordinates',/,                                &
     &       '          *the reference triangle appears above the ',    &
     &                  'second one',/,                                 &
     &       '          *the reference triangle is the basis of ',      &
     &                  'the local coordinate system',//             )
 5400 format(' network-#',i5,5x,'row-#',i5,5x,'column-#',i5,5x,         &
     &                                           'triangle-#',i5,/,     &
     &       ' network-#',i5,5x,'row-#',i5,5x,'column-#',i5,5x,         &
     &                                           'triangle-#',i5,//)
 5500 format(' global',8x,'point-1',11x,'point-2',11x,'point-3',        &
     &       9x,'local ',8x,'point-1',11x,'point-2',11x,'point-3',/,    &
     &       ' coordinates',55x,'coordinates',/,                        &
     &       3x,'x',3(1x,f17.11),11x,'x',3(1x,f17.11),/,                &
     &       4x,3(1x,f17.11),12x,3(1x,f17.11),//,                       &
     &       3x,'y',3(1x,f17.11),11x,'y',3(1x,f17.11),/,                &
     &       4x,3(1x,f17.11),12x,3(1x,f17.11),//,                       &
     &       3x,'z',3(1x,f17.11),11x,'z',3(1x,f17.11),/,                &
     &       4x,3(1x,f17.11),12x,3(1x,f17.11),///                   )
 7000 format(1x,18hintersection no = ,i10)
 9000 format(1x,/,1x,28hend of intersection checking,/)
!
  999 continue
      write(6,9000)
      return
      END subroutine triint
! **deck trns
      subroutine trns(q,s,nq,ns,nr,nt,ni,i)
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to retrieve a block of data previously stored by itrns       *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  if the record containing the data to be retrieved is         *
!     *  presently in core, it is fetched from the buffer.  if the    *
!     *  buffer does not contain that block, the record containing    *
!     *  that block is determined and read via random io.             *
!     *  the data is then retrieved from the record.  if current      *
!     *  record in buffer has not been written by itrns it is written *
!     *  here before new record is retrieved.                         *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   i         argument  input     sequency number of data block *
!     *                                 to retrieve                   *
!     *                                                               *
!     *   k         -local-   - - - -   record number data block is in*
!     *                                                               *
!     *   l         -local-   - - - -   sequence of data block        *
!     *                                 within record                 *
!     *                                                               *
!     *   nq        argument  input     length of data block to       *
!     *                                 retrieve                      *
!     *                                                               *
!     *   ni        argument  input     index array for records on nt *
!     *                                                               *
!     *   nr        argument  in/output record number currently in    *
!     *                                 buffer (= - for modified      *
!     *                                 records and = + for unmodified*
!     *                                 records).                     *
!     *                                                               *
!     *   ns        argument  input     number of data blocks         *
!     *                                 that will fit in the buffer   *
!     *                                 (buffer is ns x nq words long)*
!     *                                                               *
!     *   nt        argument  input     i/o unit data is stored on    *
!     *                                                               *
!     *   q         argument  output    array to store the retrieved  *
!     *                                 data in                       *
!     *                                                               *
!     *   s         argument  in/out    array to use for buffer       *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      logical gh1,gh2,gh3,gh4
      integer rewrit
      integer q(nq), s(nq,ns), ni(1:*)
!c
!     *  calculate record number and data block number within record  *
!
      k = (i-1)/ns+1
      l = i-ns*(k-1)
      key = iabs(nr)
      gh1 = k.eq.key.or.key.eq.0
!c
!     *  if record is already in buffer then do not read record       *
!
      if(gh1) go to 100
      gh2 = nr.gt.0
!c
!     *  if record currently in buffer has not been modified then     *
!     *  do not re-write record                                       *
!
      if(gh2) go to 50
      gh3 = ni(key).ne.0
      if(gh3) go to 25
      rewrit = 0
      go to 30
   25 continue
      rewrit = 1
   30 continue
      length = nq*ns
      length=64*((length+63)/64)
!c
!     *  write record currently in buffer if it has been created or   *
!     *  modified by itrns but not written at that time               *
!
      call writms(nt,s(1,1),length,key,rewrit,0)
      if ( ni(key).eq.0  ) ni(key) = 1
   50 continue
      gh4 = ni(k).ne.0
      if(.not.gh4) go to 80
      length = nq*ns
      length=64*((length+63)/64)
      nr = k
!c
!     *  read appropriate record if not already in core               *
!
      call readms(nt,s(1,1),length,k)
      go to 100
   80 continue
      write(6,6000) k,i,ns
      stop 707
  100 continue
!c
!     *  transfer data block from buffer                              *
!
      call icopy (nq,  s(1,l),1,  q,1)
 1000 return
 6000 format (1h ,5hblock,i3,14hdoes not exist,/                        &
     & 1h ,25hsequence number of block ,i3,/                            &
     & 1h ,21hnumber of data block ,i3)
      END subroutine trns
! **deck trwake
      subroutine trwake (kn,xwake,twake)
      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 network of mesh points for the trailing
!              wake
!
!     input    calling sequence
!              kn - network no.
!              xwake - x coordinate of corner point at downstream of the
!                      trailing wake
!              common block
!              /index/ - nm,nn,nza
!              /mspnts/ - zm
!
!     output   common block
!              /mspnts/ - zm
!
!     discussion  the routine first identifies the side of the network
!              of which the trailing wake network is attached to.  using
!              the edge mesh points on this side and the given parameter
!              xwake, it generates network mesh points for the trailing
!              wake.
!******
!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
!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
      dimension gen(3)
!                                  specify wake generator direction
      call dcopy (3,  0.d0,0,  gen,1)
      gen(1)  =  1.d0
      aarg=alpc*pi2/360.d0
      barg=-betc*pi2/360.d0
      compd(1)=cos(aarg)*cos(barg)
      compd(2)=cos(aarg)*sin(barg)
      compd(3)=sin(aarg)
      if ( twake.eq.1.d0 ) call dcopy (3,  compd,1,  gen,1)
!
!                             obtain accumulated sum of mesh points of
!                             previous networks for networks kn and inat
!                             , also row and column numbers of network
!                             inat of which the trailing wake network kn
!                             is to be attached
      kzm = nza(kn)
      izm = nza(inat)
      nrow = nm(inat)
      ncol = nn(inat)
      if(insd.ne.1.and.insd.ne.3)  go to 20
!
!                             when the side of the network of which the
!                             trailing wake is attached to is 1 or 3
      nte = ncol
      i = 1
      if(insd.eq.3)  i = nrow
      izmi = izm+i-nrow
      do 10 j=1,nte
      jmn = kzm+(2*j-1)
      ji = izmi+j*nrow
      call dcopy (3,zm(1,ji),1,zm(1,jmn),1)
          alf     =  (xwake-zm(1,ji))/gen(1)
          call vadd (zm(1,ji),alf,gen,zm(1,jmn+1),3)
   10 continue
      go to 40
!
!                             when the side of the network of which the
!                             trailing wake is attached to is 2 or 4
   20 nte = nrow
      i = ncol
      if(insd.eq.4)  i = 1
      izmi = izm+(i-1)*nrow
      do 30 j=1,nte
      jmn = kzm+(2*j-1)
      ji = izmi+j
      call dcopy (3,zm(1,ji),1,zm(1,jmn),1)
          alf     =  (xwake-zm(1,ji))/gen(1)
          call vadd (zm(1,ji),alf,gen,zm(1,jmn+1),3)
   30 continue
   40 continue
!
!                             set row and column numbers for the trail-
!                             ing wake network
      nm(kn) = 2
      nn(kn) = nte
      nza(kn+1) = nza(kn) + nm(kn)*nn(kn)
      return
      END subroutine trwake
! **deck tsing
      subroutine tsing (keyloc,maps,locs)
      implicit double precision (a-h,o-z)
! --- dimension keyloc(mxsngt), maps(mxsngt), locs(4*mxsngt)
      dimension keyloc(1:*),    maps(1:*),    locs(1:*)
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to generate panel singularity distribution defining          *
!     *  quantities for all panels                                    *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the routine calls sing or daspl for each network to calculate*
!     *  panel singularity distribution defining quantities.  daspl   *
!     *  is used only for network types employing the continuous      *
!     *  doublet analysis spline.                                     *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   isingp    /prnt/    input     singularity spline diagnostic *
!     *                                 print flag                    *
!     *                                                               *
!     *   k         -local-   - - - -   index of loop over networks   *
!     *                                                               *
!     *   nm        /index/   inputl-   array containing number of    *
!     *                                 rows in each network corner   *
!     *                                 corner point grid             *
!     *                                                               *
!     *   nnett     /index/   input     total number of networks      *
!     *                                                               *
!     *   nn        /index/   input     array containing number of    *
!     *                                 columns in each network       *
!     *                                 corner point grid             *
!     *                                                               *
!     *   npa       /index/   input     array containing cumulative   *
!     *                                 sum of array np               *
!     *                                                               *
!     *   nsd       /index/   output    number of  doublet singularity*
!     *                                 parameters in each network    *
!     *                                                               *
!     *   nsda      /index/   input     array containing cumulative   *
!     *                                 sum of singularity parameters *
!     *                                 in previous networks and in   *
!     *                                 source spline of current      *
!     *                                 network                       *
!     *                                                               *
!     *   nsngt     /index/   output    number of total singularity   *
!     *                                 parameters                    *
!     *                                                               *
!     *   nss       /index/   output    number of source singularity  *
!     *                                 parameters in each network    *
!     *                                                               *
!     *   nssa      /index/   output    array containing cumulative   *
!     *                                 sum of singularity parameters *
!     *                                 in previous networks          *
!     *                                                               *
!     *   ntd       /index/   input     array containing network      *
!     *                                 doublet types                 *
!     *                                                               *
!     *   nts       /index/   input     array containing network      *
!     *                                 source types                  *
!     *                                                               *
!     *   nza       /index/   input     array containing cumulative   *
!     *                                 sum of array nz               *
!     *                                                               *
!     *   zm        /mspnts/  input     array containing panel corner *
!     *                                 points (x,y,z 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 skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!call lndblx
!                                                           /lndblx/
      common /lndblx/ genwak(3,mxnett), slndbl(mxnett)                  &
     &              , nlndbl, iwkfil, ilndbl(mxnett), idsvfw(mxnett)
!end  lndblx
      dimension nsa(151),nda(151)
!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 mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!                                 initialize scratch common
      call setcor ('tsing')
!                                 allocate for generic spline routine
      call igtcor ('ia',  llia,    mxsgpn)
      call getcor ('za',  llza,  3*mxsgpn)
!                                 allocate for daspl
      kblc    =  48
      nblc    =  275
      call getcor ('blcp',llblcp,  kblc*4)
      call getcor ('blc', llblc,   kblc*nblc)
      call igtcor ('iblc',lliblc,       nblc)
!c
!     *  write header if singularity spline diagnostic data is        *
!     *  requested (isingp=1)                                         *
!
      nlndbl  =  0
      if(isingp.eq.1) write(6,1000)
 1000 format(1h1,////50x,35hsingularity distrubution definition,////)
      nssa(1)=0
      nsa(1)=0
      if(isingp.eq.1) write(6,2000)
 2000 format(//50x,29hpanel distribution quantities,//)
!c
!     *  loop ranges over networks to calculate panel singularity     *
!     *  distribution defining quantities                             *
!
      do 200 k=1,nnett
      ns=0
      nss=0
      nd=0
      nsd=0
      nzmpa1=nza(k)+1
!c
!     *  set source type                                              *
!
      ntk=nts(k)
!c
!     *  use standard least square fit for source spline              *
!
      if(nts(k).gt.0)                                                   &
     &    call sing (k,ntk,nm(k),nn(k),nsa(k),nssa(k),ns,nss            &
     &              ,maps,locs,npa(k),zm(1,nzmpa1),w(llia),w(llza) )
      nsda(k)=nssa(k)+nss
      nda(k)=nsa(k)+ns
!c
!     *  set doublet type. use minus sign to indicate composite       *
!     *  singularity distribution                                     *
!
      ntk=ntd(k)
      if(nts(k).gt.0) ntk=-ntd(k)
!c
!     *  use continuous quadratic fit for doublet/analysis and wake   *
!     *  networks                                                     *
!
      if((ntd(k).eq.12).or.(ntd(k).eq.18).or.(ntd(k).eq.20))            &
     &    call daspl (k,ntk,nm(k),nn(k),nda(k),nsda(k),nd,nsd           &
     &               ,maps,locs,npa(k),zm(1,nzmpa1)                     &
     &               ,w(llia),w(llza)                                   &
     &               ,kblc,nblc,w(llblcp),w(llblc),w(lliblc))
      if ( ntd(k).eq.6 )                                                &
     &    call ddwspl (k,ntk,nm(k),nn(k),nda(k),nsda(k),nd,nsd          &
     &                ,maps,locs,npa(k),zm(1,nzmpa1),w(llia),w(llza) )
!c
!     *  use standard least square fit for doublet spline             *
!
      if((ntd(k).gt.0).and.(ntd(k).ne.12).and.(ntd(k).ne.18).and.       &
     &              (ntd(k).ne.20) .and. (ntd(k).ne.6) )                &
     &    call sing (k,ntk,nm(k),nn(k),nda(k),nsda(k),nd,nsd            &
     &              ,maps,locs,npa(k),zm(1,nzmpa1),w(llia),w(llza) )
      nssa(k+1)=nsda(k)+nsd
      nsa(k+1)=nda(k)+nd
  200 continue
      nsngt=nsa(nnett+1)
      nsngn   =  nssa(nnett+1)
      if ( nsngn.gt.mxsngt )                                            &
     &   call labort (nsngn,mxsngt,'total singularity count')
      call ixtrns (26,maps,nsngn)
      call ixtrns (27,locs,4*nsngn)
      call ishel2 (nsngn,locs,keyloc)
      call ixtrns (28,locs,4*nsngn)
      call ixtrns (29,keyloc,nsngn)
!
      call frecor ('tsing')
      return
      END subroutine tsing
! **deck twopts
      subroutine twopts (p1,p2,p3,c,qfirst,qsecnd,   insidf)
      implicit double precision (a-h,o-z)
!
!     purpose: compute intersections for two points in plane of p
!
!     inputs:  p1,p2,p3 points of triangle
!              c  cofficients of plane formed by p1,p2,p3
!              qfirst, qsecnd, two points in plane of p
!
!     output:  insidf flag to indicate whether intersection does occur
!
      dimension p1(3), p2(3), p3(3)
      dimension p(3,3)
      dimension qfirst(3), qsecnd(3)
      dimension c(4)
      dimension cross(3,3), up(3,3), ul(3,3)
      dimension dp(3,3), dq(3)
      logical insidf
      data tol / 1.0d-6 /
!
!     initialize flag, insidf, to .false. where,
!       insidf = .true.    means points do intersect triangle
!       insidf = .false.   means points do not intersect triangle
!     if the line segments intersect, then insidf is set to .true.
!
      insidf = .false.
!
      do 25 ip=1,3
      dp(1,ip) = p2(ip) - p1(ip)
      dp(2,ip) = p3(ip) - p2(ip)
      dp(3,ip) = p1(ip) - p3(ip)
      dq(ip)   = qsecnd(ip) - qfirst(ip)
      p(1,ip) = p1(ip)
      p(2,ip) = p2(ip)
      p(3,ip) = p3(ip)
   25 continue
!
      do 888 j=1,3
!
!     is dp(j) parallel to dq? it is if the cross product
!     is zero.
!
      cross(j,1) = dp(j,2) * dq(3) - dp(j,3) * dq(2)
      cross(j,2) = dp(j,3) * dq(1) - dp(j,1) * dq(3)
      cross(j,3) = dp(j,1) * dq(2) - dp(j,2) * dq(1)
!
      if (( abs(cross(j,1)) .le. tol ) .and.                            &
     &    ( abs(cross(j,2)) .le. tol ) .and.                            &
     &    ( abs(cross(j,3)) .le. tol )  )   go to 888
!
      upmag = sqrt(dp(j,1)**2 + dp(j,2)**2 + dp(j,3)**2)
!
!     compute unit vector along p
!
      do 50 ip=1,3
      if( abs(upmag) .le. tol ) upmag = tol
      up(j,ip) = dp(j,ip)/upmag
   50 continue
!
!     construct unit vector perpendicular to p
!
      ul(j,1) = c(2) * up(j,3) - c(3) * up(j,2)
      ul(j,2) = c(3) * up(j,1) - c(1) * up(j,3)
      ul(j,3) = c(1) * up(j,2) - c(2) * up(j,1)
!
!     compute dot products
!
      as=0.d0
      bs=0.d0
      cs=0.d0
!
      at=0.d0
      bt=0.d0
      ct=0.d0
      dt=0.d0
!
      do 75 ip=1,3
      as=as+ul(j,ip)*p(j,ip)
      bs=bs+ul(j,ip)*qfirst(ip)
      cs=cs+ul(j,ip)*dq(ip)
!
      at=at+up(j,ip)*p(j,ip)
      bt=bt+up(j,ip)*qfirst(ip)
      ct=ct+up(j,ip)*dq(ip)
      dt=dt+up(j,ip)*dp(j,ip)
   75 continue
!
!     compute intersection points, tau and gam
!
      if( abs(cs) .le. tol ) cs = tol
      tau = (as-bs)/cs
!
      if( abs(dt) .le. tol ) dt = tol
      gam = - (at-bt-ct*tau)/dt
!
      if(.not.(((tau.gt.tol) .and. (tau.lt.(1.d0-tol))) .and.           &
     &    ((gam.gt.tol) .and. (gam.lt.(1.d0-tol))))) go to 888
      insidf = .true.
      go to 999
!
  888 continue
  999 return
      END subroutine twopts
! **deck uabend
      subroutine uabend
      implicit double precision (a-h,o-z)
      data  ifail /10/
!                                  on cray, force traceback via call to
      CALL AbortPanair('uabend')
!                                  user error. force traceback via acgoe
      go to (10,20), ifail
!                                  give the compiler some code to
!                                  fool the optimizer
   10 continue
      ifail   =  ifail+1
      go to 30
   20 continue
      ifail   = ifail+2
   30 continue
      return
      END subroutine uabend
! **deck ukysr2
      subroutine ukysr2 (n,iar,key)
      implicit double precision (a-h,o-z)
!c
!     ukysr2 is a variation on routine ukysrt.
!     the 4 integers per word logic has been removed due to the
!     46 bit integers on the cray-2 at nasa-ames.
!
!***created  on 78.060    w.o. no.   0   version        fee.01
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   ukysrt uses a permutation vector key to rearrange the       *
!     *   elements of an array iar so that                            *
!     *             iar(key(i))(new) = iar(i)(old)                    *
!     *   ukysrt may be used to restore an array iar to its original  *
!     *   ordering if key(i) is a key array that has been generated   *
!     *   by the sort process.                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!+
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   ukysrt rearranges the elements of iar by threading its way  *
!     *   through the cycles of the permutation vector key.  cycles   *
!     *   in key that have already been processed are flagged by set- *
!     *   ting the cycle*s elements negative                          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   i         local     - - - -   index of the location in iar  *
!     *                                 currently being processed     *
!     *                                                               *
!     *   iar       argument  in/out    the array to be rearranged    *
!     *                                                               *
!     *   if        local     - - - -   index of the initial element  *
!     *                                 of the cycle                  *
!     *                                                               *
!     *   ik        local     - - - -   index of the next location in *
!     *                                 the cycle.  iar(ik) (ik=key(i)*
!     *                                 is to be stuffed with it (qv) *
!     *                                                               *
!     *   it        local     - - - -   save region for iar(i)(old)   *
!     *                                                               *
!     *   key       argument  input     a permutation vector.  key(i) *
!     *                                 contains the address to which *
!     *                                 the element iar(i) is to be   *
!     *                                 moved                         *
!     *                                                               *
!     *   n         argument  input     number of elements in iar     *
!     *                                 and key                       *
!     *                                                               *
!     *                                                               *
!
!
      integer iar(1), key(1), it(4), is(4), then
!c
!     find an unprocessed cycle
!
      if ( n.le.0 ) return
      if      =  1
   10 continue
      do 20 ii = if,n
          i       =  ii
          if ( key(i) ) 20,20,40
   20 continue
!c
!     all cycles are processed.
!     restore the signs in the key array and return
!
      do 30 i = 1,n
          key(i)  =  -key(i)
   30 continue
      go to 70
!c
!     beginning at location  if   update this cycle of the
!     permutation until   key(key(...(key(if))...)) = if
!
   40 continue
      if      =  i
      do 45 then = 1,4
   45 it(then)   =  iar(4*i-4+then)
   50 continue
      ik      =  key(i)
      key(i)  =  -ik
      if ( ik.eq.if ) go to 60
      do 55 then = 1,4
      is(then)         =  iar(4*ik-4+then)
      iar(4*ik-4+then) =  it(then)
   55 it(then)         =  is(then)
      i       =  ik
      go to 50
   60 continue
!c
!     set first element of the cycle equal to the original last
!     element and go on to next cycle
!
      do 65 then=1,4
   65 iar(4*if-4+then) = it(then)
      go to 10
   70 return
      END subroutine ukysr2
! **deck ukysrd
      subroutine ukysrd (n,a,key)
      implicit double precision (a-h,o-z)
!
!         perform the inverse of the keysrt operation
!
      integer key(n)
      dimension a(n)
!
!     *   find an unprocessed cycle                                   *
!
      if ( n.le.0 ) return
      if      =  1
   10 continue
      do 20 ii = if,n
          i       =  ii
          if ( key(i) ) 20,20,40
   20 continue
!     *   all cycles are processed                                    *
!     *   restore the signs in the key array and return               *
      do 30 i = 1,n
          key(i)  =  -key(i)
   30 continue
      go to 70
!     *   beginning at location  if   update this cycle of the        *
!     *   permutation until   key(key(...(key(if))...)) = if          *
   40 continue
      if      =  i
      at      =  a(i)
   50 continue
      ik      =  key(i)
      key(i)  =  -ik
      if ( ik.eq.if ) go to 60
      as      =  a(ik)
      a(ik)   =  at
      at      =  as
      i       =  ik
      go to 50
   60 continue
!     *   set first element of the cycle equal to the original last   *
!     *   element and go on to next cycle                             *
      a(if) =  at
      go to 10
   70 return
      END subroutine ukysrd
! **deck ukysrt
      subroutine ukysrt (n,iar,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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *   ukysrt uses a permutation vector key to rearrange the       *
!     *   elements of an array iar so that                            *
!     *             iar(key(i))(new) = iar(i)(old)                    *
!     *   ukysrt may be used to restore an array iar to its original  *
!     *   ordering if key(i) is a key array that has been generated   *
!     *   by the sort process.                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!+
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *   ukysrt rearranges the elements of iar by threading its way  *
!     *   through the cycles of the permutation vector key.  cycles   *
!     *   in key that have already been processed are flagged by set- *
!     *   ting the cycle*s elements negative                          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   i         local     - - - -   index of the location in iar  *
!     *                                 currently being processed     *
!     *                                                               *
!     *   iar       argument  in/out    the array to be rearranged    *
!     *                                                               *
!     *   if        local     - - - -   index of the initial element  *
!     *                                 of the cycle                  *
!     *                                                               *
!     *   ik        local     - - - -   index of the next location in *
!     *                                 the cycle.  iar(ik) (ik=key(i)*
!     *                                 is to be stuffed with it (qv) *
!     *                                                               *
!     *   it        local     - - - -   save region for iar(i)(old)   *
!     *                                                               *
!     *   key       argument  input     a permutation vector.  key(i) *
!     *                                 contains the address to which *
!     *                                 the element iar(i) is to be   *
!     *                                 moved                         *
!     *                                                               *
!     *   n         argument  input     number of elements in iar     *
!     *                                 and key                       *
!     *                                                               *
!     *                                                               *
!
!
      integer iar(1), key(1)
!c    *                                                               *
!     *   find an unprocessed cycle                                   *
!     *                                                               *
      if ( n.le.0 ) return
      if      =  1
   10 continue
      do 20 ii = if,n
          i       =  ii
          if ( key(i) ) 20,20,40
   20 continue
!c    *                                                               *
!     *   all cycles are processed                                    *
!     *   restore the signs in the key array and return               *
!     *                                                               *
      do 30 i = 1,n
          key(i)  =  -key(i)
   30 continue
      go to 70
!c    *                                                               *
!     *   beginning at location  if   update this cycle of the        *
!     *   permutation until   key(key(...(key(if))...)) = if          *
!
   40 continue
      if      =  i
      it      =  iar(i)
   50 continue
      ik      =  key(i)
      key(i)  =  -ik
      if ( ik.eq.if ) go to 60
      is      =  iar(ik)
      iar(ik) =  it
      it      =  is
      i       =  ik
      go to 50
   60 continue
!c    *                                                               *
!     *   set first element of the cycle equal to the original last   *
!     *   element and go on to next cycle                             *
!     *                                                               *
      iar(if) =  it
      go to 10
   70 return
      END subroutine ukysrt
! **deck unipan
      subroutine unipan(ar,r0,x,y)
      implicit double precision (a-h,o-z)
!***created  on 76.011    w.o. no.   0   version        ftj.00
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  to transform the representation of a position vector from    *
!     *  universal to panel coordinates                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the origin of the panel coordinate system is subtracted      *
!     *  from the input coordinates, and the resultant is             *
!     *  premultiplied by the transformation matrix to obtain the     *
!     *  panel coordinate system                                      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   ar        argument  input     transformation matrix         *
!     *                                                               *
!     *   r0        argument  input     origin of the panel           *
!     *                                 coordinate system             *
!     *                                                               *
!     *   w         -local-   - - - -   position vector in system     *
!     *                                 parallel to universal         *
!     *                                 system with origin            *
!     *                                 coincidental with the         *
!     *                                 panel coordinate system       *
!     *                                                               *
!     *   x         argument  input     position vector in the        *
!     *                                 universal system              *
!     *                                                               *
!     *   y         argument  output    position vector in the        *
!     *                                 panel system                  *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension ar(3,3),r0(3),x(3),y(3),w(3)
!c
!     *  subtract the origin of the panel system from the position    *
!     *  vector                                                       *
!
      w(1)    =  x(1) - r0(1)
      w(2)    =  x(2) - r0(2)
      w(3)    =  x(3) - r0(3)
!c
!     *  premultiply by the transformation matrix                     *
!
      y(1)    =  ar(1,1)*w(1) + ar(1,2)*w(2) + ar(1,3)*w(3)
      y(2)    =  ar(2,1)*w(1) + ar(2,2)*w(2) + ar(2,3)*w(3)
      y(3)    =  ar(3,1)*w(1) + ar(3,2)*w(2) + ar(3,3)*w(3)
      return
      END subroutine unipan
! **deck upkims
      subroutine upkims (lblock,nbk,indx)
      integer indx(2)
!
!         return the two parts of a packed index (indx) to the caller.
!         lblock = first record address - 1
!         nbk    = number of 512 word blocks
!
      lblock  =  indx(1)
      nbk     =  indx(2)
!
      return
      END subroutine upkims
! **deck upkpsp
      subroutine upkpsp (md,m,  npsp,kkpsp,iipsp,bpsp,  ns,s)
      implicit double precision (a-h,o-z)
      dimension npsp(md,2), kkpsp(md,2), iipsp(6,md,2), bpsp(6,md,2)
      dimension s(m,*)
!
!         unpack the /compsp/ data from the array  s   using the followi
!         layout:
!
!         npsp(*,1)        s(*,1)
!         npsp(*,2)        s(*,2)
!         kkpsp(*,1)       s(*,3)
!         kkpsp(*,2)       s(*,4)
!         iipsp(6,*,1)     s(*,5:10)
!         iipsp(6,*,2)     s(*,11:16)
!         bpsp(6,*,1)      s(*,17:22)
!         bpsp(6,*,2)      s(*,23:28)
!
!         md      o   int   number of data sets
!         m       o   int   row dimension of s, it is req'd that  m >= m
!         npsp    o   int   number of spline dependencies for each data
!         kkpsp   o   int
!         iipsp   o   int   singularity parameter indices for the spline
!         bpsp    o   r*8   spline data
!         ns      i   int   number of memory cells provided by s (not us
!         s       i   mix   r*8, i data intermixed, to be unpacked
!
!         michael epton, 30 november 1988
!
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
      nw      =  m*28
      do 100 jx = 1,2
      call icopy (m,    s(1,jx),1,        npsp(1,jx),1)
      call icopy (m,    s(1,jx+2),1,     kkpsp(1,jx),1)
      call icopy (6*m,  s(1,6*jx-1) ,1,  iipsp(1,1,jx),1)
      call dcopy (6*m,  s(1,6*jx+11),1,   bpsp(1,1,jx),1)
      if ( iextrp.lt.3 ) goto 100
      write (6,'(1x,a10,1x, 2i12)')                                     &
     & 'm,jx',m,jx
      call outvci ('npsp',m,npsp(1,jx))
      call outvci ('kkpsp',m,kkpsp(1,jx))
      call outmti ('iipsp',6,6,m,iipsp(1,1,jx))
      call outmat ('bpsp',6,6,m,bpsp(1,1,jx))
  100 continue
      return
      END subroutine upkpsp
! **deck upt
      subroutine upt (ch1,ch2)
      character*(*) ch1,ch2
      write (6,6001) ch1,ch2
 6001 format ('  upt called with:',a,'   and:', a)
      return
      END subroutine upt
! **deck uvect
      subroutine uvect(a)
      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 normalize a vector (convert to unit vector)               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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    vector to normalize           *
!     *                                 (normalized in-place)         *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension a(3)
!c
!     *  z is the normal of the three-space vector                    *
!
      z=sqrt(a(1)**2+a(2)**2+a(3)**2)
      if(z.eq.0.d0) return
!c
!     *  normalize the vector                                         *
!
      do 10 i=1,3
   10 a(i)=a(i)/z
      return
      END subroutine uvect
! **deck vadd
      subroutine vadd(a,d,b,c,n)
      implicit double precision (a-h,o-z)
      dimension a(n),b(n),c(n)
      do 100 i=1,n
          c(i) = d*b(i) + a(i)
  100 continue
      return
      END subroutine vadd
! **deck valnet
      subroutine valnet( k, zk, nmk, nnk, icoor )
      implicit double precision (a-h,o-z)
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * * p u r p o s e * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     * determine minimum and maximum x, y, z coordinate limits of    *
!     * single network                                                *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                   * * *  m e t h o d  * * *                   *
!     *                          - - - - - -                          *
!     *                                                               *
!     * construct the array bndlim having max and min array for x,y,z *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!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                   *
!     *                                                               *
!     *   icoor               input     coordinate for which to       *
!     *                                 determine limits: 1=x,2=y,3=z *
!     *                                                               *
!     *   k                   input     network number                *
!     *                                                               *
!     *   nmk                 input     number of rows                *
!     *                                                               *
!     *   nnk                 input     number of columns             *
!     *                                                               *
!     *   bndlim    /netbnd/  output    x,y,z minimum and maximum     *
!     *                                 values                        *
!     *                                                               *
!     *   zk                  input     network geometry              *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!call netbnd
      common / netbnd / bndlim(150,3,2)
!end  netbnd
!
      dimension zk( 3, nmk, nnk )
!
      valmax = zk( icoor, 1, 1 )
      valmin = zk( icoor, 1, 1 )
!
      do 150, i = 2, nmk
        do 149, j = 2, nnk
          valmin =  min ( valmin, zk( icoor, i, j) )
          valmax =  max ( valmax, zk( icoor, i, j) )
  149   continue
  150 continue
!
      bndlim( k, icoor, 1 ) = valmin
      bndlim( k, icoor, 2 ) = valmax
      END subroutine valnet
! **deck velcor
      subroutine velcor (iv,f,fm,c,amach,w,v)
      implicit double precision (a-h,o-z)
      dimension f(3), c(3), w(3), v(3), pv(3)
!         apply a velocity correction formula to v, the velocity vector.
!
!     input
!         iv        velocity correction flag
!                        1 = no correction
!                        2 = the mclean correction
!                        3 = the boctor correction
!         f         the freestream velocity vector
!         fm        the magnitude of f
!         cm        the compressibility axis
!         amach     the mach number
!         w         total mass flux vector
!         v         total velocity vector (uncorrected)
!
!     output
!         v         total velocity vector (corrected)
!
      data gm /1.4d0/,   nt /20/
!
!                                  define in-line functions
      ffcn(xd) = xd * ( max(0.d0, 1.d0 + hgm1m2*(1.d0-xd*xd)  ) )**gm1i
      gfcni(ed) =  xc * (  1.d0 - sqrt( max(0.d0,1.d0-ed/fc) )  )
      phi(ed) =  ffcn(  gfcni(ed)  )
!
!
!                                  if no correction is to be applied, re
      if ( iv.le.0 ) go to 950
      call vadd (v, -1.d0, f, pv, 3)
      call vip (pv,1,  c,1,  3,pvc)
      if ( iv.gt.1 ) go to 200
!                                  mclean velocity correction
      if ( pvc .gt. 0.d0 ) go to 40
          rhorat  =  1.d0/( 1.d0-amach*amach*pvc/fm )
          go to 100
   40 continue
          call vip (v,1,  v,1,  3,  vsq)
          call vip (w,1,  w,1,  3,  wsq)
          rhorat  =  1.d0
          if ( wsq .ne. 0.d0 ) rhorat = sqrt(vsq/wsq)
  100 continue
      call vmul (w,rhorat,v,3)
      go to 950
!                                  boctor velocity correction
  200 continue
      if ( amach .gt. 1.d0 ) go to 950
      call vip (w,1,c,1,3,wc)
      y       =  wc/fm
      if ( abs(y) .gt. 1.d0 ) go to 950
!
      gm1     =  gm - 1.d0
      gm1i    =  1.d0/gm1
      hgm1m2  =  .5d0*gm1* amach**2
      sgy     =  1.d0
      if ( y.lt.0.d0 ) sgy = -1.d0
      y       =  abs(y)
      if ( amach .gt. .6d0 ) go to 500
!
!                                  solve for  x ,  y = ffcn( x )
!                                  by means of the secant method
      x       =  y
      p       =  ffcn(x)
      s       =  1.d0
      xu      =  1.d0
      xl      =  0.d0
      pu      =  1.d0
      pl      =  0.d0
!
      do 300 it = 1,nt
          xn      =   max (xl, min (xu,  x-(p-y)/s  ))
          pn      =  ffcn(xn)
          if ( pn.ge.y ) go to 210
               pl      =  pn
               xl      =  xn
  210     continue
          if ( pn.le.y ) go to 220
               pu      =  pn
               xu      =  xn
  220     continue
          sn      =  s
          if ( abs(x-xn) .gt. .0001d0 ) sn = (p-pn)/(x-xn)
          x       =  xn
          p       =  pn
          s       =  sn
          if ( abs(y-p) .lt. 1.d-8 ) go to 310
  300 continue
  310 continue
      vxc     =  sgy * x * fm
      go to 800
!
!                                  solve for  e ,  y = ffcn( gfcni( e )
!                                  by means of the secant method
  500 continue
      xc      =  sqrt(  (1.d0+hgm1m2) / (.5d0*(gm+1.d0)*amach**2)  )
      fc      =  xc * (amach*xc)**(2.d0/gm1)
      e       =  y
      x       =  gfcni( e )
      p       =  ffcn( x )
      s       =  1.d0
      eu      =  fc
      el      =  0.d0
      pu      =  fc
      pl      =  0.d0
!
      do 600 it = 1,nt
          en      =   max (el, min (eu,  e-(p-y)/s  ))
          xn      =  gfcni ( en )
          pn      =  ffcn ( xn )
          if ( pn.ge.y ) go to 510
               pl      =  pn
               el      =  en
  510     continue
          if ( pn.le.y ) go to 520
               pu      =  pn
               eu      =  en
  520     continue
          sn     =  s
          if ( abs(e-en) .gt. .0001d0 ) sn = (p-pn)/(e-en)
          e       =  en
          p       =  pn
          s       =  sn
          if ( abs(y-p) .lt. 1.d-8 ) go to 610
  600 continue
  610 continue
!                                  set  x = gfcni( e )  so that  y = ffc
      x       =  gfcni(e)
      vxc     =  sgy * x * fm
!
!                                  n.b.:  vxc = sgy * x * fm  where ffcn
  800 continue
      call vip (v,1,c,1,3,vx)
      call vadd (v,vxc-vx,c,v,3)
      go to 950
!
  950 continue
      END subroutine velcor
! **deck vffkrn
      subroutine vffkrn (nncp,nnvcp,ncnsym,za,rsqa,ifla                 &
     &                  ,hk,gk  ,hkph,gkph                              &
     &                  ,indb,rsqb,zb  ,hkb,gkb                         &
     &                  ,p1,p2   ,ps0,ps1,ps2,ps3                       &
     &                  ,xb,yb  ,xxb,xyb,yyb                            &
     &                  ,jca                                            &
     &                  )
      implicit double precision (a-h,o-z)
      dimension za(3,nncp*ncnsym), rsqa(nncp*ncnsym), ifla(nncp*ncnsym)
      dimension hk(nncp*ncnsym,6), gk(nncp*ncnsym,6)
      dimension hkph(nncp,6), gkph(nncp,6)
!                                     scratch arrays
      dimension indb(nncp*ncnsym)
      dimension rsqb(nncp*ncnsym),    zb(nncp*ncnsym,3)
      dimension  hkb(nncp*ncnsym,6), gkb(nncp*ncnsym,6)
      dimension  p1(nncp*ncnsym), p2(nncp*ncnsym)
      dimension ps0(nncp*ncnsym),ps1(nncp*ncnsym),ps2(nncp*ncnsym)      &
     &         ,ps3(nncp*ncnsym)
      dimension xxb(nncp*ncnsym),xyb(nncp*ncnsym),yyb(nncp*ncnsym)      &
     &         , xb(nncp*ncnsym), yb(nncp*ncnsym)
      dimension jca(nncp)
! +++ ACTIVATE FOLLOWING LINES FOR UNSTEADY CODE (ityprc=2)
! +++ thought: supersonic unsteady has REAL aic's ==> 1/2 cost possible
! +++ pursue this thought after getting it all validated
! +++ complex ps0, ps1, ps2, ps3
! +++ complex hk,gk,  hkph,gkph,  hkb,gkb
! --- real*8 hk,gk,  hkph,gkph,  hkb,gkb,  ps0,ps1,ps2,ps3
!
!     compute kernels moments for all far fields (ifla = 1,2,3)
!     and compute folded kernel moments for phic calculations
!
!     nncp    i  i*4  no. of c.p.'s in current group
!     nnvcp   i  i*4  no. of c.p.'s in current group needing VIC's
!     ncnsym  i  i*4  no. of symmetry conditions
!     za      i  r*8  za(3,nncp,ncnsym) = local [ p(*,icp,icnsym)-qz(*)]
!     rsqa    i  r*8  square of cp image to panel ctr compressible dist.
!     ifla    i  r*8  influence type for all cp images
!     hk      o  r*8  doublet potential kernel moments
!     gk      o  r*8  source  potential kernel moments
!     hkph    o  r*8  doublet potential kernel moments, symmetry folded
!     gkph    o  r*8  source  potential kernel moments, symmetry folded
!     indb    s  r*8  positions in ifla corresponding to far field IC's
!     rsqb    s  r*8  R^2 values for farfields; also, omg*R values
!     zb      s  r*8  local [ p(*,ib)-qz(*)] for FF cp's p(*,ib)
!     hkb     s  r*8  doublet potential kernel moments, FF cp's
!     gkb     s  r*8  source  potential kernel moments, FF cp's
!     p1      s  r*8  R, then 1/R for FF cp's
!     p2      s  r*8  1/(R^2) for FF cp's
!     ps0     s  r*8  kernel function psi(R)
!                     steady flow:           1/R
!                     unsteady subsonic:     exp(-i omg R)/R
!                     unsteady supersonic:   cos(omg R)/R
!     ps1     s  r*8  D[psi], where  Df == -(1/R) df/dR
!     ps2     s  r*8  D[ D[psi] ]
!     ps3     s  r*8  D[ D[ D[psi] ] ]
!     xb      s  r*8  [unsteady: cos(omg*R)], rf*x values
!     yb      s  r*8  [unsteady: sin(omg*r)], sf*y values
!     xxb     s  r*8  xb*xb values
!     xyb     s  r*8  xb*yb values
!     yyb     s  r*8  yb*yb values
!     jca     i  i*4  jc [control point index] values for za
!
!call freqdt
!                                                  /freqdt/
      common /freqdt/ omgbar, omegb, omg, omgabs
!---- complex*16 omgbar, omegb, omg
!end  freqdt
!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 symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!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 dsnpic
      common /dsnicr/ phsdsn(6), vsdsn(3,6), phxdsn(3,4), phydsn(3,4)
      common /dsnicl/ dsnic
      logical dsnic
!end  dsnpic
!
      dimension sgnkar(4)
      logical gkneed, hkneed
!                                  ph/s kernel moments (gk) needed if
!                                  panel has source or if dsnic is set
      gkneed  =  (itsf.ne.2) .or. dsnic
!                                  ph/d kernel moments (hk) needed if
!                                  panel has doublet or if VIC's req'd
      hkneed  =  itsf.ge.2  .or.  nnvcp.gt.0
!
                          ! SET BUT NEVER USED ???
      rs      =  rf*sf
      fs      =  -ajf*sf
      omg2    =  omg*omg
!
      sgnki    =  1.d0
      if ( misym.lt.0 ) sgnki = -1.d0
      sgnkj    =  1.d0
      if ( mjsym.lt.0 ) sgnkj = -1.d0
      sgnkar(1) =  1.d0
      sgnkar(2) =  sgnki
      sgnkar(3) =  sgnkj
      sgnkar(4) =  sgnki*sgnkj
!                                  gather up c.p. locations for
!                                  all true far fields
!
      na      =  nncp*ncnsym
!                                  note: vinflu/vinsup now uses 7 for
!                                  a null influence flag
!===      if ( amach.gt. 1.d0 ) then
!===         call wheneq (na  ,ifla,1  ,0  ,indb,nb)
!===         do 40 k = 1,nb
!===            ifla(indb(k)) = 7
!=== 40      continue
!===      endif
!                                  find all true far fields
      call whenilt (na  ,ifla,1  ,4  ,indb,nb)
      do 80 k = 1,nb
         rsqb(k) = rsqa(indb(k))
         zb(k,1) = za(1,indb(k))
         zb(k,2) = za(2,indb(k))
         zb(k,3) = za(3,indb(k))
   80 continue
!                                  get p1 = sqrt[ rsqb ]
      do 85 k = 1,nb
         p1(k)   =  sqrt(rsqb(k))
   85 continue
!
      if ( ityprc.eq.1 ) goto 110
!                                  complex data (unsteady case)
!                                  put omg*R into rsqb
      do 90 k = 1,nb
         rsqb(k) = omg*p1(k)
   90 continue
!                                  [cos(omg*R),sin(omg*R)] in [xb,yb]
      do 92 k = 1,nb
         xb(k) = cos(rsqb(k))
         yb(k) = sin(rsqb(k))
   92 continue
      if ( amach.gt. 1.d0 ) goto 100
!                                  subsonic case: partial ps0,ps1
      do 94 k = 1,nb
                                                     ! was dcmplx
         ps0(k) = CMPLX(xb(k), -yb(k), KIND=8)
                                                                ! was dc
         ps1(k) = ps0(k) * CMPLX(1.d0, rsqb(k), KIND=8)
   94 continue
      goto 110
!                                  supersonic case: partial ps0,ps1
  100 continue
      do 102 k = 1,nb
         ps0(k) = xb(k)
         ps1(k) = xb(k) + rsqb(k)*yb(k)
  102 continue
      goto 110
!                                  start generating kernel moments
!                                  inverse powers of R;
!                                  normalized  x, y, x*x, x*y, y*y
  110 continue
      do 120 k = 1,nb
         p1(k)  =  1.d0/p1(k)
         p2(k)  =  p1(k)*p1(k)
         xb(k)  =  rf*zb(k,1)
         yb(k)  =  sf*zb(k,2)
         xxb(k) =  zb(k,1)*zb(k,1)
         xyb(k) =  xb(k)*yb(k)
         yyb(k) =  zb(k,2)*zb(k,2)
  120 continue
!
      if ( ityprc.eq.2 ) goto 125
!                                  real data: steady flow
      do 122 k = 1,nb
         ps0(k) = p1(k)
         ps1(k) = p1(k)*p2(k)
         ps2(k) = 3.d0*p2(k)*ps1(k)
         ps3(k) = 5.d0*p2(k)*ps2(k)
  122 continue
      goto 135
!                                  complex data: unsteady flow
  125 continue
      do 130 k = 1,nb
         ps0(k) = p1(k)*ps0(k)
         ps1(k) = p1(k)*p2(k)*ps1(k)
         ps2(k) = p2(k)*( 3.d0*ps1(k) -  omg2*ps0(k) )
         ps3(k) = p2(k)*( 5.d0*ps2(k) -  omg2*ps1(k) )
  130 continue
!
  135 continue
!                                  doublet kernel moments
      if ( .not.hkneed ) goto 190
      do 140 k = 1,nb
         hkb(k,1)  =         ps1(k)
         hkb(k,2)  =   xb(k)*ps2(k)
         hkb(k,3)  =   yb(k)*ps2(k)
         hkb(k,4)  =  xxb(k)*ps3(k) - rf*ps2(k)
         hkb(k,5)  =  xyb(k)*ps3(k)
         hkb(k,6)  =  yyb(k)*ps3(k) - sf*ps2(k)
  140 continue
!                                  scatter the doublet kernel moments
      call zero (hk,ityprc*na*6)
      do 150 k = 1,nb
         hk(indb(k),1) = hkb(k,1)
         hk(indb(k),2) = hkb(k,2)
         hk(indb(k),3) = hkb(k,3)
         hk(indb(k),4) = hkb(k,4)
         hk(indb(k),5) = hkb(k,5)
         hk(indb(k),6) = hkb(k,6)
  150 continue
!                                  perform folding for ph/d calculation
      do 155 k = 1,nncp
         hkph(k,1)  =  za(3,k)*hk(k,1)
         hkph(k,2)  =  za(3,k)*hk(k,2)
         hkph(k,3)  =  za(3,k)*hk(k,3)
         hkph(k,4)  =  za(3,k)*hk(k,4)
         hkph(k,5)  =  za(3,k)*hk(k,5)
         hkph(k,6)  =  za(3,k)*hk(k,6)
  155 continue
!
      kbase   =  0
      do 180 icnsym = 2,ncnsym
      kbase   =  kbase + nncp
      sgnk    =  sgnkar(icnsym)
      if ( sgnk.lt.0.d0 ) goto 165
      do 160 k = 1,nncp
         hkph(k,1) = hkph(k,1) + za(3,k+kbase)*hk(k+kbase,1)
         hkph(k,2) = hkph(k,2) + za(3,k+kbase)*hk(k+kbase,2)
         hkph(k,3) = hkph(k,3) + za(3,k+kbase)*hk(k+kbase,3)
         hkph(k,4) = hkph(k,4) + za(3,k+kbase)*hk(k+kbase,4)
         hkph(k,5) = hkph(k,5) + za(3,k+kbase)*hk(k+kbase,5)
         hkph(k,6) = hkph(k,6) + za(3,k+kbase)*hk(k+kbase,6)
  160 continue
      goto 180
!
  165 continue
      do 170 k = 1,nncp
         hkph(k,1) = hkph(k,1) - za(3,k+kbase)*hk(k+kbase,1)
         hkph(k,2) = hkph(k,2) - za(3,k+kbase)*hk(k+kbase,2)
         hkph(k,3) = hkph(k,3) - za(3,k+kbase)*hk(k+kbase,3)
         hkph(k,4) = hkph(k,4) - za(3,k+kbase)*hk(k+kbase,4)
         hkph(k,5) = hkph(k,5) - za(3,k+kbase)*hk(k+kbase,5)
         hkph(k,6) = hkph(k,6) - za(3,k+kbase)*hk(k+kbase,6)
  170 continue
!                                  end loop on symmetry conditions
  180 continue
!
  190 continue
!                                  source kernel moments
      if ( .not.gkneed ) goto 290
      do 240 k = 1,nb
         gkb(k,1)  =         ps0(k)
         gkb(k,2)  =   xb(k)*ps1(k)
         gkb(k,3)  =   yb(k)*ps1(k)
         gkb(k,4)  =  xxb(k)*ps2(k) - rf*ps1(k)
         gkb(k,5)  =  xyb(k)*ps2(k)
         gkb(k,6)  =  yyb(k)*ps2(k) - sf*ps1(k)
  240 continue
!                                  scatter the source kernel moments,
!                                  scaling by the factor  fs = -ajf*sf
!                                  as you go [no bop count increase]
      call zero (gk,ityprc*na*6)
      do 250 k = 1,nb
         gk(indb(k),1) = fs*gkb(k,1)
         gk(indb(k),2) = fs*gkb(k,2)
         gk(indb(k),3) = fs*gkb(k,3)
         gk(indb(k),4) = fs*gkb(k,4)
         gk(indb(k),5) = fs*gkb(k,5)
         gk(indb(k),6) = fs*gkb(k,6)
  250 continue
!                                  perform folding for ph/s calculation
      do 255 k = 1,nncp
         gkph(k,1)  =  gk(k,1)
         gkph(k,2)  =  gk(k,2)
         gkph(k,3)  =  gk(k,3)
         gkph(k,4)  =  gk(k,4)
         gkph(k,5)  =  gk(k,5)
         gkph(k,6)  =  gk(k,6)
  255 continue
!
      kbase   =  0
      do 280 icnsym = 2,ncnsym
      kbase   =  kbase + nncp
      sgnk    =  sgnkar(icnsym)
      if ( sgnk.lt.0.d0 ) goto 265
      do 260 k = 1,nncp
         gkph(k,1) = gkph(k,1) + gk(k+kbase,1)
         gkph(k,2) = gkph(k,2) + gk(k+kbase,2)
         gkph(k,3) = gkph(k,3) + gk(k+kbase,3)
         gkph(k,4) = gkph(k,4) + gk(k+kbase,4)
         gkph(k,5) = gkph(k,5) + gk(k+kbase,5)
         gkph(k,6) = gkph(k,6) + gk(k+kbase,6)
  260 continue
      goto 280
!
  265 continue
      do 270 k = 1,nncp
         gkph(k,1) = gkph(k,1) - gk(k+kbase,1)
         gkph(k,2) = gkph(k,2) - gk(k+kbase,2)
         gkph(k,3) = gkph(k,3) - gk(k+kbase,3)
         gkph(k,4) = gkph(k,4) - gk(k+kbase,4)
         gkph(k,5) = gkph(k,5) - gk(k+kbase,5)
         gkph(k,6) = gkph(k,6) - gk(k+kbase,6)
  270 continue
!                                  end loop on symmetry conditions
  280 continue
!
  290 continue
!
      return
      END subroutine vffkrn
! **deck vffmat
      subroutine vffmat (label,kind,nnvcp,ncnsym,nj,vb)
      implicit double precision (a-h,o-z)
      character*(*) label
      dimension vb(nnvcp,ncnsym,nj,3)
!
!     print an individual panel influence (selected by kind)
!     from vffvs2 with vb stored in a format appropriate to vffvs2
!
      dimension vx(3,10)
!
      do 100 icnsym = 1,ncnsym
         write (6,'(''  symmetry condition:'',i5)') icnsym
         do 60 j = 1,nj
            do 50 i = 1,3
               vx(i,j) = vb(kind,icnsym,j,i)
   50       continue
   60    continue
         call outmtx (label,3,3,nj,vx)
  100 continue
      return
      END subroutine vffmat
! **deck vffpev
      subroutine vffpev (nncp,jca  ,iflc  ,gkph,hkph                    &
     &                  ,phs,phd  ,phic,astcpx)
      implicit double precision (a-h,o-z)
      logical astcpx
      dimension gkph(nncp,6), hkph(nncp,6), phic(nncp,*)
      dimension phs(nncp,9), phd(nncp,21)
      dimension jca(nncp), iflc(nncp)
! --- real*8 gkph, hkph, phs, phd, phic
!
!     transform folded kernel moments into potential IC's and store in
!     the buffers phs, phd
!
!     RECOMMENDATIONS:  construct hmt in /pandfx/
!                       incorporate code inline in vinfcc
!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 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
!
      dimension nkrna(0:7)
      dimension phsx(9), phdx(21)
! --- real*8 phsx, phdx, gkk, hkk
!                                  number of kernel terms
      data nkrna /0,1,3,6,0,0,0,0/
!                                  method: 1,true FF; 2, all quadrupole
      data method / 2 /
!
      nncpx   =  nncp*ityprc
      if ( astcpx ) goto 800
      goto ( 100, 500) method
!                                  DISTINGUISH TYPES 1, 2 AND 3 FF's
  100 continue
!                                  evaluate source influences
      if ( mod(itsf,2).ne.0 ) then
         do 200 k = 1,nncp
            nkrn    =  nkrna(iflc(k))
            if ( nkrn.le.0 ) goto 200
!                                  build source potential
            gkk     =  gkph(k,1)
            do 140 j = 1,insf
               phsx(j) = gkk*hmasts(1,j)
  140       continue
            do 180 ikrn = 2,nkrn
               gkk     =  gkph(k,ikrn)
               do 160 j = 1,insf
                  phsx(j) = phsx(j) + gkk*hmasts(ikrn,j)
  160          continue
  180       continue
!
            do 190 j = 1,insf
               phic(k,iisf(j)) = phic(k,iisf(j)) + phsx(j)
  190       continue
!
  200    continue
      endif
!                                  evaluate doublet influences
      if ( itsf.ge.2 ) then
         do 400 k = 1,nncp
            nkrn    =  nkrna(iflc(k))
            if ( nkrn.le.0 ) goto 400
!                                  build source potential
            hkk     =  hkph(k,1)
            do 340 j = 1,indf
               phdx(j) = hkk*hmastd(1,j)
  340       continue
            do 380 ikrn = 2,nkrn
               hkk     =  hkph(k,ikrn)
               do 360 j = 1,indf
                  phdx(j) = phdx(j) + hkk*hmastd(ikrn,j)
  360          continue
  380       continue
!
            do 390 j = 1,indf
               phic(k,iidf(j)) = phic(k,iidf(j)) + phdx(j)
  390       continue
!
  400    continue
      endif
      goto 950
!                                   USE QUADRUPOLES FOR ALL EVALUATIONS
  500 continue
      if ( mod(itsf,2).ne.0 ) then
         call hsmmp1 (nncpx,6,insf  ,gkph,1,nncpx  ,hmasts,1,6          &
     &               ,phs,1,nncpx)
         do 600 j = 1,insf
            jj      =  iisf(j)
            do 550 k = 1,nncp
               phic(k,jj) = phic(k,jj) + phs(k,j)
  550       continue
  600    continue
!====    call hsmmp1 (nncpx,6,3  ,gkph,1,nncpx  ,hm,10,1  ,phs,1,nncpx)
!----    call hsmmp1 (nncpx,6,3  ,gkph,1,nncpx  ,hmt,1,6  ,phs,1,nncpx)
      endif
      if ( itsf.ge.2 ) then
         call hsmmp1 (nncpx,6,indf  ,hkph,1,nncpx  ,hmastd,1,6          &
     &               ,phd,1,nncpx)
         do 700 j = 1,indf
            jj      =  iidf(j)
            do 650 k = 1,nncp
               phic(k,jj) = phic(k,jj) + phd(k,j)
  650       continue
  700    continue
!====    call hsmmp1 (nncpx,6,6  ,hkph,1,nncpx  ,hm,10,1  ,phd,1,nncpx)
!----    call hsmmp1 (nncpx,6,6  ,hkph,1,nncpx  ,hmt,1,6  ,phd,1,nncpx)
      endif
      goto 950
!
!                                   USE QUADRUPOLES FOR ALL EVALUATIONS
!                                   [DATA IS COMPLEX]
  800 continue
      if ( mod(itsf,2).ne.0 ) then
         call hcmmp1 (nncp,6,insf  ,gkph,1,nncp  ,hmasts,1,6            &
     &               ,phs,1,nncp)
         do 850 j = 1,insf
            jj      =  iisf(j)
            do 820 k = 1,nncp
               phic(k,jj) = phic(k,jj) + phs(k,j)
  820       continue
  850    continue
      endif
      if ( itsf.ge.2 ) then
         call hcmmp1 (nncp,6,indf  ,hkph,1,nncp  ,hmastd,1,6            &
     &               ,phd,1,nncp)
         do 900 j = 1,indf
            jj      =  iidf(j)
            do 870 k = 1,nncp
               phic(k,jj) = phic(k,jj) + phd(k,j)
  870       continue
  900    continue
      endif
      goto 950
!
  950 continue
      return
      END subroutine vffpev
! **deck vffpin
      subroutine vffpin (nncp,phs,phd,ph,phic)
      implicit double precision (a-h,o-z)
      dimension phs(nncp,3), phd(nncp,6), ph(nncp,30), phic(nncp,*)
! +++ complex phs, phd, ph, phic
!
!     transform folded kernel moments into potential IC's and accumulate
!     into the phic buffer
!
!     RECOMMENDATIONS:  put insp,iisp in /pandfx/
!                       write assembly code to do 100 loop
!                       incorporate code inline in vinfcc
!
!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 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
      dimension iisp(30)
!
      insp    =  0
      nncpx   =  nncp*ityprc
      if ( mod(itsf,2).ne.0 ) then
         call icopy (insf  ,iisf,1  ,iisp,1)
         call hsmmp1 (nncpx,3,insf  ,phs,1,nncpx  ,astsf,1,3            &
     &               ,ph,1,nncpx)
         insp    =  insf
      endif
!
      if ( itsf.ge.0 ) then
         call icopy (indf  ,iidf,1  ,iisp(insp+1),1)
         call hsmmp1 (nncpx,6,indf  ,phd,1,nncpx  ,astdf,1,6            &
     &               ,ph(1,insp+1),1,nncpx)
         insp    =  insp + indf
      endif
!
      if (ityprc.eq.1) call djsct2 (nncp,insp ,ph,nncp ,iisp ,phic,nncp)
      if (ityprc.eq.2) call zjsct2 (nncp,insp ,ph,nncp ,iisp ,phic,nncp)
! ---      do 100 j = 1,insp
! ---         jic     =  iisp(j)
! ---         call daxpy (nncp  ,1.d0  ,ph(1,j),1  ,phic(1,jic),1)
! --- 100  continue
!
      return
      END subroutine vffpin
! **deck vffvel
      subroutine vffvel (nncp,nnvcp,ncnsym                              &
     &                  ,hk,za,ifla,indv,iflva,iflvb                    &
     &                  ,vsa,vda,sna                                    &
     &                  ,indva,indvb,indb,zvb,hkv  ,hbv,hv              &
     &                  ,vsb,vsc  ,vdb,vdc  ,snb,snc,  jca)
      implicit double precision (a-h,o-z)
      dimension hk(nncp*ncnsym,6), za(3,nncp*ncnsym)
      dimension ifla(nncp*ncnsym), indv(nnvcp), iflva(nnvcp*ncnsym)     &
     &                                        , iflvb(nnvcp*ncnsym)
      dimension vsa(3,nnvcp,3), vda(3,nnvcp,5), sna(3,nnvcp,3)
!                                  scratch memory
      dimension indva(nnvcp*ncnsym), indvb(nnvcp*ncnsym), indb(nnvcp)
      dimension zvb(nnvcp*ncnsym,3), hkv(nnvcp*ncnsym,6)
      dimension hbv(nnvcp*ncnsym,12), hv(nnvcp*ncnsym,6)
      dimension vsb(nnvcp*ncnsym,9),  vsc(nnvcp*ncnsym,9)
      dimension vdb(nnvcp*ncnsym,15), vdc(nnvcp*ncnsym,15)
      dimension snb(nnvcp*ncnsym,9),  snc(nnvcp*ncnsym,9)
      dimension jca(nncp)
! --- real*8 hk,hkv,hbv,hv,  vsa,vsb,vsc,  vda,vdb,vdc,  sna,snb,snc
!
!     transform hk kernel moments into velocity matrices
!
!     nncp    i  i*4  no. of c.p.'s in current group
!     nnvcp   i  i*4  no. of c.p.'s in current group needing VIC's
!     ncnsym  i  i*4  no. of symmetry conditions
!     za      i  r*8  za(3,nncp,ncnsym) = local [ p(*,icp,icnsym)-qz(*)]
!     ifla    i  i*4  influence type for all cp images
!     indv    i  i*4  list of cp-indices for cp's needing VIC data
!     iflva   l  i*4  influence types for cp's needing VIC data
!     hk      i  r*8  doublet potential kernel moments
!     vsa     o  r*8  source  VIC's computed by FF methods (3,nnvcp,3)
!     vda     o  r*8  doublet VIC's computed by FF methods (3,nnvcp,5)
!     indva   o  i*4
!     indvb   l  i*4
!     indb    l  i*4
!     zvb     l  r*8
!     hkv     l  r*8
!     hbv     l  r*8
!     hv      l  r*8
!     vsb     l  r*8  vsb(nnvcp,ncnsym,3,i)  source vic's, true FF's
!     vsc     l  r*8  scratch array for vsb calculation
!     vdb     l  r*8  vdb(nnvcp,ncnsym,5,i) doublet vic's, true FF's
!     vdc     l  r*8  scartch array for vdb calculation
!
!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 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 symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!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
!
      logical vdblet, vsourc, vsens
      logical true12
!
      vsens   =  .false.
      vsourc  =  itsf.ne.2  .or.  vsens
      vdblet  =  itsf.ge.2
!                                  flag to enforce true types 1&2 by
!                                  zeroing appropriate kernel moments
      true12  =  .false.
!                                  generate the list of c.p. images
!                                  for which vic computation is req'd
      nnkv    =  nnvcp*ncnsym
      kabase  =  0
      kvabas  =  0
      nvb     =  0
      do 70 icnsym = 1,ncnsym
         do 40 k = 1,nnvcp
            iflva(kvabas+k) = ifla(indv(k)+kabase)
   40    continue
         call whenilt (nnvcp  ,iflva(kvabas+1),1  ,4  ,indb,nb)
!                                  indva points back into the za array;
!                                  indvb points back into the vb buffer
!                                  used in vffvs2: vb(nnvcp*ncnsym,nj,3)
         do 50 ib = 1,nb
            indva(ib+nvb) = indv( indb(ib) ) + kabase
            indvb(ib+nvb) = indb(ib) + kvabas
!                                  following line req'd if true12 = .T.
            iflvb(ib+nvb) = iflva(kvabas+indb(ib))
   50    continue
         kabase  =  kabase + nncp
         kvabas  =  kvabas + nnvcp
         nvb     =  nvb + nb
   70 continue
!                                  check for no influence; if nvb = 0,
!                                  zero outputs and return
      if ( nvb.gt.0 ) goto 100
         if ( vsourc ) call zero (vsa,ityprc*3*nnvcp*3)
         if ( vdblet ) call zero (vda,ityprc*3*nnvcp*5)
         if ( vsens  ) call zero (sna,ityprc*3*nnvcp*6)
         goto 950
  100 continue
!                                  gather up all kernel moments for
!                                  the required velocity matrices
      do 110 k = 1,nvb
         zvb(k,1)  =  za( 1, indva(k) )
         zvb(k,2)  =  za( 2, indva(k) )
         zvb(k,3)  =  za( 3, indva(k) )
  110 continue
!                                  doublet kernel moments
      do 130 k = 1,nvb
         hkv(k,1)  =  hk( indva(k),1 )
         hkv(k,2)  =  hk( indva(k),2 )
         hkv(k,3)  =  hk( indva(k),3 )
         hkv(k,4)  =  hk( indva(k),4 )
         hkv(k,5)  =  hk( indva(k),5 )
         hkv(k,6)  =  hk( indva(k),6 )
  130 continue
!                                  zero out certain farfield moments
!                                  in accordance with influence type
!                                  instructions
      if ( .not. true12 ) goto 151
      call whenilt (nnkv  ,iflvb,1  ,3  ,indb,nb)
      do 140 ib = 1,nb
         hkv( indb(ib), 4 ) = 0.d0
         hkv( indb(ib), 5 ) = 0.d0
         hkv( indb(ib), 6 ) = 0.d0
  140 continue
!
      call whenilt (nnkv  ,iflvb,1  ,2  ,indb,nb)
      do 150 ib = 1,nb
         hkv( indb(ib), 2 ) = 0.d0
         hkv( indb(ib), 3 ) = 0.d0
  150 continue
  151 continue
!                                  EVALUATE KERNEL INTEGRALS
      nvbx    =  ityprc*nvb
      nnkvx   =  ityprc*nnkv
!                                  nhv = 3 for linear source alone
      nhv     =  3
      if ( vdblet .or. vsens ) nhv = 6
      call hsmmp1 (nvbx,6,nhv  ,hkv,1,nnkvx  ,hm,10,1  ,hv,1,nnkvx)
! --- call hsmmp1 (nvbx,6,nhv  ,hkv,1,nnkvx  ,hmt,1,6  ,hv,1,nnkvx)
!                                  build hbar velocity moments (used
!                                  for vs(1),vs(2) and vd(3) )
!                                  First, enforce any 'true 1&2'
!                                  conditions if requested.
      if ( .not. true12 ) goto 171
!                                  indb still set for true monopoles
! ---      call whenilt (nnkv  ,iflvb,1  ,2  ,indb,nb)
      do 170 ib = 1,nb
         hkv( indb(ib), 1 ) = 0.d0
  170 continue
!                                  find true monopoles and dipoles
      call whenilt (nnkv  ,iflvb,1  ,3  ,indb,nb)
      do 160 ib = 1,nb
         hkv( indb(ib), 2 ) = 0.d0
         hkv( indb(ib), 3 ) = 0.d0
  160 continue
  171 continue
      nhbv    =  6
      if ( vsens ) nhbv = 12
      call hsmmp1 (nvbx,3,nhbv  ,hkv,1,nnkvx  ,hbm,12,1  ,hbv,1,nnkvx)
! --- call hsmmp1 (nvbx,3,nhbv  ,hkv,1,nnkvx  ,hbmt,1,3  ,hbv,1,nnkvx)
!                                  build VIC data for source, doublets
!                                  and sensitivity calculations per req.
      call vffvs1 (ncnsym,nnvcp,nvb,nnkv  ,indvb,zvb,hv,hbv             &
     &            ,vsourc,vsa,vsb,vsc  ,vdblet,vda,vdb,vdc              &
     &            ,vsens ,sna,snb,snc  ,nncp,jca,indv)
!                                  common return point
  950 continue
!
      return
      END subroutine vffvel
! **deck vffvin
      subroutine vffvin (nnvcp,vsa,vda,va,vic,astcpx)
      implicit double precision (a-h,o-z)
      logical astcpx
      dimension vsa(3,nnvcp,3), vda(3,nnvcp,5), va(3,nnvcp,30)
      dimension vic(3,nnvcp,*)
! --- real*8 vsa, vda, va, vic
!
!     apply outer splines to FF vic data and accumulate it into the
!     vic buffer.
!
!     RECOMMENDATIONS:  put insp,iisp in /pandfx/
!                       write assembly code to do 100 loop
!                       incorporate code inline in vinfcc
!
!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 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
      dimension iisp(30)
!
      nnvcp3  =  nnvcp*3
      nvcp3x  =  nnvcp3*ityprc
      insp    =  0
      if ( mod(itsf,2).ne.0 ) then
         call icopy (insf  ,iisf,1  ,iisp,1)
         if ( .not.astcpx ) then
         call hsmmp1 (nvcp3x,3,insf  ,vsa,1,nvcp3x  ,astsf,1,3          &
     &               ,va,1,nvcp3x)
         else
            call hcmmp1 (nvcp3,3,insf   ,vsa,1,nvcp3   ,astsf,1,3       &
     &                  ,va,1,nvcp3)
         endif
         insp    =  insf
      endif
!
      if ( itsf.ge.2 ) then
         call icopy (indf  ,iidf,1  ,iisp(insp+1),1)
         if ( .not.astcpx ) then
         call hsmmp1 (nvcp3x,5,indf  ,vda,1,nvcp3x  ,astdf(2),1,6       &
     &               ,va(1,1,insp+1),1,nvcp3x)
         else
            call hcmmp1 (nvcp3,5,indf   ,vda,1,nvcp3   ,astdf(2),1,6    &
     &                  ,va(1,1,insp+1),1,nvcp3)
         endif
         insp    =  insp + indf
      endif
!
      if ( ityprc.eq.1 )                                                &
     &   call djsct2 (nnvcp3,insp  ,va,nnvcp3  ,iisp  ,vic,nnvcp3)
      if ( ityprc.eq.2 )                                                &
     &   call zjsct2 (nnvcp3,insp  ,va,nnvcp3  ,iisp  ,vic,nnvcp3)
!---      do 100 j = 1,insp
!---         jic     =  iisp(j)
!---         call daxpy (nnvcp3  ,1.d0  ,va(1,1,j),1  ,vic(1,1,jic),1)
!--- 100  continue
!
      return
      END subroutine vffvin
! **deck vffvs1
      subroutine vffvs1 (ncnsym,nnvcp,nvb,nnkv   ,indvb,zvb,hv,hbv      &
     &                  ,vsourc,vsa,vsb,vsc  ,vdblet,vda,vdb,vdc        &
     &                  ,vsens ,sna,snb,snc,  nncp,jca,indv)
      implicit double precision (a-h,o-z)
      dimension zvb(nnkv,3), hv(nnkv,6), hbv(nnkv,12), indvb(nnkv)
      dimension  vsa(3,nnvcp,3), vsb(nvb,9), vsc(nvb,9)
      dimension  vda(3,nnvcp,5), vdb(nvb,15),vdc(nvb,15)
      dimension  sna(3,nnvcp,6), snb(nvb,9), snc(nvb,9)
! --- real*8  hbv,hv,  vsa,vsb,vsc,  vda,vdb,vdc,  sna,snb,snc
      dimension jca(nncp), indv(nnvcp)
!
!     builds velocity matrices given control point positions zvb
!     and far field integrals hv, hbv
!
!     ncnsym  i  i*4  no. of symmetry conditions
!     nnvcp   i  i*4  no. of c.p.'s in current group needing VIC's
!     nvb     i  i*4  no. of cp images with FF VIC data required
!     nnkv    i  i*4  nnvcp*ncnsym, row dimension for several arrays
!     zvb     i  r*8  local coords of cp images for req'd FF VIC evals
!     hv      i  r*8  h  type kernel moments for req'd FF VIC evals
!     hbv     i  r*8  hb type kernel moments for req'd FF VIC evals
!     vsa     o  r*8  source  VIC's for req'd cp's, symmetry folded
!     vsb     l  r*8  source  VIC's for req'd cp images
!     vsc     l  r*8  source  VIC scratch buffer
!     vsa     o  r*8  doublet VIC's for req'd cp's, symmetry folded
!     vdb     o  r*8  doublet VIC's for req'd cp images
!     vsc     l  r*8  doublet VIC scratch buffer
!
!                Following source VIC's are used for AIC' calculation
!                Note that reflection matrices R(i,j) for symmetry
!                conditions (i,j) are NOT applied before folding,
!                although sgnk factors are included
!
!     sna     o  r*8  source VIC's for req'd cp's, symmetry folded
!     snb     l  r*8  source VIC's for req'd cp images
!     snc     l  r*8  source VIC scratch buffer
!
!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 symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!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 sgijk(3,4), sgij(2), sgkar(3,4)
      logical vdblet, vsourc, vsens
!
      kx   =  0
!                                 following code could be moved out
!                                 of here and sgijk could be stored in
!                                 /symm/, say.
      icnsym  =  0
      sgij(1) =  1.d0
      sgij(2) = -1.d0
      do 50 jsymm = 1,njsym
         do 40 isymm = 1,nisym
            icnsym  =  icnsym + 1
            sgnk    =  1.d0
            if ( isymm*misym .eq. -2 ) sgnk = -sgnk
            if ( jsymm*mjsym .eq. -2 ) sgnk = -sgnk
            sgijk(1,icnsym) = sgnk
            sgijk(2,icnsym) = sgnk * sgij(isymm)
            sgijk(3,icnsym) = sgnk * sgij(jsymm)
!
            sgkar(1,icnsym) = sgnk
            sgkar(2,icnsym) = sgnk
            sgkar(3,icnsym) = sgnk
   40    continue
   50 continue
!                                  define assorted scalars
      f1      =  -ajf*rf*sf
      f2      =  -ajf
      f3      =   ajf*rf
      nvb3    =  3*nvb
      nvb5    =  5*nvb
      nvb3x   =  nvb3*ityprc
      nvb5x   =  nvb5*ityprc
!                                  build transposed velocity matrices
      do 140 k = 1,nvb
!                                  row 1 of vs
         vsb(k,1) =  hbv(k, 1) - zvb(k,1)*hv(k,1)
         vsb(k,2) =  hbv(k, 3) - zvb(k,1)*hv(k,2)
         vsb(k,3) =  hbv(k, 5) - zvb(k,1)*hv(k,3)
!                                  row 2 of vs
         vsb(k,4) =  hbv(k, 2) - zvb(k,2)*hv(k,1)
         vsb(k,5) =  hbv(k, 4) - zvb(k,2)*hv(k,2)
         vsb(k,6) =  hbv(k, 6) - zvb(k,2)*hv(k,3)
!                                  row 3 of vs
         vsb(k,7) =  zvb(k,3)*hv(k,1)
         vsb(k,8) =  zvb(k,3)*hv(k,2)
         vsb(k,9) =  zvb(k,3)*hv(k,3)
  140 continue
!                                  DOUBLET VELOCITY
!                                  build vdb if needed
      if ( .not. vdblet ) goto 180
      do 160 k = 1,nvb
         vdb(k, 1) =  vsb(k,7)
         vdb(k, 2) =  0.d0
         vdb(k, 3) =  vsb(k,8)
         vdb(k, 4) =  vsb(k,9)
         vdb(k, 5) =  0.d0
!
         vdb(k, 6) =  0.d0
         vdb(k, 7) =  vsb(k,7)
         vdb(k, 8) =  0.d0
         vdb(k, 9) =  vsb(k,8)
         vdb(k,10) =  vsb(k,9)
!
         vdb(k,11) =  vsb(k,1)
         vdb(k,12) =  vsb(k,4)
         vdb(k,13) =  vsb(k,2)
         vdb(k,14) =  vsb(k,5)+vsb(k,3)
         vdb(k,15) =  vsb(k,6)
  160 continue
!                                  apply transformation matrix
      call hsmmp1 (nvb5x,3,3  ,vdb,1,nvb5x  ,af,1,3  ,vdc,1,nvb5x)
!                                  scatter the vdc data to vdb, applying
!                                  symmetry factors and summing
!                                  up symmetry images along the way
      call vffvs2 (nvb,nnvcp,5,ncnsym,indvb,sgijk  ,vdc,vdb,vda,  kx)
  180 continue
!                                  SOURCE VELOCITY
      if ( (.not.vsourc) .and. (.not.vsens)  ) goto 200
!                                  apply diagonal scaling
      call dscal (nvb3x  ,f1  ,vsb(1,1),1)
      call dscal (nvb3x  ,f2  ,vsb(1,4),1)
      call dscal (nvb3x  ,f3  ,vsb(1,7),1)
!                                  apply transformation matrix
      call hsmmp1 (nvb3x,3,3  ,vsb,1,nvb3x  ,af,1,3  ,vsc,1,nvb3x)
!                                  scatter the vsc data to vsb, applying
!                                  symmetry factors and summing symmetry
!                                  images into vsa.
      if ( .not.vsourc ) goto 200
      call vffvs2 (nvb,nnvcp,3,ncnsym,indvb,sgijk  ,vsc,vsb,vsa,  kx)
!
  200 continue
!                                  SENSITIVITY VIC'S
!                                  build quadratic velocity matrix used
!                                  for sensitivity calculation (AIC')
!                                  via the VIC method
      if ( .not.vsens ) goto 300
!                                  get quadratic terms of source VIC's
      do 250 k = 1,nvb
!                                  row 1 of vs
         snb(k,1) =  hbv(k, 7) - zvb(k,1)*hv(k,4)
         snb(k,2) =  hbv(k, 9) - zvb(k,1)*hv(k,5)
         snb(k,3) =  hbv(k,11) - zvb(k,1)*hv(k,6)
!                                  row 2 of vs
         snb(k,4) =  hbv(k, 8) - zvb(k,2)*hv(k,4)
         snb(k,5) =  hbv(k,10) - zvb(k,2)*hv(k,5)
         snb(k,6) =  hbv(k,12) - zvb(k,2)*hv(k,6)
!                                  row 3 of vs
         snb(k,7) =  zvb(k,3)*hv(k,4)
         snb(k,8) =  zvb(k,3)*hv(k,5)
         snb(k,9) =  zvb(k,3)*hv(k,6)
  250 continue
!                                  scale rows of quadratic VIC src terms
      call dscal (nvb3x  ,f1  ,snb(1, 1),1)
      call dscal (nvb3x  ,f2  ,snb(1, 4),1)
      call dscal (nvb3x  ,f3  ,snb(1, 7),1)
!                                  transform quadratic terms to global
      call hsmmp1 (nvb3x,3,3  ,snb,1,nvb3x  ,af,1,3  ,snc,1,nvb3x)
!                                  build the sna array; use snb to hold
!                                  scattered vsc and snc that is then
!                                  accumulated into sna.
      kz      =  0
      call vffvs2 (nvb,nnvcp,3,ncnsym,indvb,sgkar,vsc,snb,sna(1,1,1),kz)
      call vffvs2 (nvb,nnvcp,3,ncnsym,indvb,sgkar,snc,snb,sna(1,1,4),kz)
  300 continue
!
      return
      END subroutine vffvs1
! **deck vffvs2
      subroutine vffvs2 (nvb,nnvcp,nj,ncnsym,indvb,sgijk                &
     &                  ,vc,vb,va,  kx)
      implicit double precision (a-h,o-z)
      dimension vc(nvb,nj*3), vb(nnvcp*ncnsym,nj*3), va(3,nnvcp,nj)
      dimension indvb(nvb), sgijk(3,ncnsym)
! --- real*8  va, vb, vc
!
!     scatter velocity data, applying symmetry signs and summing
!     up along the way.
!
!     nvb     i  i*4  no. of cp images with FF VIC data required
!     nnvcp   i  i*4  no. of c.p.'s in current group needing VIC's
!     nj      i  i*4  number of basic fcns VIC's depend on
!     ncnsym  i  i*4  no. of symmetry conditions
!     indvb   i  i*4  locations in vb buffer for all FF VIC results
!     sgijk   i  r*8  sign factors for symmetry reflections
!     vc      i  r*8  source/doublet VIC scratch buffer
!     vb      l  r*8  source/doublet VIC's for req'd cp images
!     va      o  r*8  source/doublet VIC's folded and rearranged
!
!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 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
!                                    initialize all VIC symmetry images
      nnvcpx  =  nnvcp*ityprc
      nnkv    =  nnvcp*ncnsym
      nnkvx   =  nnkv*ityprc
      call zero (vb,ityprc*nnvcp*ncnsym*nj*3)
      call zero (va,ityprc*nnvcp*nj*3)
!                                    scatter the VIC data
      nji     =  nj*3
      if ( ityprc.eq.1 )                                                &
     &   call disct1 (nvb,nji  ,vc,nvb  ,indvb  ,vb,nnvcp*ncnsym)
      if ( ityprc.eq.2 )                                                &
     &   call zisct1 (nvb,nji  ,vc,nvb  ,indvb  ,vb,nnvcp*ncnsym)
!                                    accumulate symmetry images
      do 500 i = 1,3
         kvb     =  0
         do 400 icnsym = 1,ncnsym
            sgnx    =  sgijk(i,icnsym)
            do 300 j = 1,nj
               ji      =  j + (i-1)*nj
               do 250 k = 1,nnvcp
                  va(i,k,j) = va(i,k,j) + sgnx*vb(k+kvb,ji)
  250          continue
  300       continue
            kvb     =  kvb + nnvcp
  400    continue
  500 continue
!
      return
      END subroutine vffvs2
! **deck vinchk
      subroutine vinchk (nncp,ncnsym,za,rsqa,ifla,iflb,iflc,jca)
      implicit double precision (a-h,o-z)
      dimension za(3,nncp,ncnsym), rsqa(nncp,ncnsym), ifla(nncp,ncnsym) &
     &        , iflb(nncp,ncnsym), iflc(nncp), jca(nncp)
!
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!call epsff
      common /epsff/ eps1, eps2, eps3, eps4, eps5                       &
     &             , phc1, phc2, phc3
!end  epsff
!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 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 /skrch1/ w(9000000)
!call piccnt
!                                                     /piccnt/
      common /piccnt/ npic(4,7), n56chg(0:3)
!end  piccnt
      dimension ifluar(4), imap(0:7)
      character*3 ch(4)
      logical print
      data imap /0,1,2,3,4,5,6,0/
      data ncall /0/
      data nerr  /0/
      data nersum /0/
      data nulsum /0/
!
      ncall = ncall + 1
!
      call setcor ('vinchk')
      call getcor ('zasv',llzasv,3*nncp*ncnsym)
      call getcor ('zbsv',llzbsv,3*nncp*ncnsym)
      call dcopy (3*nncp*ncnsym,  za,1,  w(llzasv),1)
!
      call CPU_TIME (ta)
      call vinflu (nncp,ncnsym,za,rsqa,ifla,iflb,iflc)
      call CPU_TIME (tb)
!
      call dcopy (3*nncp*ncnsym,  za,1,  w(llzbsv),1)
      call dcopy (3*nncp*ncnsym,  w(llzasv),1,  za,1)
!
      do 100 k = 1,nncp
         call dinflu (za(1,k,1),ifluar,iflumx)
         call icopy (ncnsym,  ifluar,1,  iflb(k,1),nncp)
!---         write (6,6201) k, ifluar(1),ifluar(2), iflumx
  100 continue
      call dcopy (3*nncp*ncnsym,  w(llzbsv),1,  za,1)
 6201 format (' dinflu, iicp:',i5,'  ifluar:',2i5,'  iflumx:',i5)
      call CPU_TIME (tc)
!
      tfast  =  tb-ta
      tslow  =  tc-tb
! ---      write (6,6000) nncp,tfast,tslow
 6000 format ('  vinchk test:',i6,'  fast:',f12.6,'  slow:',f12.6)
 6001 format (2x,i4,4x,a3,1x,a3  ,2i4,3f12.6  ,2(2x,2i2) ,4x,2(2x,2i2) )
!                                    look for error situations
      nerrx = 0
      nnulx = 0
      do 200 k = 1,nncp
!
         print = .false.
         do 150 j  = 1,ncnsym
            ch(j)  =  '   '
            iflax  =  imap( ifla(k,j) )
            iflbx  =        iflb(k,j)
            if ( iflax .ne. iflbx ) then
               if ( iflax.eq.6 .and. iflbx.eq.0 ) then
                  ch(j) = 'nul'
                  nnulx = nnulx + 1
               else
                  ch(j)  =  'err'
                  nerrx  =  nerrx + 1
                  print  =  .true.
               endif
            endif
  150    continue
!
         lzb   =  llzasv + 3*(  k-1 + nncp*(j-1) ) - 1
         if ( print )                                                   &
     &        write (6,6001) k, (ch(j),j=1,2)                           &
     &                        , ipnf, jca(k), (w(lzb+kk),kk=1,3)        &
     &                        , (ifla(k,j),j=1,ncnsym)                  &
     &                       , (iflb(k,j),j=1,ncnsym)
  200 continue
!
      nersum = nersum + nerrx
      nulsum = nulsum + nnulx
      if ( nerrx.gt.0 ) nerr = nerr + 1
      write (7,6101) ncall,nncp, nerr,nerrx,nersum, nnulx,nulsum
      write (6,6101) ncall,nncp, nerr,nerrx,nersum, nnulx,nulsum
 6101 format (' vinchk, call,n:',2i6,'   err,count,tot:',2i6,i9         &
     &       ,'  null count, total:',i6,i9)
      if ( nerr.gt.10 .or. nersum.gt.2000 ) then
         do 400 ii = 1,7
            iix  =  ii - 1
            write (6,6401) iix, npic(1,ii), npic(2,ii)
  400    continue
!
         STOP
!
      endif
 6401 format (' PIC method index:',i6,'  source:',i8,'  doublet:',i9)
!
      call frecor ('vinchk')
      return
      END subroutine vinchk
! **deck vinfcc
      subroutine vinfcc (nwvx)
      implicit double precision (a-h,o-z)
      dimension nwvx(1:*)
!---      dimension nwvx(4*nctrt)
!                                                  ...  mxxscr = 295000
      parameter (mxxscr=295000)
!                                                  ...  mxxcls = 512
      parameter (mxxcls=512)
!                                                  ...  mxxrws = 300
      parameter (mxxrws=300)
!        LOCAL PARAMETERIZED ARRAYS
      dimension indgrp(2*mxxcls)
      dimension iptgrp(2*mxxcls)
      dimension nepha(mxxrws+1), neva(mxxrws+1), indv(mxxrws)
      dimension jca(mxxrws)
!                                                  ... nrzc =8, nizc =12
      parameter (nrzc=8)
      parameter (nizc=12)
      dimension szc(nrzc,mxxrws),   kszc(nizc,mxxrws)
!     icp1    l   i*4  index of the 1st cp in a cp group
!     icp2    l   i*4  index of the last cp in a cp group
!     icpbk   l   i*4  cp block index
!     icpbk1  l   i*4  index of the 1st cp block in a cp group
!     icpbk2  l   i*4  index of the last cp block in a cp group
!     icpgp   l   i*4  cp group index
!     indgrp  l   i*4  global sp indices of the sp's in a panel group
!     ipn1    l   i*4  index of the 1st panel in a panel group
!     ipn2    l   i*4  index of the last panel in a panel group
!     iptgrp  l   i*4  list of global mesh pt indices for a panel group
!     irec    l   i*4  record index on units nsc3, nsc4 to receive
!                      the panel group on cp block influence.  initially
!                      set to 0, it is increased by 1 before each write
!     iszc    l   i*4  index of a cp WITHIN the current cp group
!     jpagp   l   i*4  panel group index
!     kcp1    l   i*4  index for 1st cp in a cp block
!     kcp2    l   i*4  index for last cp in a cp block
!     kcpbk   l   i*4  count of cp's in a cp block
!     kcpgp   l   i*4  count of cp's in a cp group
!     kszc    l   i*4  buffer for integer cp data for cp's in cp group
!     laic    l   i*4  location in w of assembled aic's (target)
!     lphic   l   i*4  start location in w to store phic info
!     lvic    l   i*4  start location in w to store vic  info
!     llaic   l   i*4  address in w for the aic  buffer
!     llphix  l   i*4  address in w for the phix buffer
!     llphic  l   i*4  address in w for the phic buffer
!     llvic   l   i*4  address in w for the vic  buffer
!     locphx  l   i*4  address in w for the phix info for current cp
!                      within the current cp group
!     locphz  l   i*4  address in w for the assembled phix info for
!                      the current cp
!     mxcls   l   i*4  max number of sp's in a panel group
!     mxcpbk  l   i*4  max value of kcpbk for all blocks
!     mxcpgp  l   i*4  max value of kcpgp for all blocks
!     mxrws   l   i*4  max number of aic rows or cp's in a cp group
!     mxxcls  p   i*4  max number of sp's in a panel group
!     mxxrws  p   i*4  max number of aic rows or cp's in a cp group
!     mxxscr  p   i*4  estimate of available scratch memory
!     naicgp  l   i*4  mxrws*mxcls, lth of f.p. data, p-gp/cp-gp influ.
!     nbsqdq  l   i*4  length of panel data blocks on unit nsqb
!     ncpbk   l   i*4  number of cp blocks in current group
!     nebk    l   i*4  cum number of aic rows in a cp block (<=nrpb)
!     negp    l   i*4  cum number of aic rows in a cp group (<=mxrws)
!     nepha   l   i*4  cum ne count in the phic array
!     nesum   l   i*4  count of aic rows in a cp group
!     neva    l   i*4  cum ne count in the vic array
!     nisc3   l   i*4  index array for pic scratch unit nsc3 [12]
!     nisc4   l   i*4  index array for phx scratch unit nsc4 [14]
!     nncp    l   i*4  number of cp's in current group
!     npagp   i   i*4  number of panel groups
!     npn     l   i*4  number of panels in the current panel group
!     npt     l   i*4  number of meshpoints for current panel group
!     nrb     l   i*4  cum counter of aic rows in a cp block
!     nrpb    l   i*4  max number of rows in a cp block; defined so that
!                      nrpb*( mxcls + nsngt ) + nsngt < nscr
!     nscr    l   i*4  = mxxscr, estimate of available scratch
!     nsp     l   i*4  number of sp's in the current panel group
!     nvdq    o   i*4  length of records on unit ntv [4,/vrwi/]
!     nwpb    l   i*4  (nrpb+1)*mxcls, size of each write buffer to nsc3
!     nwvx    s   i*4  [icpgpk, icpbkk, ne, jc] for each control pt
!     pblock  i   log  panel blocking indicator (obs)
!     pfmpbl  i   log  flag for performing panel blocking (.false.)
!     rlse12  l   log  flag indicating that unit nsc3=12 be deleted
!     rlse14  l   log  flag indicating that unit nsc4=14 be deleted
!     strbuf  l   r*8  scratch array for reading panel data from nsqg
!     szc     l   r*8  buffer for real cp data for cp's in cp group
!
!ca locinf
!                                                         /locinf/
      common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i
      double precision rlocdm
!end  locinf
!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 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 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
!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
!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 solnt
      common/solnt/naic,nrhs,nans,nsc1,nsc2,nsc3,nsc4,iray(10),mtitle(5)
!end  solnt
!call skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!call mspnts
      common/mspnts/zm(3,maxpts)
!end  mspnts
!call gbnejc
!                                                            /gbnejc/
      common /gbnejc/ icpgpk, icpbkk, ne, jc
!end  gbnejc
!
!call prnt
      common /prnt/ igeomp,   isingp,   icontp,   ibconp,   iedgep,     &
     &              isings,   ipraic,   ipartp,   iparts                &
     &        , ioutpr,  ifmcpr,  icostp,  iextrp,  ispmap              &
     &        , icpmap,  ibcmap
!end  prnt
!call pblprm
!                                                         /pblprm/
      common /pblprm/ mxcls
!                                                         /pblprm/
!end  pblprm
!call vrwi
      common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp)
!end  vrwi
!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
!call gsqrwi
      parameter (npagpx=400)
      common /gsqrwi/ nsqg, npagp, npngrp(npagpx), nspgrp(npagpx)       &
     &              , ndsgrp, nptgrp(npagpx)
!end  gsqrwi
!call bsqrwi
      common /bsqrwi/ nbsqdq, nsqb
!end  bsqrwi
!call kstrns
      common /kstrns/ nstrns, mstrns
!end  kstrns
!call psdflg
      common /psdflg/ psdpan
      integer psdpan
!end  psdflg
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!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
      logical rlse12
      logical rlse14
      logical astcpx, ltewic
      logical debug, dbgprt
      dimension qd(3,9)
      dimension nisc3(12001)
      dimension nisc4(12001)
      dimension ncalw(3), nwrdw(3)
      dimension strbuf(1024)
!!      dimension ifluar(2,2)                                               ! Removed by Martin Hegedus, 4/21/09
      dimension ifluar(4)                                                 ! Added by Martin Hegedus, 4/21/09
!
      debug = .false.
!--      debug = .true.
      dbgprt = .false.
!--      dbgprt = .true.
      call setcor ('vinfcc')
      call CPU_TIME (tasetp)
      rlse12  =  .true.
      rlse14  =  .true.
      call jzero (ncalw,3)
      call jzero (nwrdw,3)
      nbsqdq  =  locfcn(qa) - locfcn(cp)
      call dlocfx (nbsqdq)
!                                    count real words (change for cray)
      nbsqdq  =  (nbsqdq+kklr2i-1)/kklr2i
      write (6,'( '' size of records written by pvinfc '',i6)')nbsqdq
!                                  initialize /psdflg/ and /kstrns/
      psdpan  =  0
      nstrns  =  0
      mstrns  =  0
!                                  set /pblprm/ parameters
      mxrws   =  mxxrws
      mxcls   =  mxxcls
      nscr    =  mxxscr
!                                  open the scratch aic file
      call openms (nsc3,nisc3,12001,0)
      call openms (nsc4,nisc4,12001,0)
      call openms (ntphx,niphx,nnphx,0)
      naicgp  =  mxrws*mxcls*ityprc
      if ( naicgp+mxcls .gt. nscr ) CALL AbortPanair('vinfcc')
      nvdq    =  nsngt
!                                  define the panel groups
      call pvinfc
!                                  get max pt count for all panel groups
      mxptgp  =  0
      do 20 jpagp = 1,npagp
         mxptgp  =  max ( mxptgp, nptgrp(jpagp))
   20 continue
!                                  define the control point groups and b
      nrpb    =  (nscr - mxcls)/( ityprc*(mxcls+nsngt) )
      nrpb    =  min( nrpb, mxrws)
      nwpb    =  mxcls*(1 + ityprc*nrpb)
      kcpgp   =  mxrws + 1
      negp    =  mxrws + 1
      nebk    =  mxrws + 1
      icpbk   =  0
      icpgp   =  0
      mxcpgp  =  0
      mxcpbk  =  0
      kcpbk   =  0
!--      write (6,6000)
!
      do 100 jcx = 1,nctrt
          call ctrns (jcx,zc)
          jc      =  jcn
          ne      =  nec
          icpgpk  =  100000
          icpbkk  =  100000
!-------- if ( nec.eq.0 .and. nbinmc.eq.0 ) go to 90
          if ( nec.lt.1 ) goto 90
!                                  control point is to be added to the l
!                                  of control points requiring processin
!                                  get the group and block indices right
          if ( negp+ne.le.mxrws .and. kcpgp+1.le.mxrws ) go to 50
!                                  new group
                    icpgp   =  icpgp + 1
                    kcpgp   =  0
                    negp    =  0
                    icpbk   =  icpbk + 1
                    nebk    =  0
                    kcpbk   =  0
                    go to 80
!
   50     continue
          if ( nebk+ne.le.nrpb ) go to 80
!                                  new block
               icpbk   =  icpbk + 1
               nebk    =  0
               kcpbk   =  0
   80     continue
          negp    =  negp + ne
          nebk    =  nebk + ne
          kcpgp   =  kcpgp + 1
          kcpbk   =  kcpbk + 1
          icpbkk  =  icpbk
          icpgpk  =  icpgp
          mxcpgp  =  max ( mxcpgp, kcpgp)
         mxcpbk  =  max ( mxcpbk, kcpbk )
!
   90     continue
          call icopy (4,  icpgpk,1, nwvx(4*jc-3),1)
          if ( jc.gt.nctrt ) call a502er ('vinfcc'                      &
     &       ,'c.p. index jc exceeds admissable nctrt limit')
!--          write (6,6001) jcx, icpgpk, icpbkk, ne, jc, kcpbk, kcpgp
  100 continue
      call shlsr2 (nctrt,nwvx)
         write (6,6002) mxcpgp, mxcpbk, kcpbk
 6000 format (2x,'     jcx  icpgpk  icpbkk      ne       jc'            &
     & ,'   kcpbk   kcpgp')
 6001 format (2x,7i8)
 6002 format (' mxcpgp:',i8,' mxcpbk:',i8,'  kcpbk:',i8)
      nwphix  =  mxptgp*( 1 + 3*mxcpbk )
!                                  for each cp group, define its limits
!                                  process it.
      ncpgp   =  icpgp
      ncpbkc  =  icpbk
      ncpbkw  =  icpbk
      icpgp   =  0
      icp2    =  0
      call CPU_TIME (tbsetp)
      tsetp   =  tbsetp - tasetp
      tkrn    =  0.d0
      tvel    =  0.d0
      tvsp    =  0.d0
      tvin    =  0.d0
      tphi    =  0.d0
      tnear   =  0.d0
      tpic    =  0.d0
      twric   =  0.d0
      trdic   =  0.d0
!
!                                  if-loop on c.p. groups
  200 continue
      icpgp   =  icpgp + 1
      if ( icpgp.gt.ncpgp ) go to 2000
      icp1    =  icp2 + 1
      if ( icp1.gt.nctrt ) go to 2000
      call icopy (4,  nwvx(4*icp1-3),1, icpgpk,1)
      if ( icpgpk.ne.icpgp ) call a502er ('vinfcc'                      &
     &                      ,'control point groups out of synch')
      icpbk1  =  icpbkk
      nncp    =  0
      nnvcp   =  0
!                                  get c.p. index limits of current gp
      do 220 icp = icp1,nctrt
          call icopy (4,  nwvx(4*icp-3),1, icpgpk,1)
          if ( icpgpk.ne.icpgp ) go to 225
          iszc    =  icp - icp1 + 1
          icp2    =  icp
          icpbk2  =  icpbkk
          nepha(iszc) = nncp
          neva (iszc) = 3*nnvcp
          jca(iszc)   = jc
          if ( ne.lt.0 ) call a502er ('vinfcc','null aic cp found')
          nncp    =  nncp + 1
          if ( ne.gt.1 ) then
             nnvcp  = nnvcp + 1
             indv(nnvcp) = nncp
          endif
!----          write (6,9301) icp,  icpgpk,icpbkk,ne,jc
 9301 format (' icp',i4,'  gp,bk,ne,jc:',4i6)
  220 continue
  225 continue
      if ( dbgprt ) call outvci ('jca',nncp,jca)
      ncpbk =  icpbk2 - icpbk1 + 1
      nncpx =  icp2 - icp1 + 1
      if ( nncp.ne.nncpx ) call a502er ('vinfcc',' nncp .ne. nncpx ')
!
      nephsm  =  nncp
      nevsm   =  3*nnvcp
      nesum   =  nephsm + nevsm
!
      nepha(nncp+1) = nephsm
      neva (nncp+1) = nevsm
!                                  get data into szc for current group
      do 250 icp = icp1,icp2
          iszc    =  icp - icp1 + 1
          call icopy (4,  nwvx(4*icp-3),1, icpgpk,1)
          call ctrns (jc,zc)
          call dcopy (nrzc,   zc,1,   szc(1,iszc),1)
          call icopy (nizc,  ipc,1,  kszc(1,iszc),1)
  250 continue
!                                  allocate memory for cp group calc.
      call setcor ('cp-group')
      ncnsym  =  nisym*njsym
      nnza    =  nncp*ncnsym
      call getcor ('za',llza,3*nnza)
      call getcor ('rsqa',llrsqa,nnza)
      call igtcor ('ifla',llifla,nnza)
      call igtcor ('iflb',lliflb,nnza)
      call igtcor ('iflc',lliflc,nnza)
!                                  setup call to vffkrn
      nnzax   =  nnza*ityprc
      nnvcps  =  nnvcp*ncnsym
      nnvcpx  =  nnvcps*ityprc
!                                  output arrays, vffkrn
      call getcor ('hk',llhk,nnzax*6)
      call getcor ('gk',llgk,nnzax*6)
      call getcor ('hkb',llhkb,nnzax*6)
      call getcor ('gkb',llgkb,nnzax*6)
      call getcor ('hkph',llhkph,nncp*ityprc*6)
      call getcor ('gkph',llgkph,nncp*ityprc*6)
!                                  scratch memory for vffkrn
      call igtcor ('indb',llindb,nnza)
      call getcor ('rsqb',llrsqb,nnza)
      call getcor ('zb',  llzb,  nnza*3)
      call getcor ('p1',  llp1,  nnza)
      call getcor ('p2',  llp2,  nnza)
!
      call getcor ('ps0', llps0, nnzax)
      call getcor ('ps1', llps1, nnzax)
      call getcor ('ps2', llps2, nnzax)
      call getcor ('ps3', llps3, nnzax)
!
      call getcor ('xb',  llxb,  nnza)
      call getcor ('yb',  llyb,  nnza)
      call getcor ('xxb', llxxb, nnza)
      call getcor ('xyb', llxyb, nnza)
      call getcor ('yyb', llyyb, nnza)
!                                  scratch for vffpin call
      call getcor ('phs' ,llphs, ityprc*nncp*9)
      call getcor ('phd' ,llphd, ityprc*nncp*21)
      call getcor ('ph'  ,llph,  ityprc*nncp*30)
!                                  output arrays for vffvel
      if ( nnvcp.le.0 ) goto 260
         call getcor ('vsa' ,llvsa , 9*ityprc*nnvcp)
         call getcor ('vda' ,llvda ,15*ityprc*nnvcp)
         call getcor ('sna' ,llsna ,18*ityprc*nnvcp)
         call getcor ('vsb' ,llvsb , 9*nnvcpx)
         call getcor ('vdb' ,llvdb ,15*nnvcpx)
         call getcor ('snb' ,llsnb , 9*nnvcpx)
         call getcor ('vsc' ,llvsc , 9*nnvcpx)
         call getcor ('vdc' ,llvdc ,15*nnvcpx)
         call getcor ('snc' ,llsnc , 9*nnvcpx)
!                                  scratch memory for vffvel call
         call igtcor ('flva',llflva,nnvcp*ncnsym)
         call igtcor ('flvb',llflvb,nnvcp*ncnsym)
         call igtcor ('ndb', llndb ,nnvcp*ncnsym)
         call igtcor ('indva',llndva,nnvcps)
         call igtcor ('indvb',llndvb,nnvcps)
         call getcor ('zvb' ,llzvb , 3*nnvcps)
         call getcor ('hkv' ,llhkv , 6*nnvcpx)
         call getcor ('hbv' ,llhbv ,12*nnvcpx)
         call getcor ('hv'  ,llhv  , 6*nnvcpx)
!                                  scratch for vffvin call
         call getcor ('va'  ,llva,  3*ityprc*nncp*30)
  260 continue
!                                  rewind files associated with panel
!                                  groups and blocks
      rewind nsqg
      rewind nsqb
      irec    =  0
!                                  loop over panel groups
      ipn2   =  0
!                                  loop over panel groups
      do 1000 jpagp = 1,npagp
      call setcor ('pic-pngp')
      nnphic  =  ityprc*nephsm*mxcls
      nnvic   =  ityprc*nevsm *mxcls
      if ( nephsm.gt.0) call getcor ('phic',llphic,nnphic)
      if ( nevsm .gt.0) call getcor ('vic' ,llvic ,nnvic)
      call zero (w(llphic),nnphic)
      call zero (w(llvic), nnvic)
!                                  debug copies
      llphiq  =  llphic
      llviq   =  llvic
      if ( debug ) then
         if ( nephsm.gt.0) call getcor ('phiq',llphiq,nnphic)
         if ( nevsm .gt.0) call getcor ('viq' ,llviq ,nnvic)
         call zero (w(llphiq),nnphic)
         call zero (w(llviq), nnvic)
      endif
!
      nsp    =  nspgrp(jpagp)
      npn    =  npngrp(jpagp)
      npt     =  nptgrp(jpagp)
      call jzero (indgrp,mxcls)
      read (nsqg) (indgrp(i),i=1,nsp)
      read (nsqg) (iptgrp(i),i=1,npt)
      if ( dbgprt ) call outvci ('indgrp',nsp,indgrp)
      if ( dbgprt ) call outvci ('iptgrp',npt,iptgrp)
      if ( ndsgrp.ne.0 ) then
!                                 allocate enough memory so that if the
!                                 last cp block overflows w, we will
!                                 find out about it here
!                                 VERY BIZARRE CODE --- FIGURE THIS OUT
!                                 THERE SEEMS TO BE AN ASSUMPTION THAT
!                                 PHIX IS THE LAST ARRAY
         nphix  =  mxptgp +                                             &
     &             ityprc*3*( mxptgp*mxcpbk + npt*max(0,nncp-mxcpbk) )
         call getcor ('phix',llphix,nphix)
         call zero (w(llphix),nphix)
         call icopy (npt,  iptgrp,1,  w(llphix),1)
!--   write (6,'('' initializing ipagp='',i5,'' npt,mxptgp,nncp'',3i5)')
!--  x        ipagp,npt,mxptgp,nncp
      endif
      ipn1   =  ipn2 + 1
      ipn2   =  ipn2 + npn
!                                  loop on panels within a group
      call CPU_TIME (tapic)
      do 700 ip = ipn1,ipn2
      read (nsqb) (strbuf(i),i=1,nbsqdq)
      call dcopy (nbsqdq,  strbuf,1,  cp,1)
      call stunpk (strbuf)
      call psddq5
      nstrns  =  nstrns + 1
!                                  unstdy wake nw's have complex splines
      astcpx  =  .false.
      call qtewic (ltewic)
!--      if ( ntd(kpf).eq.8  .or. ntd(kpf).eq.10  .or.
!--     x     ntd(kpf).eq.18 .or. ntd(kpf).eq.20       ) astcpx = .true.
      if ( ndsgrp.ne.0 ) then
         read (nsqb) wpdn, wsdn, iiptdn, iipgdn
         call dcopy (3*9,  0.d0,0,  qd,1)
         call panpwm (ics,cp  ,en,ar,aj,wsdn                            &
     &               ,wcdn,wcsdn,acdn,acsdn                             &
     &               ,qd)
      endif
!                                  checkout of vectorized influence test
      call mcopy (3,nncp,  szc,1,nrzc,  w(llza),1,3)
      call CPU_TIME (ta)
!--      call vinchk (nncp,ncnsym,w(llza),w(llrsqa),w(llifla),w(lliflb)
!--     x            ,w(lliflc),jca )
      call vinflu (nncp,ncnsym,w(llza),w(llrsqa),w(llifla),w(lliflb)    &
     &            ,w(lliflc))
      call CPU_TIME (tb)
      tvin = tvin + tb-ta
!                                  use pivc for panels w wake filaments
      if ( ltewic ) goto 480
!                                  evaluate far-field kernel moments
      call CPU_TIME (ta)
      call vffkrn (nncp,nnvcp,ncnsym,w(llza),w(llrsqa),w(llifla)        &
     &            ,w(llhk),w(llgk)  ,w(llhkph),w(llgkph)                &
     &            ,w(llindb),w(llrsqb),w(llzb)  ,w(llhkb),w(llgkb)      &
     &            ,w(llp1),w(llp2)  ,w(llps0),w(llps1),w(llps2),w(llps3)&
     &            ,w(llxb),w(llyb)  ,w(llxxb),w(llxyb),w(llyyb)         &
     &            ,jca                                                  &
     &            )
      call CPU_TIME (tb)
      tkrn  =  tkrn + tb-ta
      call vffpev (nncp,jca ,w(lliflc) ,w(llgkph),w(llhkph)             &
     &            ,w(llphs),w(llphd)  ,w(llphic),astcpx)
      call CPU_TIME (tc)
      tphi  =  tphi + tc-tb
      ta   =  tc
!                                  setup call to vffvel
      if ( nnvcp.le.0 ) goto 450
      call CPU_TIME (ta)
      call vffvel (nncp,nnvcp,ncnsym                                    &
     &            ,w(llhk),w(llza),w(llifla),indv,w(llflva),w(llflvb)   &
     &            ,w(llvsa),w(llvda),w(llsna)                           &
     &            ,w(llndva),w(llndvb),w(llndb),w(llzvb),w(llhkv)       &
     &                                          ,w(llhbv),w(llhv)       &
     &         ,w(llvsb),w(llvsc) ,w(llvdb),w(llvdc) ,w(llsnb),w(llsnc) &
     &         ,jca)
      call CPU_TIME (tb)
      call vffvin (nnvcp,w(llvsa),w(llvda),w(llva),w(llvic),astcpx)
      call CPU_TIME (tc)
      tvel = tvel + tb-ta
      tvsp = tvsp + tc-tb
  450 continue
!                                  loop on c.p.'s within a group
  480 continue
      call CPU_TIME (ta)
      do 500 icp = icp1,icp2
      call icopy (4,  nwvx(4*icp-3),1, icpgpk,1)
      iszc    =  icp - icp1 + 1
      call vinicp (nncp,ncnsym,w(llifla),  iszc,ltewic,  ifluar,iflumx)
      if ( iflumx.le.0 ) goto 500
      call dcopy (nrzc,   szc(1,iszc),1,   zc,1)
      call icopy (nizc,  kszc(1,iszc),1,  ipc,1)
!                                  llphiq = llphic; llviq = llvic
!                                  unless debug was set .true.
      lphic    =  llphiq + ityprc*nepha(iszc)
      lvic     =  llviq  + ityprc*neva (iszc)
!
      locphx   =  llphix + ityprc*( npt + 3*npt*(icp-icp1) )
!                                  regular aic computation
      if ( ne.gt.0 )                                                    &
     &    call pivc (ne ,nncp,w(lphic) ,nnvcp,w(lvic) ,npt,w(locphx)    &
     &              ,ifluar,iflumx,astcpx)
!                                  end loop on control points
  500 continue
      call CPU_TIME (tb)
      tnear = tnear + tb-ta
!                                  end, loop on panels within a block
  700 continue
      call CPU_TIME (tbpic)
      tpic  =  tpic + tbpic-tapic
!
      if ( dbgprt ) then
!                                  print first two columns of ph and v
         call difmat ('phic-phiq',nncp,mxcls,w(llphic),w(llphiq))
         call difmat ('vic-viq',3*nnvcp,mxcls,w(llvic),w(llviq))
         lphic = llphic + 42*nncp
         lphiq = llphiq + 42*nncp
         lvic  = llvic + 42*nevsm
         lviq  = llviq + 42*nevsm
         call outmtx ('phic',nncp,nncp,10,w(lphic))
         call outmtx ('phiq',nncp,nncp,10,w(lphiq))
         call outmtx ('vic' ,nevsm,nevsm,10,w(lvic))
         call outmtx ('viq' ,nevsm,nevsm,10,w(lviq))
      endif
!
      if ( debug ) then
         call daxpy (nnphic,   -1.d0,  w(llphic),1,  w(llphiq),1)
         iphmax  =  idamax(nnphic,w(llphiq),1)
         ephmax  =  w(llphiq+iphmax-1)
         call daxpy (nnvic,   -1.d0,  w(llvic),1,  w(llviq),1)
         ivmax  =  idamax(nnvic,w(llviq),1)
         evmax  =  w(llviq+ivmax-1)
         write(7,'('' ERROR SUMMARY: ph, v -'',1p,2e12.4)') ephmax,evmax
      endif
!--   write(7,'('' TIMING SUMMARY: vin,krn,phi,vel,vsp,near-'',6f12.6)')
!--  x         tvin,tkrn,tphi,tvel,tvsp,tnear
!                                  write out a buffer
      kcp2    =  icp1 - 1
!                                  loop on c.p. blocks within a group
      call getcor ('aic',llaic,nwpb)
      call icopy (mxcls,  indgrp,1,  w(llaic),1)
      call CPU_TIME (tawric)
      do 800 icpbk = icpbk1,icpbk2
      irec    =  irec + 1
      kcp1   =  kcp2 + 1
!                                  loop on c.p.'s within a block
      laic    =  llaic + mxcls
      incv    =  nevsm
      do 750 icp = kcp1,icp2
      call icopy (4,  nwvx(4*icp-3),1, icpgpk,1)
      if ( icpbkk.ne.icpbk ) go to 760
      iszc    =  icp - icp1 + 1
      lphic   =  llphic + nepha(iszc)*ityprc
      lvic    =  llvic  + neva (iszc)*ityprc
      if (ne.gt.0) then
         if ( ityprc.eq.1 )                                             &
     &      call dcopy (mxcls,  w(lphic),nncp,  w(laic),1)
         if ( ityprc.eq.2 )                                             &
     &      call zcopy (mxcls,  w(lphic),nncp,  w(laic),1)
         if ( jc.eq.ipraic ) then
            call outvci ('indgrp',nsp,indgrp)
            call outmtx ('aic',ityprc,ityprc,nsp,w(laic))
         endif
!+++         call zcopy (mxcls,  w(lphic),nncp,  w(laic),1)
         laic    =  laic + ityprc*mxcls
      endif
      if (ne.gt.1) then
         if ( ityprc.eq.1 )                                             &
     &      call mcopy (mxcls,3,  w(lvic),incv,1,  w(laic),1,mxcls)
         if ( ityprc.eq.2 )                                             &
     &      call mccopy (mxcls,3,  w(lvic),incv,1,  w(laic),1,mxcls)
!+++         call mccopy(mxcls,3, w(lvic),incv,1, w(laic),1,mxcls)
         laic    =  laic + ityprc*3*mxcls
      endif
      kcp2    =  icp
  750 continue
  760 continue
      call writmd (nsc3,  w(llaic),nwpb,irec,-1,0)
      kcpbk   =  kcp2-kcp1+1
      if ( ndsgrp.ne.0 ) then
         locphx  =  llphix + npt + ityprc*3*npt*(kcp1-icp1)
         locphp  =  locphx - npt
         call icopy (npt,  iptgrp,1,  w(locphp),1)
         call writmd (nsc4, w(locphp), nwphix, irec, -1,0)
      endif
      ncalw(1)=  ncalw(1) + 1
      nwrdw(1)=  nwrdw(1) + nwpb
!                                  end, loop on cp blocks
  800 continue
      call CPU_TIME (tbwric)
      twric  =  twric + tbwric-tawric
!                                  end, loop on groups of panels
      call frecor ('pic-pngp')
 1000 continue
!
      call frecor ('cp-group')
!                                 if required, assemble phix influences
      call CPU_TIME (tardic)
      if ( ndsgrp.eq.0 ) goto 1190
      call setcor ('pic-dsnb')
      call getcor ('phix',llphix, nwphix )
      call getcor ('phiz',llphiz, 3*nzmpt*mxcpbk)
!                                 loop over control point blocks
      kcp2    =  icp1 - 1
      do 1180 icpbk = icpbk1,icpbk2
!                                 identify the current c.p. block
         kcp1    =  kcp2 + 1
         do 1050 icp = kcp1,icp2
            call icopy (4,  nwvx(4*icp-3),1,  icpgpk,1)
            if ( icpbkk.ne.icpbk ) goto 1060
            kcp2    =  icp
 1050    continue
 1060    continue
         kcpbk   =  kcp2 - kcp1 + 1
!                                 accumulate all group on block influ-
!                                 ences for the current c.p. block
      if ( kcpbk .gt. mxcpbk ) CALL AbortPanair('vinfcc')
         call zero (w(llphiz),3*nzmpt*kcpbk)
         do 1100 jpagp = 1,npagp
            npt     =  nptgrp(jpagp)
               irec    =  (icpbk-icpbk1 + 1) + (jpagp-1)*ncpbk
            call readmd (nsc4,w(llphix),nwphix,irec)
            call icopy (npt,  w(llphix),1,  iptgrp,1)
            call cpbphx (npt,nzmpt,kcpbk,iptgrp,w(llphix+npt),w(llphiz))
 1100    continue
!                                 write the records for the current blk
         do 1150 icp = kcp1,kcp2
            call icopy (4,  nwvx(4*icp-3),1,  icpgpk,1)
            locphz    =  llphiz + 3*nzmpt*(icp-kcp1)
            call writmd (ntphx,w(locphz),3*nzmpt,jc,  -1,0)
            call ctrns (jc,zc)
 1150    continue
 1180 continue
      call frecor ('pic-dsnb')
 1190 continue
!                                  read file nsc3.and write the results
!                                  on the aic file
      kcp2    =  icp1 - 1
!                                  loop on c.p. blks in current c.p. gro
      call setcor ('cpbcum')
      call getcor ('ind', llind,  nwpb)
      call getcor ('b'  , llb,    ityprc*nsngt*nrpb)
      call getcor ('cvic',llcvic, 4*ityprc*nsngt)
      do 1900 icpbk = icpbk1,icpbk2
          kcp1    =  kcp2 + 1
          do 1200 icp = kcp1,icp2
               call icopy (4,  nwvx(4*icp-3),1, icpgpk,1)
               if ( icpbkk.ne.icpbk ) go to 1210
               kcp2    =  icp
 1200     continue
 1210     continue
          inirec  =  icpbk - icpbk1 + 1
          increc  =  ncpbk
          ncalw(2)=  ncalw(2) + npagp
          nwrdw(2)=  nwrdw(2) + nwpb*npagp
          ncp     =  kcp2 - kcp1 + 1
          ncalw(3)=  ncalw(3) + ncp
          lla     =  llind + mxcls
          call cpbcum (nsc3,inirec,increc,nwpb,mxcls,w(llind),w(lla)    &
     &                ,w(llb),nsngt,nrpb,  w(llcvic)                    &
     &                ,npagp,nspgrp                                     &
     &                ,kcp1,kcp2,nwvx,nrb)
          nwrdw(3)=  nwrdw(3) + ityprc*nsngt*nrb
 1900 continue
      call CPU_TIME (tbrdic)
      trdic = trdic + tbrdic-tardic
      call frecor ('cpbcum')
      go to 200
!
 2000 continue
      write (6,6100) ncalw,nwrdw
 6100 format (2x,10hi/o calls ,3i10,/,2x,10hi/o words ,3i10 )
      npabk   =  0
      write (6,6200) mxrws,mxcls,npagpx,nrpb,ncpbkc,ncpbkw,ncpgp,npabk  &
     &             , npagp
 6200 format (2x                                                        &
     &,60h     mxrws     mxcls    mxblks      nrpb    ncpbkc    ncpbkw  &
     &,40h     ncpgp     npabk     npagp          ,/,2x,10i10)
      write (6,6300) nstrns,mstrns
 6300 format ('  strns calls  type 5/6 =',i5,'   type 6 =',i5)
!
      write(7,'('' TIMING SUMMARY: vin,krn,phi,vel,vsp,near-'',6f12.6)')&
     &         tvin,tkrn,tphi,tvel,tvsp,tnear
      write(7,'('' TIMING SUMMARY: setup,pic-s,block,assy-'',4f12.6)')  &
     &         tsetp,tpic,twric,trdic
!                                  put ne into nwvx
      do 2100 i = 1,nctrt
          call icopy (4,  nwvx(4*i-3),1, icpgpk,1)
          nwv(jc)=  ne
 2100 continue
      call writms (ntv,nwv,nctrt,nctrt+1,-1,0)
      if ( rlse12 ) then
         close (nsc3,status='delete')
      else
         call closms (nsc3)
      endif
      if ( rlse14 ) then
         close (nsc4,status='delete')
      else
         call closms (nsc4)
      endif
!
      call closms (ntphx)
      call frecor ('vinfcc')
!
      return
      END subroutine vinfcc
! **deck vinflu
      subroutine vinflu (nncp,ncnsym,za,rsqa,ifla,iflb,iflc)
      implicit double precision (a-h,o-z)
      dimension za(3,nncp,ncnsym)                                       &
     &        ,  ifla(nncp,ncnsym), rsqa(nncp,ncnsym)                   &
     &        , iflb(nncp*ncnsym), iflc(nncp)
!
!     perform the influence test for a group of control points in vector
!     mode.
!
!call piccnt
!                                                     /piccnt/
      common /piccnt/ npic(4,7), n56chg(0:3)
!end  piccnt
!call epsff
      common /epsff/ eps1, eps2, eps3, eps4, eps5                       &
     &             , phc1, phc2, phc3
!end  epsff
!call symm
      common /symm/ nsymm, ictsym, nisym, njsym, misym, mjsym
!end  symm
!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 skrch1
      common /skrch1/ w(9000000)
!end  skrch1
      dimension ifmap(0:7), iflcnt(0:7)
      logical syncff
!
      data ifmap / 0,1,2,3  ,0,0,0,0 /
      data syncff /.false./
!
!
      call setcor ('vinflu')
!
      if ( amach.gt.1.d0 ) goto 500
!
!                                  SUBSONIC INFLUENCE TESTS
!
!                                  Generate control point images
      if ( nisym.gt.1 .and. njsym.gt.1 ) then                             ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nncp,  za(1,1,1),1,  za(1,1,2),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (  nncp,  -1.d0,        za(2,1,2),3)                  ! Added by Martin Hegedus, 4/21/09
         call dcopy (6*nncp,  za(1,1,1),1,  za(1,1,3),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (2*nncp,  -1.d0,        za(3,1,3),3)                  ! Added by Martin Hegedus, 4/21/09
      elseif ( nisym.gt.1 ) then                                          ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nncp,  za(1,1,1),1,  za(1,1,2),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (  nncp,  -1.d0,        za(2,1,2),3)                  ! Added by Martin Hegedus, 4/21/09
      elseif ( njsym.gt.1 ) then                                          ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nncp,  za(1,1,1),1,  za(1,1,2),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (  nncp,  -1.d0,        za(3,1,2),3)                  ! Added by Martin Hegedus, 4/21/09
      endif                                                               ! Added by Martin Hegedus, 4/21/09
!!      if ( nisym.gt.1 ) then                                              ! Removed by Martin Hegedus, 4/21/09
!!!                                  1st p-o-s: copy and reflect y coord    ! Removed by Martin Hegedus, 4/21/09
!!         call dcopy (3*nncp,  za(1,1,1),1,  za(1,1,2),1)                  ! Removed by Martin Hegedus, 4/21/09
!!         call dscal (  nncp,  -1.d0,        za(2,1,2),3)                  ! Removed by Martin Hegedus, 4/21/09
!!         if ( njsym.gt.1 ) then                                           ! Removed by Martin Hegedus, 4/21/09
!!!                                  2nd p-o-s: copy and reflect z coord    ! Removed by Martin Hegedus, 4/21/09
!!            call dcopy (6*nncp,  za(1,1,1),1,  za(1,1,3),1)               ! Removed by Martin Hegedus, 4/21/09
!!            call dscal (2*nncp,  -1.d0,        za(3,1,3),3)               ! Removed by Martin Hegedus, 4/21/09
!!         endif                                                            ! Removed by Martin Hegedus, 4/21/09
!!      endif                                                               ! Removed by Martin Hegedus, 4/21/09
!                                  perform influence tests
      n       =  ncnsym*nncp
      call getcor ('v',llv,5*n)
      call vinsub (nncp*ncnsym,  za,rsqa,ifla                           &
     &            ,w(llv),w(llv+n),w(llv+2*n) )
!
      goto 950
!
!                                  SUPERSONIC INFLUENCE TESTS
!
  500 continue
! NOTE: imaging control points must be done so other routines get values  ! NOTE by Martin Hegedus, 4/21/09
!       which are not garbage, such as NANs                               ! NOTE by Martin Hegedus, 4/21/09
!                                  Generate control point images          ! Added by Martin Hegedus, 4/21/09
      if ( nisym.gt.1 .and. njsym.gt.1 ) then                             ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nncp,  za(1,1,1),1,  za(1,1,2),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (  nncp,  -1.d0,        za(2,1,2),3)                  ! Added by Martin Hegedus, 4/21/09
         call dcopy (6*nncp,  za(1,1,1),1,  za(1,1,3),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (2*nncp,  -1.d0,        za(3,1,3),3)                  ! Added by Martin Hegedus, 4/21/09
      elseif ( nisym.gt.1 ) then                                          ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nncp,  za(1,1,1),1,  za(1,1,2),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (  nncp,  -1.d0,        za(2,1,2),3)                  ! Added by Martin Hegedus, 4/21/09
      elseif ( njsym.gt.1 ) then                                          ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nncp,  za(1,1,1),1,  za(1,1,2),1)                  ! Added by Martin Hegedus, 4/21/09
         call dscal (  nncp,  -1.d0,        za(3,1,2),3)                  ! Added by Martin Hegedus, 4/21/09
      endif                                                               ! Added by Martin Hegedus, 4/21/09
!                                  perform the first pass test
!                                  on the principle image generating
!                                  an index
      call igtcor ('indb',llindb,nncp)
      call vinsp1 (nncp,  za,rsqa,  w(llindb),nndb)
!                                  initialize to null influence and
!                                  skip the remainder if there is no
!                                  influence at all
      call icopy (nncp*ncnsym,  7,0,  ifla,1)
      if ( nndb.le.0 ) goto 950
!                                  generate the short list of c.p.'s
      call getcor ('zb',llzb,3*ncnsym*nndb)
      call vinsp2 (za,  w(llindb),nndb,  w(llzb))
!                                  generate the images of the short list
      if ( nisym.gt.1 .and. njsym.gt.1 ) then                             ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nndb,  w(llzb),1,  w(llzb+3*nndb),1)               ! Added by Martin Hegedus, 4/21/09
         call dscal (  nndb,  -1.d0,      w(llzb+3*nndb+1),3)             ! Added by Martin Hegedus, 4/21/09
         call dcopy (6*nndb,  w(llzb),1,  w(llzb+6*nndb),1)               ! Added by Martin Hegedus, 4/21/09
         call dscal (2*nndb,  -1.d0,      w(llzb+6*nndb+2),3)             ! Added by Martin Hegedus, 4/21/09
      elseif ( nisym.gt.1 ) then                                          ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nndb,  w(llzb),1,  w(llzb+3*nndb),1)               ! Added by Martin Hegedus, 4/21/09
         call dscal (  nndb,  -1.d0,      w(llzb+3*nndb+1),3)             ! Added by Martin Hegedus, 4/21/09
      elseif ( njsym.gt.1 ) then                                          ! Added by Martin Hegedus, 4/21/09
         call dcopy (3*nndb,  w(llzb),1,  w(llzb+3*nndb),1)               ! Added by Martin Hegedus, 4/21/09
         call dscal (  nndb,  -1.d0,      w(llzb+3*nndb+2),3)             ! Added by Martin Hegedus, 4/21/09
      endif                                                               ! Added by Martin Hegedus, 4/21/09
!!      if ( nisym.gt.1 ) then                                              ! Removed by Martin Hegedus, 4/21/09
!!         call dcopy (3*nndb,  w(llzb),1,  w(llzb+3*nndb),1)               ! Removed by Martin Hegedus, 4/21/09
!!         call dscal (  nndb,  -1.d0,      w(llzb+3*nndb+1),3)             ! Removed by Martin Hegedus, 4/21/09
!!         if ( njsym.gt.1 ) then                                           ! Removed by Martin Hegedus, 4/21/09
!!            call dcopy (6*nndb,  w(llzb),1,  w(llzb+6*nndb),1)            ! Removed by Martin Hegedus, 4/21/09
!!            call dscal (2*nndb,  -1.d0,      w(llzb+6*nndb+2),3)          ! Removed by Martin Hegedus, 4/21/09
!!         endif                                                            ! Removed by Martin Hegedus, 4/21/09
!!      endif                                                               ! Removed by Martin Hegedus, 4/21/09
!
      n       =  ncnsym*nndb
      call getcor ('w',llw,16*n)
      call vinsup (nncp,ncnsym,za,rsqa,ifla                             &
     &            ,nndb,w(llindb),w(llzb)                               &
     &            ,w(llw),w(llw+3*n)                                    &
     &     ,w(llw+ 6*n),w(llw+ 7*n),w(llw+ 8*n),w(llw+ 9*n),w(llw+10*n) &
     &     ,w(llw+11*n),w(llw+12*n),w(llw+13*n),w(llw+14*n),w(llw+15*n) &
     &            )
!
      goto 950
  950 continue
!                                  fix up influences so that all far
!                                  fields for a given c.p. are the
!                                  same type
      do 960 k = 1,nncp
         iflc(k) = ifmap( ifla(k,1) )
  960 continue
      do 980 icnsym = 2,ncnsym
         do 965 k = 1,nncp
            iflb(k) = ifmap( ifla(k,icnsym) )
  965    continue
         do 970 k = 1,nncp
            iflc(k) = max( iflb(k), iflc(k))
  970    continue
  980 continue
!                                  following code can be suppressed
!                                  (with some loss of accuracy on the
!                                  pic statistics) when not doing
!                                  debug validation with pivc
      if ( .not. syncff ) goto 991
      do 990 icnsym = 1,ncnsym
         do 985 k = 1,nncp
            ifla(k,icnsym) = max( ifla(k,icnsym), iflc(k) )
  985    continue
  990 continue
  991 continue
!                                  count the various influence types
      nncpx   =  nncp*ncnsym
      do 995 iflx = 0,7
         call wheneq (nncpx,  ifla,1,  iflx,   iflb,nx)
         iflcnt(iflx) = nx
  995 continue
! ----      call outvci ('iflcnt',8,iflcnt)
      iflcnt(0) = iflcnt(0) + iflcnt(7)
      do 997 iflx = 0,6
         ii      =  iflx+1
         if ( mod(itsf,2).ne.0 ) npic(1,ii) = npic(1,ii) + iflcnt(iflx)
         if (     itsf   .ge.2 ) npic(2,ii) = npic(2,ii) + iflcnt(iflx)
  997 continue
!
      call frecor ('vinflu')
!
      return
      END subroutine vinflu
! **deck vinicp
      subroutine vinicp (nncp,ncnsym,ifla,  iszc,ltewic,  ifluar,iflumx)
      implicit double precision (a-h,o-z)
      dimension ifla(nncp,4), ifluar(4)
      logical ltewic
!
!     move influences from the cp-group influence array ifla to the
!     individual panel influence array ifluar, taking account of
!     far-field influences already computed
!
      logical produx
      dimension iflmap(0:7), ifltew(0:7)
!                                   for validation, set debug=.t. in vin
!                                   validation: method=2, true12=.f.
! ---      data iflmap /0,  3,3,3,  0,0,0,   0/
!                                   validation: method=1, true12=.t.
! ---      data iflmap /0,  1,2,3,  0,0,0,   0/
!                                   for production, be sure debug=.f. in
!                                   production: qffcal still in pivc
      data iflmap /0,  0,0,0,  4,5,6,   0/
!                                   production: wake filament panels
      data ifltew /0,  1,2,3,  4,5,6,   0/
!                                   production: produx = .true.
!                                               true12 = .false.[vffvel]
!                                               method = 1 [vffpev,ws]
!                                                      = 2 [vffpev,cray]
! ---      data produx /.false./
      data produx /.true./
!
      iflumx  =  0
      if ( ltewic .and. produx ) goto 300
!
      iflumx  =  0
      do 100 kk = 1,ncnsym
         ifluar(kk) = iflmap( ifla(iszc,kk) )
         iflumx     = max(iflumx,ifluar(kk))
  100 continue
      return
!
  300 continue
      iflumx  =  0
      do 400 kk = 1,ncnsym
         ifluar(kk) = ifltew( ifla(iszc,kk) )
         iflumx     = max(iflumx,ifluar(kk))
  400 continue
      return
!
      END subroutine vinicp
! **deck vinsb2
      subroutine vinsb2 (ndex,index,  za,rsqa,ifla,rhsqa                &
     &                  ,zb,rhosq,dmnsq,iflb                            &
     &                     ,rhocc,dmncc,indcc                           &
     &                  )
      implicit double precision (a-h,o-z)
      dimension index(ndex)
      dimension za(3,1:*), rsqa(1:*), ifla(1:*), rhsqa(1:*)
      dimension zb(3,ndex), rhosq(ndex), dmnsq(ndex), iflb(ndex)
      dimension rhocc(ndex), dmncc(ndex), indcc(ndex)
!
!     perform near field influence tests for residual of types 4,5,6
!
!call epsff
      common /epsff/ eps1, eps2, eps3, eps4, eps5                       &
     &             , phc1, phc2, phc3
!end  epsff
!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
!
      rsq4     =  (eps4*diamf)**2
      rsq5     =  (eps5*diamf)**2
      rad      =  .5d0*diamf
      radsq    =  rad**2
!                                  gather up basic data
      do 100 idex = 1,ndex
         ii      =  index(idex)
         zb(1,idex) = za(1,ii)
         zb(2,idex) = za(2,ii)
         zb(3,idex) = za(3,ii)
         rhosq(idex)= rhsqa(ii)
  100 continue
      do 200 idex = 1,ndex
         dmnsq(idex) = ( max( 0.d0, abs(zb(3,idex))-qdltf ) )**2
  200 continue
      call whenfgt (ndex,  rhosq,1,  radsq,  indcc,nndcc)
      if ( nndcc.le.0 ) goto 310
!
      do 220 iic = 1,nndcc
         idex    =  indcc(iic)
         rhocc(iic)  = rhosq(idex)
         dmncc(iic)  = dmnsq(idex)
  220 continue
      do 240 iic = 1,nndcc
         rhocc(iic) = sqrt(rhocc(iic))
  240 continue
      do 250 iic = 1,nndcc
         idex    =  indcc(iic)
         dmnsq(idex) = ( rhocc(iic) - rad )**2 + dmncc(iic)
  250 continue
!
  310 continue
      do 340 idex = 1,ndex
!--         iflb(idex) = cvmgm (         4,5,  rsq4 - dmnsq(idex) )
         iflb(idex)  =  4
         if ( rsq4 .ge. dmnsq(idex)  ) iflb(idex) = 5
  340 continue
      do 350 idex = 1,ndex
!--         iflb(idex) = cvmgm (iflb(idex),6,  rsq5 - dmnsq(idex) )
         if ( rsq5 .ge. dmnsq(idex)  ) iflb(idex) = 6
  350 continue
!                                  perform the tests
!                                  scatter the influence results
      do 500 idex = 1,ndex
         ifla( index(idex) ) = iflb(idex)
  500 continue
      return
      END subroutine vinsb2
! **deck vinsp1
      subroutine vinsp1 (n,  za,xa,  indb,nndb)
      implicit double precision (a-h,o-z)
      dimension za(3,n), xa(n)
      dimension indb(1:*)
!
!     generate a list of reasonable control points
!
!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
!
      xbcrit  =  pxf - 1.d-2*diamf
      rsqadj  =  1.d-2*diamf*diamf
      amach2  =  amach*amach
      do 200 i = 1,n
         z1      =  za(1,i) - pwf(1)
         z2      =  za(2,i) - pwf(2)
         z3      =  za(3,i) - pwf(3)
         xb      =  compd(1)*z1 + compd(2)*z2 + compd(3)*z3
         rsq     =  betams*( z1**2 + z2**2 + z3**2 ) + amach2*xb*xb
         xa(i)   =  min ( xb-xbcrit, rsq+rsqadj )
  200 continue
!
      call whenfge (n,  xa,1,  0.d0,  indb,nndb)
!
      return
      END subroutine vinsp1
! **deck vinsp2
      subroutine vinsp2 (za,  indb,nndb,  zb)
      implicit double precision (a-h,o-z)
      dimension za(3,1:*),  indb(nndb),  zb(3,nndb)
!
!     given the control point coordinates and a sublist, extract a
!     sublist of control points coordinates
!
      do 300 ib = 1,nndb
         idex    =  indb(ib)
         zb(1,ib) = za(1,idex)
         zb(2,ib) = za(2,idex)
         zb(3,ib) = za(3,idex)
  300 continue
!
      return
      END subroutine vinsp2
! **deck vinsub
      subroutine vinsub (n,  za,rsqa,ifla                               &
     &                  ,index,rhsqa,zb)
      implicit double precision (a-h,o-z)
      dimension za(3,n), rsqa(n), ifla(n)                               &
     &        , index(n), rhsqa(n), zb(3,n)
!
!     compute local coordinates, the R^2 values and evaluate the method
!     for influence computation for a collection of control points.
!     (subsonic flow case)
!
!call epsff
      common /epsff/ eps1, eps2, eps3, eps4, eps5                       &
     &             , phc1, phc2, phc3
!end  epsff
!ca freqdt
!                                                  /freqdt/
      common /freqdt/ omgbar, omegb, omg, omgabs
!---- complex*16 omgbar, omegb, omg
!end  freqdt
!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 skrch1
      common /skrch1/ w(9000000)
!end  skrch1
!
      logical chek12
!
      call setcor ('vinsub')
      chek12   =  .true.
      amach2   =  amach*amach
      rsq1     =  (eps1*diamf)**2
      rsq2     =  (eps2*diamf)**2
      rsq3     =  (eps3*diamf)**2
!                                  initialize x-coords, R^2 values
!                                  and influence types
      do 50 i = 1,n
         ifla(i)  =   0
   50 continue
!                                  compute vector from panel center to
!                                  control point images, x-coord of this
!                                  vector and square of this vector
      do 200 kk = 1,3
         qckk    =  cpfz(kk)
         do 100 i = 1,n
            zb(kk,i) = za(kk,i) - qckk
  100    continue
  200 continue
!                                  get local coords of pan ctr to c.p.
      call hsmmp1 (n,3,3,  zb,3,1,  af,3,1,  za,3,1)
! --- call hsmmp1 (3,3,n,  af,1,3,  zb,1,3,  za,1,3)
!                                  compute square of compressible dist.
      do 300 i = 1,n
         rhsqa(i) =  za(1,i)**2 + za(2,i)**2
         rsqa(i)  =  rhsqa(i)   + za(3,i)**2
  300 continue
!                                  set default influence based on max
!                                  possible phase variation
      phc     =  diamf*omgabs
      ifldfl  =  4
      if ( phc.lt.phc3 ) ifldfl = 3
!                                  perform basic far field test
      do 320 i = 1,n
! ---         ifla(i) = cvmgm (3,0, rsq3 - rsqa(i) )
         if ( rsq3 .lt. rsqa(i) ) ifla(i) = ifldfl
  320 continue
      if ( .not.chek12 ) goto 351
!
      if ( phc.ge.phc2 ) goto 351
      do 340 i = 1,n
! ---         ifla(i)  =  cvmgm (2,ifla(i), rsq2 - rsqa(i) )
         if ( rsq2 .lt. rsqa(i)  ) ifla(i) = 2
  340 continue
!
      if ( phc.ge.phc1 ) goto 351
      do 350 i = 1,n
! ---         ifla(i)  =  cvmgm (1,ifla(i), rsq1 - rsqa(i) )
         if ( rsq1 .lt. rsqa(i)  ) ifla(i) = 1
  350 continue
!
  351 continue
!                                  if ifla is zero, reset to 4, 5 or 6
      call wheneq (n,  ifla,1,  0,  index,ndex)
      if ( ndex.le.0 ) goto 400
!                                  do a single allocation (to save time)
!                                  and fill out types 4, 5 and 6
      call getcor ('vinsb2',llv,9*ndex)
      call vinsb2 (ndex,index,  za,rsqa,ifla,rhsqa                      &
     &            ,w(llv),w(llv+3*ndex),w(llv+4*ndex),w(llv+5*ndex)     &
     &                   ,w(llv+6*ndex),w(llv+7*ndex),w(llv+8*ndex)     &
     &            )
  400 continue
      call frecor ('vinsub')
      return
      END subroutine vinsub
! **deck vinsup
      subroutine vinsup (nncp,ncnsym,za,rsqa,ifla                       &
     &                  ,nndb,indb,zb                                   &
     &                  ,zc,zd   ,zx,dmn,dc,anfl,bnfl                   &
     &                  ,iflb,iflc,ifld    ,indc,indd                   &
     &                  )
      implicit double precision (a-h,o-z)
      dimension za(3,nncp*ncnsym),  rsqa(nncp*ncnsym), ifla(nncp,ncnsym)
      dimension indb(nndb), zb(3,nndb*ncnsym), iflb(nndb*ncnsym)
      dimension zc(3,*), zd(3,*)
      dimension zx(1:*), dmn(1:*), dc(1:*),   anfl(1:*), bnfl(1:*)
      dimension iflc(*), ifld(1:*), indc(1:*), indd(1:*)
!
!     winnow down the baseline zb list of candidate control pt images
!     into the list zc and compute the distance from the panel to the
!     mach cone associated with each point in the zc list.  using these
!     distances, define the method of influence coefficient computation
!     and scatter that information back to zb and then to za
!
!call epsff
      common /epsff/ eps1, eps2, eps3, eps4, eps5                       &
     &             , phc1, phc2, phc3
!end  epsff
!ca freqdt
!                                                  /freqdt/
      common /freqdt/ omgbar, omegb, omg, omgabs
!---- complex*16 omgbar, omegb, omg
!end  freqdt
!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 cpxb(3,4), cpzxb(3), cpzloc(3), cploc(3,4)
      logical chek12, chknul
      dimension ifluar(4)
!
      rthaf   =  sqrt( .5d0 )
      radxb   =  .5d0*diamf
      chek12  =  .true.
      chknul  =  .true.
      rsf     =  rf*sf
!
      dist1   =  eps1*diamf
      dist2   =  eps2*diamf
      dist3   =  eps3*diamf
      dist4   =  eps4*diamf
      dist5   =  eps5*diamf
      call hsmmp1 (3,3,1,     ggcp,1,3,  cpfz,1,3,  cpzxb,1,3)
      call hsmmp1 (3,3,1,       af,1,3,  cpfz,1,3, cpzloc,1,3)
!
      call hsmmp1 (3,3,4,     ggcp,1,3,   cpf,1,3,   cpxb,1,3)
      call hsmmp1 (3,3,4,       af,1,3,   cpf,1,3,  cploc,1,3)
!                                   compute distance from panel center
!                                   to the boundary of the zb's mach
!                                   cones as first cut test.
      nndbx   =  ncnsym*nndb
      call hsmmp1 (nndbx,3,3,  zb,3,1,  ggcp,3,1,  zd,3,1)
      do 150 i = 1,nndbx
         z1      =  cpzxb(1) - zd(1,i)
         z2      =  cpzxb(2) - zd(2,i)
         z3      =  cpzxb(3) - zd(3,i)
         rcyzsq  =  z2**2 + z3**2
         xcsq    =  z1**2
         rsqa(i) =  xcsq + rcyzsq
         hcsq    =  xcsq - rcyzsq
         hcsqmn  =  -hcsq
!                                   if anfl(i) < 0, then both z1<0
!                                   and   rcyzsq < xcsq ==> influence
!----         anfl(i) =  max( z1, rcyzsq-xcsq )
         anfl(i) =  max( z1,  hcsqmn )
!                                   if bnfl(i) > 0, distance is
!                                   sqrt( rsqa(i) )  and the point on
!                                   the mach cone closest to the panel
!                                   center is at the apex
!----         bnfl(i) =  min( z1, xcsq-rcyzsq )
         bnfl(i) =  min( z1, hcsq )
!
         zx(i)   =  rthaf*abs( z1 + sqrt(rcyzsq) )
  150 continue
!
      call whenfgt (nndbx,  bnfl,1,  0.d0,  indc,napex)
      do 160 i = 1,napex
         zx(indc(i)) = sqrt(  rsqa(indc(i))  )
  160 continue
!                                   if zx(i) <= .5*diam, we must assume
!                                   an influence.
      do 170 i = 1,nndbx
         anfl(i) =  min( anfl(i), zx(i)-radxb )
  170 continue
!                                   gather up list of zb pts influenced
!                                   by the panel
      call whenfle (nndbx,  anfl,1,  0.d0,  indc,nndc)
!
      do 180 ic = 1,nndc
         zc(1,ic)  =  zd(1,indc(ic))
         zc(2,ic)  =  zd(2,indc(ic))
         zc(3,ic)  =  zd(3,indc(ic))
         dc(ic)    =  zx(indc(ic))
  180 continue
      call whenfgt (nndc,  dc,1,  dist3,  indd,nndd)
! ---      call jzero (iflc,nndc)
      call icopy (nndc,  7,0,  iflc,1)
!                                  set default influence based on max
!                                  possible phase variation
      phc     =  diamf*omgabs
      ifldfl  =  4
      if ( phc.lt.phc3 ) ifldfl = 3
      do 190 id = 1,nndd
         iflc(indd(id)) = ifldfl
  190 continue
!                                   code to use only during validation
      if ( .not.chek12 ) goto 250
      if ( phc.ge.phc2 ) goto 250
      do 220 ic = 1,nndc
! ----        iflc(ic) = cvmgm (2,iflc(ic),  dist2-dc(ic))
         if ( dist2 .lt. dc(ic) ) iflc(ic) = 2
  220 continue
      if ( phc.ge.phc1 ) goto 250
      do 240 ic = 1,nndc
! ----        iflc(ic) = cvmgm (1,iflc(ic),  dist1-dc(ic))
         if ( dist1 .lt. dc(ic) ) iflc(ic) = 1
  240 continue
  250 continue
!                                   next define the sublist that fail
!                                   the farfield test and for which
!                                   the distance from panel to boundary
!                                   of mach cone must be computed
      call wheneq (nndc,  iflc,1,  7,  indd,nndd)
!
      if ( nndd.le.0 ) goto 700
!
      do 300 id = 1,nndd
         zd(1,id)  =  zc(1,indd(id))
         zd(2,id)  =  zc(2,indd(id))
         zd(3,id)  =  zc(3,indd(id))
  300 continue
!                                   compute minimum distance from the
!                                   panel corners to the c.p. image
!                                   mach cones in X(bar)
      ischk   =  0
      do 600 is = 1,4
         if ( is.eq.icsf ) goto 600
         ischk   =  ischk + 1
         q1      =  cpxb(1,is)
         q2      =  cpxb(2,is)
         q3      =  cpxb(3,is)
         do 510 i = 1,nndd
            zx(i)   =  zd(1,i) - q1
            rsqa(i) =  (zd(2,i) - q2)**2 + (zd(3,i) - q3)**2
  510    continue
         do 520 i = 1,nndd
            rsqa(i) = sqrt(rsqa(i))
  520    continue
         if ( ischk.gt.1 ) goto 540
!                                   is = 1
         do 530 i = 1,nndd
            dmn(i)   =  rthaf * ( zx(i) - rsqa(i) )
  530    continue
         goto 600
!                                   is = 2,3,4
  540    continue
         do 550 i = 1,nndd
            dmni     =  rthaf * ( zx(i) - rsqa(i) )
            dmn(i)   =  min( dmn(i), dmni)
  550    continue
  600 continue
!
!                                  set influence types 4,5,6
      do 640 i = 1,nndd
!--         ifld(i) = cvmgm (         4,5,  dist4 - dmn(i) )
         ifld(i)  =  4
         if ( dist4 .ge. dmn(i)  ) ifld(i) = 5
  640 continue
      do 650 i = 1,nndd
!--         ifld(i) = cvmgm (ifld(i),6,  dist5 - dmn(i) )
         if ( dist5 .ge. dmn(i)  ) ifld(i) = 6
  650 continue
!
      do 660 i = 1,nndd
         iflc(indd(i)) = ifld(i)
  660 continue
!                                  scatter iflc data to iflb
  700 continue
! ---      call jzero (iflb,  nndbx)
      call icopy (nndbx,  7,0,  iflb,1)
      do 720 i = 1,nndc
         iflb(indc(i)) = iflc(i)
  720 continue
!                                  for supersonic flow, apply the more
!                                  rigorous test of sinflu (clone of the
!                                  original dinflu routine) to help
!                                  determine null influences
      if ( .not.chknul ) goto 735
         call wheneq (ncnsym*nndb,  iflb,1,  6,  indc,nndc)
         if ( nndc.gt.0 ) call sinflu (nndc,indc  ,zb,iflb)
  735 continue
!                                  novel usage: 7 == null influence
! ---      call jzero (ifla,nncp*ncnsym)
      call icopy (nncp*ncnsym,  7,0,  ifla,1)
      ibias   =  0
      do 750 ijsym = 1,ncnsym
         do 740 i = 1,nndb
            ifla(indb(i),ijsym) = iflb(i+ibias)
  740    continue
         ibias   =  ibias + nndb
  750 continue
!                                   gather up all non-null influence
!                                   control point images, transform
!                                   to local coordinates and get R^2
!                                   at panel centers
! ---      call whenne (ncnsym*nncp,  ifla,1,  0,  indc,nndc)
!                                   indc will point into zb
      call whenne (nndbx,  iflb,1,  7,  indc,nndc)
      call vinsp2 (zb,  indc,nndc,  zc)
      call hsmmp1 (nndc,3,3,  zc,3,1,  af,3,1,  zd,3,1)
!                                   construct indd so that it points
!                                   into za
      do 760 ic = 1,nndc
         ib      =  indc(ic)
         icnsbs  =  (ib-1)/nndb
         ibx     =  ib - icnsbs*nndb
         indd(ic) = indb(ibx) + icnsbs*nncp
  760 continue
!                                   get indc = indd another way & check
!---      call whenne (ncnsym*nncp,  ifla,1,  7,  indc,nndcx)
!---      do 770 ic = 1,nndc
!---         if ( indd(ic).ne.indc(ic) ) call abort
!--- 770  continue
!
!---      if ( nndcx.ne.nndc ) call abort
      call dcopy (nncp*ncnsym,  -100.d0,0,  rsqa,1)
      do 780 i = 1,nndc
         z1      = zd(1,i) - cpzloc(1)
         z2      = zd(2,i) - cpzloc(2)
         z3      = zd(3,i) - cpzloc(3)
         za(1,indd(i)) = z1
         za(2,indd(i)) = z2
         za(3,indd(i)) = z3
         rsqa(indd(i)) = rf*( z1*z1 - z3*z3 ) - z2*z2
  780 continue
!
      return
      END subroutine vinsup
! **deck vip
      subroutine vip (a,ia,b,ib,m,c)
      implicit double precision (a-h,o-z)
      dimension a(*), b(*)
!
!         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.0d0
      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 vip
! **deck vips
      subroutine vips (a,ia,b,ib,m,c)
      implicit double precision (a-h,o-z)
      dimension a(*), b(*)
!
!         fortran equivalent of the bcslib routine vips: c = c + <a,b>
!         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       i/o r*8   the input value of c minus the inner product
!
!         michael epton, 30 november 1988
!
      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 vips
! **deck vmul
      subroutine vmul(a,x,b,n)
      implicit double precision (a-h,o-z)
      dimension a(n),b(n)
      do 100 i=1,n
          b(i) = x*a(i)
  100 continue
      return
      END subroutine vmul
! **deck vtrns
      subroutine  vtrns(jc,dvdfs)
      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 retrieve influence coefficient array for given contol     *
!     *  point                                                        *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the information is retrieved via readms                      *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                 *
!     *                                                               *
!     *   dvdfs     argument  input     control point influence       *
!     *                                 coefficient array             *
!     *                                                               *
!     *  ne         -local-   - - - -   number of components of       *
!     *                                 influence coefficients stored *
!     *                                 for given control point       *
!     *                                 =0 no influence coefficients  *
!     *                                 stored                        *
!     *                                 =1 only potential influence   *
!     *                                    coefficients are stored    *
!     *                                 =4 both potential and velocity*
!     *                                    influence coefficients are *
!     *                                    stored                     *
!     *                                                               *
!     *   niv       /vrwi/    input     index array for ntv           *
!     *                                                               *
!     *   nnv       /vrwi/    input     length of niv                 *
!     *                                                               *
!     *   ntv       /vrwi/    input     file on which control point   *
!     *                                 influence coefficient arrays  *
!     *                                 are stored                    *
!     *                                                               *
!     *   nvdq      /vrwi/    input     number of singularity         *
!     *                                 parameters influencing control*
!     *                                 point                         *
!     *                                                               *
!     *   nwpr      -local-   - - - -   total number of influence     *
!     *                                 coefficients per record       *
!     *                                                               *
!     *   nwv       /vrwi/    input     array containing number of    *
!     *                                 components (0 thur 4) of      *
!     *                                 influence coefficients stored *
!     *                                 for each 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 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 vrwi
      common /vrwi/ nvdq,nsv,nrv,ntv,nnv, niv(maxcp+2), nwv(maxcp)
!end  vrwi
!call cvtrns
!                                               /cvtrns/
      common /cvtrns/ nejc
!end  cvtrns
      dimension dvdfs(1)
      ne=nwv(jc)
      nejc    =  ne
!c
!     *  if no influence coefficients are to be retrieved for this    *
!     *  control point then return                                    *
!
      if(ne.eq.0) go to 900
!c
!     *  calculate number of influence coefficients to be retrieved   *
!
      nwpr    =  ityprc*ne*nvdq
!c
!     *  the information is retrieved via readms                      *
!
      call readmd(ntv,dvdfs,nwpr,jc)
      if(ne.eq.4) go to 900
!c
!     *  if only potential influence  coefficients have been stored,  *
!     *  zero out velocity coefficients and rearrange order so that   *
!     *  potential and velocity influence coefficients for each       *
!     *  singularity parameter are in consecutive order               *
!
      do 500 i=1,nvdq
      ir=nvdq-i+1
      ir4=4*(nvdq-i)
      dvdfs(ir4+1)=dvdfs(ir)
      dvdfs(ir4+2)=0.d0
      dvdfs(ir4+3)=0.d0
      dvdfs(ir4+4)=0.d0
  500 continue
  900 return
      END subroutine  vtrns
! **deck wheneq
      subroutine wheneq (n,  a,ia,  ac,  ind,nind)
      implicit double precision (a-h,o-z)
      integer a(1:*), ac
      dimension ind(1:*)
!
      nind    =  0
      if ( n.lt.0 ) return
      la      =  1
      if ( ia.lt.0) la = 1 - ia*(n-1)
      do 100 k = 1,n
         if ( a(la).eq.ac ) then
            nind    =  nind + 1
            ind(nind) = k
         endif
         la      =  la + ia
  100 continue
      return
      END subroutine wheneq
! **deck whenfge
      subroutine whenfge (n,  a,ia,  ac,  ind,nind)
      implicit double precision (a-h,o-z)
      dimension a(1:*)
      dimension ind(1:*)
!
      nind    =  0
      if ( n.lt.0 ) return
      la      =  1
      if ( ia.lt.0) la = 1 - ia*(n-1)
      do 100 k = 1,n
         if ( a(la).ge.ac ) then
            nind    =  nind + 1
            ind(nind) = k
         endif
         la      =  la + ia
  100 continue
      return
      END subroutine whenfge
! **deck whenfgt
      subroutine whenfgt (n,  a,ia,  ac,  ind,nind)
      implicit double precision (a-h,o-z)
      dimension a(1:*)
      dimension ind(1:*)
!
      nind    =  0
      if ( n.lt.0 ) return
      la      =  1
      if ( ia.lt.0) la = 1 - ia*(n-1)
      do 100 k = 1,n
         if ( a(la).gt.ac ) then
            nind    =  nind + 1
            ind(nind) = k
         endif
         la      =  la + ia
  100 continue
      return
      END subroutine whenfgt
! **deck whenfle
      subroutine whenfle (n,  a,ia,  ac,  ind,nind)
      implicit double precision (a-h,o-z)
      dimension a(1:*)
      dimension ind(1:*)
!
      nind    =  0
      if ( n.lt.0 ) return
      la      =  1
      if ( ia.lt.0) la = 1 - ia*(n-1)
      do 100 k = 1,n
         if ( a(la).le.ac ) then
            nind    =  nind + 1
            ind(nind) = k
         endif
         la      =  la + ia
  100 continue
      return
      END subroutine whenfle
! **deck whenilt
      subroutine whenilt (n,  a,ia,  ac,  ind,nind)
      implicit double precision (a-h,o-z)
      integer a(1:*), ac
      dimension ind(1:*)
!
      nind    =  0
      if ( n.lt.0 ) return
      la      =  1
      if ( ia.lt.0) la = 1 - ia*(n-1)
      do 100 k = 1,n
         if ( a(la).lt.ac ) then
            nind    =  nind + 1
            ind(nind) = k
         endif
         la      =  la + ia
  100 continue
      return
      END subroutine whenilt
! **deck whenne
      subroutine whenne (n,  a,ia,  ac,  ind,nind)
      implicit double precision (a-h,o-z)
      integer a(1:*), ac
      dimension ind(1:*)
!
      nind    =  0
      if ( n.lt.0 ) return
      la      =  1
      if ( ia.lt.0) la = 1 - ia*(n-1)
      do 100 k = 1,n
         if ( a(la).ne.ac ) then
            nind    =  nind + 1
            ind(nind) = k
         endif
         la      =  la + ia
  100 continue
      return
      END subroutine whenne
! **deck wopen
      subroutine wopen (lun,nblk,istat,ier)
!
!         stub for wopen calls
!
      write (6,6000) lun,nblk,istat
 6000 format ('  wopen call on unit',i5,'  blocks:',i6                  &
     &       ,'   status:',i6)
      ier     =  0
      return
      END subroutine wopen
! **deck writmd
      subroutine writmd (lun,ia,n,irec, i1,i2)
      dimension ia(n)
!ca locinf
!                                                         /locinf/
      common /locinf/ rlocdm(2), ilocdm(2), kkloci, kklocr, kklr2i
      double precision rlocdm
!end  locinf
!
!         write a ms record of double words
!
      call writms (lun,ia,n*kklr2i,irec,  i1,i2)
      return
      END subroutine writmd
! **deck writms
      subroutine writms (lun,a,na,irec  ,irewrt,istat)
      dimension a(na)
!
!         write a fake readms/writms record
!
!call dictms
      common /dictms/ nrecmx(100), llindx(100), ndirwr(100)             &
     &              , rwmstr                                            &
     &              , lldict, lldmax, indxms(2,800000)                   &
     &              , buffms(512)
      integer buffms
      logical  rwmstr
!end  dictms
!
      if ( na.lt.1 ) na = 1
      nbk    =  (na+511)/512
      lliudx =  llindx(lun)
      if ( rwmstr ) then
      write (6,6001) lun,irec,na,nbk,ndirwr(lun),indxms(1,lliudx+irec)
 6001 format (' writms:  unit,rec,lth',3i6,'  nbk,ndirwr,iudx',2i6,i10)
      endif
      nind    = nrecmx(lun)
      if ( irec.eq.nind .and. istat.ne.97531 ) then
         write (6,6004) lun, irec, nind, istat
         call remarx ('writms: attempt to write data in index record')
         CALL AbortPanair('writms')
      endif
 6004 format (' writms: on unit',i4,', attempt to write record',2i8,    &
     & ' which should be an index record using istat=',i6)
      call upkims (iblock,nbkold,indxms(1,lliudx+irec))
      if ( indxms(1,lliudx+irec).eq.0 ) goto 50
      if ( nbk.le.nbkold ) goto 500
!                                  calculate the block address in the
!                                  direct access file
   50 continue
      lblock  =  ndirwr(lun)
      ndirwr(lun) = ndirwr(lun) + nbk
      if (nbk.gt.4095) call exitms (lun,'record size > 4095*512 words')
      call pakims (lblock,nbk,indxms(1,lliudx+irec))
      do 100 k = 1,nbk
          jrec   =  k + lblock
          la     =  1 + (k-1)*512
          nw     =  512
          if ( k.eq.nbk ) nw = na - (nbk-1)*512
          call icopy (nw,  a(la),1,  buffms,1)
          write (lun,rec=jrec) buffms
  100 continue
      return
!
!                                  rewrite a logical record in place
!
  500 continue
      call upkims (lblock,nbkold,indxms(1,lliudx+irec))
      if ( nbk.gt.nbkold ) call exitms (lun                             &
     &  ,'attempt to overwrite a too-short record')
      do 700 k = 1,nbk
          jrec   =  k + lblock
          la     =  1 + (k-1)*512
          nw     =  512
          if ( k.eq.nbk ) nw = na - (nbk-1)*512
          call icopy (nw,  a(la),1,  buffms,1)
          write (lun,rec=jrec) buffms
  700 continue
      return
      END subroutine writms
! **deck wtbuf
      subroutine wtbuf (lun,a,n)
      implicit double precision (a-h,o-z)
      dimension a(n)
      if ( n.le.0 ) return
      write (lun) (a(i),i=1,n)
      return
      END subroutine wtbuf
! **deck wxtrct
      subroutine wxtrct (ipotm,jc,ip ,zc,tsc,anx,any,anz                &
     &                  ,amachm,wm,vm,cpm                               &
     &                  ,amachu,wu,vu,cpu,pheu  ,wnu,pwnu,vtu,pvtu      &
     &                  ,amachl,wl,vl,cpl,phel  ,wnl,pwnl,vtl,pvtl      &
     &                  ,cpd)
      implicit double precision (a-h,o-z)
      dimension zc(3), tsc(5)                                           &
     &        , wm(3), vm(3), cpm(4)                                    &
     &        , wu(3), vu(3), cpu(4)                                    &
     &        , wl(3), vl(3), cpl(4)                                    &
     &                      , cpd(4)
!
!         write a record to the extract file (ft13) using e11fmt to
!         format the data
!
!         ipotm   i   int
!         jc      i   int   control point index
!         ip      i   int   panel index
!         zc      i   r*8   control point location
!         tsc     i   r*8   (sg,mu, mu/x, mu/y, mu/z)
!         anx     i   r*8   x component of normal, scaled by area
!         any     i   r*8   y component of normal, scaled by area
!         anz     i   r*8   z component of normal, scaled by area
!
!         amachm  i   r*8   local mach number computed from stagnation c
!         wm      i   r*8   total mass flux, from stagnation cond.
!         vm      i   r*8   total velocity, from stagnation cond.
!         cpm     i   r*8   pressure coefficients, from stagnation cond.
!
!         amachu  i   r*8   local mach number, upper surface
!         wu      i   r*8   total mass flux, upper surface
!         vu      i   r*8   total velocity, upper surface
!         cpu     i   r*8   pressure coefficients, upper surface
!         pheu    i   r*8   perturbation potential, upper surface
!         wnu     i   r*8   normal mass flux component, upper surface
!         pwnu    i   r*8   perturbation normal mass flux, upper surface
!         vtu     i   r*8   tangential velocity, upper surface
!         pvtu    i   r*8   perturbation tangential velocity, upper surf
!
!         amachl  i   r*8   local mach number, lower surface
!         wl      i   r*8   total mass flux, lower surface
!         vl      i   r*8   total velocity, lower surface
!         cpl     i   r*8   pressure coefficients, lower surface
!         phel    i   r*8   perturbation potential, lower surface
!         wnl     i   r*8   normal mass flux component, lower surface
!         pwnl    i   r*8   perturbation normal mass flux, lower surface
!         vtl     i   r*8   tangential velocity, lower surface
!         pvtl    i   r*8   perturbation tangential velocity, lower surf
!
!         cpd     i   r*8   difference (u-l) pressure coefficients
!
!         michael epton, 30 november 1988
!
      character*11 azc(3), atsc(5)                                      &
     &           , awm(3), avm(3), acpm(4), aamchm                      &
     &           , awu(3), avu(3), acpu(4), aamchu                      &
     &           , awl(3), avl(3), acpl(4), aamchl                      &
     &                           , acpd(4)                              &
     &           , adum(1)                                              &
     &           ,aanx,aany,aanz                                        &
     &           ,awnu,apwnu,avtu,apvtu,apheu                           &
     &           ,awnl,apwnl,avtl,apvtl,aphel
!                                  put data into std format
      call e11fmt (3,zc,azc)
      call e11fmt (5,tsc,atsc)
!
      call e11fmt (1,anx,adum)
      aanx  =  adum(1)
      call e11fmt (1,any,adum)
      aany  =  adum(1)
      call e11fmt (1,anz,adum)
      aanz  =  adum(1)
!
      call e11fmt (1,amachm,adum)
      aamchm  =  adum(1)
      call e11fmt (1,amachu,adum)
      aamchu  =  adum(1)
      call e11fmt (1,amachl,adum)
      aamchl  =  adum(1)
!
      call e11fmt (3,wm,awm)
      call e11fmt (3,wu,awu)
      call e11fmt (3,wl,awl)
!
      call e11fmt (3,vm,avm)
      call e11fmt (3,vu,avu)
      call e11fmt (3,vl,avl)
!
      call e11fmt (4,cpm,acpm)
      call e11fmt (4,cpu,acpu)
      call e11fmt (4,cpl,acpl)
      call e11fmt (4,cpd,acpd)
!
      call e11fmt (1,pheu,adum)
      apheu  =  adum(1)
      call e11fmt (1,phel,adum)
      aphel  =  adum(1)
!
      call e11fmt (1,wnu,adum)
      awnu  =  adum(1)
      call e11fmt (1,wnl,adum)
      awnl  =  adum(1)
!
      call e11fmt (1,pwnu,adum)
      apwnu  =  adum(1)
      call e11fmt (1,pwnl,adum)
      apwnl  =  adum(1)
!
      call e11fmt (1,vtu,adum)
      avtu  =  adum(1)
      call e11fmt (1,vtl,adum)
      avtl  =  adum(1)
!
      call e11fmt (1,pvtu,adum)
      apvtu  =  adum(1)
      call e11fmt (1,pvtl,adum)
      apvtl  =  adum(1)
!
      write (13,3500) jc,ip,(azc(i),i=1,3)                              &
     &              ,(atsc(i),i=2,5),atsc(1),aanx,aany,aanz
      if ( ipotm.eq.1 ) write (13,3600) aamchm,awm,apheu,avm,acpm
                        write (13,3600) aamchu,awu,apheu,avu,acpu
                        write (13,3600) aamchl,awl,aphel,avl,acpl
      if ( ipotm.eq.-1) write (13,3600) aamchm,awm,aphel,avm,acpm
      write (13,3600) awnu,awnu,apwnu,apwnl,avtu,avtl,apvtu,apvtl,acpd
 3500 format (/,i5,i6,11a11)
 3600 format (12a11)
!
      return
      END subroutine wxtrct
! **deck xbcncl
      subroutine xbcncl (nbdq,wa,bca,wb,bcb)
      implicit double precision (a-h,o-z)
!         set the b.c. data for an extra control point given the b.c.
!         data for the two nearest regular edge control points, a and b,
!         and the corresponding weights.
      dimension bca(nbdq), bcb(nbdq)
!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
!                                  /bcona/ and /bconb/ exactly parallel
!                                  /bcon/, and receive the b.c. data for
!                                  neighboring edge control points a and
      common /bcona/                                                    &
     &               ctdb1a(14), n1a(6), b1a(4)                         &
     &             , ctdb2a(14), n2a(6), b2a(4)
      common /bconb/                                                    &
     &               ctdb1b(14), n1b(6), b1b(4)                         &
     &             , ctdb2b(14), n2b(6), b2b(4)
!                                  copy the b.c. data for control points
!                                  a and b into /bcona/ and /bconb/
      call icopy (nbdq,  bca,1,  ctdb1a,1)
      call icopy (nbdq,  bcb,1,  ctdb1b,1)
!                                  if b.c. indexes don't match, just cop
!                                  data from the nearest point
      do 40 i = 1,3
          if ( n1a(i).ne.n1b(i) ) goto 200
          if ( n2a(i).ne.n2b(i) ) goto 200
   40 continue
      if ( n1a(4).ne.0 .or. n2a(4).ne.0 ) goto 200
      if ( n1b(4).ne.0 .or. n2b(4).ne.0 ) goto 200
!                                  all integral parameters agree, averag
!                                  the floating point data
      do 100 i = 1,14
          ctdb1a(i)  =  wa*ctdb1a(i) + wb*ctdb1b(i)
          ctdb2a(i)  =  wa*ctdb2a(i) + wb*ctdb2b(i)
  100 continue
!
      call icopy (nbdq,  ctdb1a,1,  cu1,1)
      go to 950
!                                   b.c. indexes don't match, copy in da
!                                   from the nearest point
!
  200 continue
      call icopy (nbdq,  ctdb1b,1,  cu1,1)
      if ( wa.gt.wb ) call icopy (nbdq,  ctdb1a,1,  cu1,1)
!
!
  950 continue
      return
      END subroutine xbcncl
! **deck xdasin
      subroutine xdasin (astd,iid,ind,  indx,iidx,astx,  iprnt)
      implicit double precision (a-h,o-z)
      dimension astd(9,25), iid(25), astx(4,4), iidx(4,4), indx(4)
!
      dimension astp(9,41), iip(41)
      data ncall /0/
!
      ncall   =  ncall + 1
!
      call zero (astp,9*41)
      ncd     =  9
!
      iprx    =  iprnt
      if ( ncall.gt.10 ) iprx = min (iprx,1)
      if ( iprx.ge.1 ) call outvci ('iid/b-4',ind,iid)
      if ( iprx.ge.2 ) call outmat ('astd/b-4',9,9,ind,astd)
      do 100 i = 1,4
          if ( indx(i) .le. 0 ) go to 100
          do 50 j = 1,ind
               astd(i,j) =  0.d0
   50     continue
  100 continue
!
      k       =  0
      do 200 j = 1,ind
          do 150 i = 1,9
               if ( astd(i,j) .ne. 0.d0 ) go to 160
  150     continue
          go to 200
!
  160     continue
          k       =  k + 1
          iip(k)  =  iid(j)
          call dcopy (9, astd(1,j),1, astp(1,k),1)
  200 continue
!
      do 300 i = 1,4
          if ( indx(i) .le. 0.d0 ) go to 300
          indxi   =  indx(i)
          do 220 j = 1,indxi
               astp(i,j+k) = astx(j,i)
               iip(j+k)    = iidx(j,i)
  220     continue
          k       =  k + indxi
  300 continue
!
      call scmpkt (astp,iip,ncd,k)
      ind     =  k
      call icopy (ind,  iip,1,  iid,1)
      call dcopy (ind*ncd,  astp,1,  astd,1)
      if ( ind.gt.21 ) call errmsg ('xdasin: too many s.p.-s found')
      if ( iprx.ge.1 ) call outvci ('iid/b-4',ind,iid)
      if ( iprx.ge.2 ) call outmat ('astd/b-4',9,9,ind,astd)
      return
      END subroutine xdasin
! **deck xdaspl
      subroutine xdaspl (knet,ipan,jpan,  indx,iidx,astx,  nssax,iprnt)
      implicit double precision (a-h,o-z)
      dimension indx(4), iidx(4,4), astx(4,4)
!                                  compute any special edge splines when
!                                  extra singularity parameters are pres
!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 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 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 dex(4,4), de(4), w(3), we(4), ze(3,5), z(3,4)           &
     &        , locx(4), xe(4), nwsdpt(4), izeloc(5)
      logical ident
!
      nt      =  ntd(knet)
      nmk     =  nm(knet)
      nnk     =  nn(knet)
      nma     =  nmk + 1
      nna     =  nnk + 1
      nss     =  nma*nna
      call jzero (indx,4)
      call jzero (iidx,16)
      call zero (astx,16)
      if ( nt.eq.18 ) nss = nna
      nxsp1   =  nxspa(knet) + 1
      nxsp2   =  nxspa(knet+1)
      nxspk   =  nxsp2 - nxsp1 + 1
      if ( nxspk .le. 0 ) go to 410
      if ( nt.eq.20 ) call errmsg ('extra s.p.-s on type 20 nw')
      if ( nt.eq.20 ) CALL AbortPanair('xdaspl')
!
      call zero (dex,16)
      do 300 kcr = 1,4
      icr     =  ipan + kcr/3
      jcr     =  jpan + mod(kcr,4)/2
      if ( icr.ne.1 .and. icr.ne.nmk .and. jcr.ne.1 .and. jcr.ne.nnk )  &
     &    go to 300
      if (  ( icr.eq.1 .and. jcr.eq.1 )  .or.                           &
     &      ( icr.eq.1 .and. jcr.eq.nnk) .or.                           &
     &      ( icr.eq.nmk .and. jcr.eq.1 ).or.                           &
     &      ( icr.eq.nmk .and. jcr.eq.nnk )    )  go to 300
!                                  panel corner  kcr  is on an edge but
!                                  not a netork corner
      if ( icr.eq.1 ) ksd = 1
      if ( jcr.eq.nnk ) ksd = 2
      if ( icr.eq.nmk ) ksd = 3
      if ( jcr.eq.1 ) ksd = 4
      call edgind (ksd,nmk,nnk,  kzedg,kncedg,kncint,knedg)
      kzedg   =  kzedg + nza(knet)
      if ( ksd.eq.1 ) kpt = jcr
      if ( ksd.eq.2 ) kpt = icr
      if ( ksd.eq.3 ) kpt = nnk + 1 - jcr
      if ( ksd.eq.4 ) kpt = nmk + 1 - icr
      nloc    =  0
      do 250 l = nxsp1,nxsp2
          call icopy (4,  locxsp(4*(l)-3),1, nwsdpt,1)
          lnw     =  nwsdpt(1)
          lsd     =  nwsdpt(2)
          lpt     =  nwsdpt(3)
          if ( lsd.ne.ksd ) go to 250
          idist   =  iabs( kpt - lpt )
          if ( idist.gt.1 ) go to 250
          if ( idist.eq.1 ) go to 220
!                                  this corner point is the site of an e
!                                  singularity parameter.
               locx(1) =  l
               go to 290
!
  220     continue
          nloc    =  nloc + 1
          locx(nloc) = l
  250 continue
      if ( nloc.le.0 ) go to 300
!                                  the current corner's spline is affect
!                                  by an extra singularity parameter.
!                                  compute the spline
!
!                                  gather up the neighboring mesh points
      do 260 i = 1,5
          ipt    =  i - 3 + kpt
          ipt    =  min ( knedg, max ( 1, ipt))
          izeloc(i)=  ipt
          kz1    =  kzedg + (ipt-1)*kncedg
          call dcopy (3, zm(1,kz1),1, ze(1,i),1)
  260 continue
!                                  compute the edge segment lengths and
!                                  get the locations of the s.p.'s
      do 265 i = 1,4
          z(1,i)  =  .5d0*( ze(1,i) + ze(1,i+1) )
          z(2,i)  =  .5d0*( ze(2,i) + ze(2,i+1) )
          z(3,i)  =  .5d0*( ze(3,i) + ze(3,i+1) )
          call distnc ( ze(1,i), ze(1,i+1), de(i) )
          call pident ( ze(1,i), ze(1,i+1), ident )
          if ( ident .or. (izeloc(i).eq.izeloc(i+1))  ) de(i) = 0.d0
  265 continue
      xe(1)   =  -de(2) - .5d0*de(1)
      xe(2)   =  -.5d0*de(2)
      xe(4)   =  de(3) + .5d0*de(4)
      xe(3)   =  .5d0*de(3)
!                                  get the naive s.p. indices of neighbo
!                                  singularity parameters
      do 275 i = 1,4
          ipt     =  kpt + i - 2
          go to (271, 272, 273, 274), ksd
  271     continue
               iidx(i,kcr)  =  1 + (ipt-1)*nma + nssax
               if ( nt.eq.18 ) iidx(i,kcr) = ipt + nssax
               go to 275
  272     continue
               iidx(i,kcr)  =  ipt + (nna-1)*nma + nssax
               go to 275
  273     continue
               iidx(i,kcr)  =  nma*(nna+1-ipt) + nssax
               go to 275
  274     continue
               iidx(i,kcr)  =  (nma+1-ipt) + nssax
               go to 275
  275 continue
!                                  now, replace default data with extra
!                                  s.p. data where appropriate
      do 280 iloc = 1,nloc
          l       =  locx(iloc)
          call icopy (4,  locxsp(4*(l)-3),1, nwsdpt,1)
          lpt     =  nwsdpt(3)
          if ( lpt .gt. kpt ) go to 277
!                                  lpt = kpt - 1
               call dcopy (3, ze(1,2),1, z(1,1),1)
               xe(1)   =  -de(2)
               iidx(1,kcr) = nss + nssax + (l+1-nxsp1)
               go to 280
!                                  lpt = kpt + 1
  277     continue
               call dcopy (3, ze(1,4),1, z(1,4),1)
               xe(4)   =  de(3)
               iidx(4,kcr) = nss + nssax + (l+1-nxsp1)
               go to 280
  280 continue
      call dcopy (4, xe,1,  dex(1,kcr),1)
!                                  get any upstream weighting factors
      do 285 i = 1,4
          call vadd ( z(1,i), -1.d0, ze(1,3), w, 3)
          wsq     =  w(1)**2 + w(2)**2 + w(3)**2
          we(i)   =  1.d0
          if ( wsq.le.0.d0  .or. amach.lt.1.d0 ) go to 285
          call uvect (w)
          call vip (w,1, compd,1, 3, wc)
          we(i)   =  1.d0 + amach*( 1.d0-wc )
  285 continue
      indx(kcr)  =  4
      call edgspl (xe,we,astx(1,kcr))
      go to 295
!                                  add a unit spline
  290 continue
      l       =  locx(1)
      indx(kcr) = 1
      iidx(1,kcr) =  nss + nssax + (l+1-nxsp1)
      astx(1,kcr) =  1.d0
!                                  common collection pt.
  295 continue
      if ( iprnt.le.0 ) go to 300
      write (6,'(1x,a10,1x, 10i12)')                                    &
     & 'in-xdaspl',knet,ipan,jpan,kcr,ksd,kpt,                          &
     &                            nxsp1,nxsp2,nloc,locx(1)
      if ( indx(kcr).eq.4 ) call outmat ('ze',3,3,5,ze)
  300 continue
!
  410 continue
      return
      END subroutine xdaspl
! **deck xfera
      subroutine xfera (a,b,n)
      implicit double precision (a-h,o-z)
      dimension a(n), b(n)
      if ( n.le.0 ) return
      do 10 i = 1,n
   10 b(i) = a(i)
      return
      END subroutine xfera
! **deck xsgcmp
      subroutine xsgcmp (kmp,nedmpa,nfsga,kfdseg,nnett                  &
     &                  ,kfsg1,kfsg2)
      implicit double precision (a-h,o-z)
      dimension  nedmpa(601), nfsga(601), kfdseg(3200), ivseg(4)
!         ORIGINAL VERSION OF FSGCMP:  LOOKING FOR MISSED ERRORS
!         find the index of the incoming fundamental edge segment (kfsg1
!         and the outgoing fundamental edge segment (kfsg2) for edge
!         mesh point  kmp
      nind    =  4*nnett + 1
      call ibsrch (nedmpa,nind,kmp,l)
      if ( l.le.0 .or. l.ge.nind ) go to 1100
      knet    =  (l+3)/4
      iedg1   =  4*(knet-1)+1
      ifsg1   =  nfsga(iedg1)+1
      ifsg2   =  nfsga(iedg1+4)
!
      kfsg1   =  ifsg2
      do 100 ifsg = ifsg1,ifsg2
          call icopy (4,  kfdseg(4*ifsg-3),1, ivseg,1)
          call edgmpi (ivseg(2),ivseg(3),nedmpa,  kmp1)
          call edgmpi (ivseg(2),ivseg(4),nedmpa,  kmp2)
          kfsg2   =  ifsg
          if ( kmp.le.kmp1 ) go to 200
          kfsg1   =  ifsg
          if ( kmp.lt.kmp2 ) go to 200
  100 continue
      kfsg2   =  ifsg1
  200 continue
      return
!
 1100 continue
      write (6,'(1x,a10,1x, 3i12)')                                     &
     & 'nind,l,kmp',nind,l,kmp
      call outvci ('nedmpa',nind,nedmpa)
      call abtend ('xsgcmp error:  index not found')
      END subroutine xsgcmp
! **deck xtrns
      subroutine xtrns (irec,iar,lth)
      implicit double precision (a-h,o-z)
      dimension iar(1:*)
!call xrwi
      common /xrwi/ ntxrwi, nnxrwi, nwxrwi(200), nixrwi(202)
!end  xrwi
      lth     =  nwxrwi(irec)
      if ( lth.le.0 ) return
      call readms (ntxrwi,iar,lth,irec)
      return
      END subroutine xtrns
! **deck xxadj
      subroutine xxadj(p0,p1,p2,al,z)
      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 * * *                   *
!     *                         - - - - - - -                         *
!     *                                                               *
!     *  withraw vertex of triangle a fraction of the distance along  *
!     *  its angle bisector.                                          *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  calculate vectors from given vertex to two other verticies.  *
!     *  add a suitable linear combination of these vectors to given  *
!     *  vectex position.                                             *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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                   *
!     *                                                               *
!     *   al        argument  input     fraction of bisector length   *
!     *                                                               *
!     *   p0        argument  input     given vertex                  *
!     *                                                               *
!     *   p1        argument  input     other vertex                  *
!     *                                                               *
!     *   p2        argument  input     remaining vertex              *
!     *                                                               *
!     *   z         argument  output    withdrawn position of vertex  *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      dimension p0(3),p1(3),p2(3),z(3),v1(3),v2(3)
!c
!     *  calculate vectors from given vertex to two other verticies.  *
!
      call vadd(p1,-1.d0,p0,v1,3)
      call vadd(p2,-1.d0,p0,v2,3)
      call mag(v1,v1m)
      call mag(v2,v2m)
!c
!     *  add a suitable linear combination of these vectors to given  *
!     *  vertex position.                                             *
!
      do 100 i=1,3
  100 z(i)=p0(i)+al*(v2m*v1(i)+v1m*v2(i))/(v1m+v2m)
      return
      END subroutine xxadj
! **deck ytrns
      subroutine ytrns (irec,iar,lth)
      implicit double precision (a-h,o-z)
      dimension iar(*)
!
!         read a record of data from unit  ntyrwi,  a random unit with
!         control information in /yrwi/
!
!         irec    i   int   index of record to read
!         iar     o   int   on exit, iar(1:lth) is the data read
!         lth     o   int   number of data items read, retrieved from /y
!
!         michael epton, 30 november 1988
!
!         limitations: don't write more records than allowed by /yrwi/ d
!                      allocations
!
!call yrwi
      common /yrwi/ ntyrwi, nnyrwi, nwyrwi(200), niyrwi(202)
!end  yrwi
      lth     =  nwyrwi(irec)
      if ( lth.le.0 ) return
      call readmd (ntyrwi,iar,lth,irec)
      return
      END subroutine ytrns
! **deck zaxpy
      subroutine zaxpy (n,  a,  x,ix,  y,iy)
      implicit double precision (a-h,o-z)
      complex*16 x(1), y(1), a
!
!        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 zaxpy
! **deck zcadj
      subroutine zcadj
      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 withdraw network edge control points from network edges   *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!c    *                    * * * m e t h o d * * *                    *
!     *                          - - - - - -                          *
!     *                                                               *
!     *  the routine withdraws edge control points from their         *
!     *  respective panel edges to avoid numerical difficulties       *
!     *  associated with infinite self-induced velocities.            *
!     *  the loop terminating at statement label 100 identifies an    *
!     *  edge control point as an edge midpoint or corner point.      *
!     *  the respective calculations are performed from statements    *
!     *  labeled 200 through 300 and from statement label 300 through *
!     *  end.                                                         *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!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)         *
!     *                                                               *
!     *   deltac    -local-   - - - -   fraction of distance control  *
!     *                                 point is withdran from panel  *
!     *                                 corner                        *
!     *                                                               *
!     *   deltam    -local-   - - - -   fraction of distance control  *
!     *                                 point is withdran from panel  *
!     *                                 edge midpoint                 *
!     *                                                               *
!     *   deltar    -local-   - - - -   praction of ratio of minimum  *
!     *                                 distance dm to distance from  *
!     *                                 control point to panel center *
!     *                                                               *
!     *   di        -local-   - - - -   distance from control point to*
!     *                                 endpoint of side on which     *
!     *                                 control point is midpoint     *
!     *                                                               *
!     *   dm        -local-   - - - -   minimum of d4,d7 and di       *
!     *                                                               *
!     *   d4        -local-   - - - -   distance from edge midpoint   *
!     *                                 coinciding with control point *
!     *                                 to panel center               *
!     *                                                               *
!     *   d7        -local-   - - - -   distance from adjacent edge   *
!     *                                 midpoint to panel center      *
!     *                                                               *
!     *   ics       /pandq/   input     =0 - panel is quadrilateral   *
!     *                                 =1 thru 4 - panel is triangle *
!     *                                     because edge ics is       *
!     *                                    collapsed                  *
!     *                                                               *
!     *   ident     -local-   - - - -   logical variable              *
!     *                                 =.true.   if two points are   *
!     *                                           considered          *
!     *                                           coincident          *
!     *                                 =.false.  otherwise           *
!     *                                                               *
!     *   is        -local-   - - - -   index of loop over panel edges*
!     *                                                               *
!     *   l         -local-   - - - -   index of loops over           *
!     *                                 coordinates                   *
!     *                                                               *
!     *   zc        argument  input     global coordinates of control *
!     *                                 point                         *
!     *                                                               *
!     *   znc       argument  output    global coordinates of surface *
!     *                                 normal at control point       *
!     *                                                               *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
      logical ident
!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 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
      data deltac,deltam /.25d0,.125d0/
!c
!     *  loop ranges over panel sides                                 *
!
      do 100 is=1,4
      isave=is
      isp4=is+4
      isp3=mod(is+2,4)+1
      isp7=isp3+4
!c
!     *  check if control point is midpoint of an edge                *
!
      call pident(zc,cp(1,isp4),ident)
!c
!     *  if essentially a midpoint, branch to statement label 200     *
!
      if(ident) go to 200
!c
!     *  omit further tests for this panel side when panel is triangle*
!     *  and corner will be tested when is=ics                        *
!
      if(isp3.eq.ics) go to 100
!c
!     *  check if control point is endpoint of panel side, i.e. panel *
!     *  corner point                                                 *
!
      call pident(zc,cp(1,is),ident)
      if(ident) go to 300
  100 continue
      call errmsg ('control point not on panel')
      return
  200 continue
!c
!     *  calculations for midpoint of an edge.                        *
!
!c
!     *  determine fraction of distance  control point is to be       *
!     *  withdrawn                                                    *
!
      call distnc(cp(1,isp4),cp(1,9),d4)
      call distnc(cp(1,isp7),cp(1,9),d7)
      call distnc(cp(1,isp4),cp(1,isave),di)
      dm= min (d4,d7,di)
      deltar=deltam*dm/d4
      if(ics.eq.isave) deltar=deltac
!c
!     *  withdraw control point from edge midpoint along              *
!     *  one of the adjacent interior sub-panel angle bisectors       *
!     *  a fraction deltam of the distance to the sub-panel opposite  *
!     *  edge                                                         *
!
      call xxadj(cp(1,isp4),cp(1,9),cp(1,isp7),deltar,zc)
      go to 500
  300 continue
!c
!     *  calculations for network corner point                        *
!
!c
!     *  withdraw control point along corner angle bisector by a      *
!     *  fraction deltac of the distance from corner to corresponding *
!     *  sub-panel opposite edge                                      *
!
      call xxadj(cp(1,isave),cp(1,isp4),cp(1,isp7),deltac,zc)
  500 continue
      return
      END subroutine zcadj
! **deck zcmpr
      subroutine zcmpr(msg,a,b,n,l)
      implicit double precision (a-h,o-z)
      dimension a(n), b(n)
      character*(*) msg
!call prcmpr
!                                                            /prcmpr/
      common /prcmpr/ llcmpr
      logical llcmpr
!end  prcmpr
      dimension iloc(10)
      data tol/1.d-5/
      k = 0
      do 100 i = 1,n
      if ( abs(a(i)-b(i)) .lt. tol ) go to 100
      if ( abs(a(i)-b(i)) .lt. tol*abs(a(i))  )  go to 100
      k = k + 1
      if ( k.le.10 ) iloc(k) = i
  100 continue
      l = l + k
      kk = min (k,10)
      if ( k.ne.0 .and.llcmpr ) call outvci (msg,kk,iloc)
      if ( k.ne.0 .and. llcmpr ) then
         call outvec ('a',n,a)
         call outvec ('b',n,b)
      endif
      return
      END subroutine zcmpr
! **deck zcopy
      subroutine zcopy (n,  x,ix,  y,iy)
      implicit double precision (a-h,o-z)
      dimension x(1), y(1)
      complex*16 x, y
!
!        standard blas zcopy
!
      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 zcopy
! **deck zero
      subroutine zero (a,n)
      implicit double precision (a-h,o-z)
      dimension a(n)
!
!         zero out an array of n real numbers
!
      do 100 k = 1,n
          a(k) = 0.d0
  100 continue
      return
      END subroutine zero
! **deck zisct1
      subroutine zisct1 (m,n  ,a,na  ,ind  ,b,nb)
      implicit double precision (a-h,o-z)
      dimension a(na,n), b(nb,n)
      complex*16 a, b
      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 zisct1
! **deck zisct2
      subroutine zisct2 (m,n  ,a,na  ,ind  ,b,nb)
      implicit double precision (a-h,o-z)
      dimension a(na,n), b(nb,n)
      complex*16 a, b
      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 zisct2
! **deck zjsct1
      subroutine zjsct1 (m,n  ,a,na  ,ind  ,b,nb)
      implicit double precision (a-h,o-z)
      dimension a(na,n), b(nb,n)
      complex*16 a, b
      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 zjsct1
! **deck zjsct2
      subroutine zjsct2 (m,n  ,a,na  ,ind  ,b,nb)
      implicit double precision (a-h,o-z)
      dimension a(na,n), b(nb,n)
      complex*16 a, b
      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 zjsct2
! **deck zmerge
      subroutine zmerge (npt,zpt,zavg)
      implicit double precision (a-h,o-z)
      dimension zpt(3,npt), zavg(3)
!         compute a representative point for a number of closely
!         placed points.
      zavg(1) =  0.d0
      zavg(2) =  0.d0
      zavg(3) =  0.d0
      do 10 j = 1,npt
          zavg(1) =  zavg(1) + zpt(1,j)
          zavg(2) =  zavg(2) + zpt(2,j)
          zavg(3) =  zavg(3) + zpt(3,j)
   10 continue
      f       =  1.d0/npt
      zavg(1) =  f*zavg(1)
      zavg(2) =  f*zavg(2)
      zavg(3) =  f*zavg(3)
      return
      END subroutine zmerge
! **deck zmproj
      subroutine zmproj (z1,z2,  x,taux)
      implicit double precision (a-h,o-z)
      dimension z1(3), z2(3), x(3), dz(3), xmz(3)
!         project  x  onto the line  (z1,z2)  and report back the value
!         of  tau  for the projection point.
      xmz(1)  =  x(1) - z1(1)
      xmz(2)  =  x(2) - z1(2)
      xmz(3)  =  x(3) - z1(3)
!
      dz(1)   =  z2(1) - z1(1)
      dz(2)   =  z2(2) - z1(2)
      dz(3)   =  z2(3) - z1(3)
!
      dzsq    =  dz(1)*dz(1) + dz(2)*dz(2) + dz(3)*dz(3)
      dzxmz   =  dz(1)*xmz(1) + dz(2)*xmz(2) + dz(3)*xmz(3)
      taux    =  dzxmz/dzsq
!
      x(1)    =  z1(1) + taux*dz(1)
      x(2)    =  z1(2) + taux*dz(2)
      x(3)    =  z1(3) + taux*dz(3)
      return
      END subroutine zmproj
! **deck zscal
      subroutine zscal (n,  a,   y,iy)
      implicit double precision (a-h,o-z)
      dimension  y(1)
      complex*16 a, y
!
!        standard blas zscal
!
      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 zscal
! **deck zswap
      subroutine zswap (n,  x,ix,  y,iy)
      implicit double precision (a-h,o-z)
      dimension x(1), y(1)
      complex*16 x, y, xsv
!
!        standard blas zswap
!
      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 zswap
! **deck zwindg
      subroutine zwindg (n,x,y,zc,izc,ierr)
      implicit double precision (a-h,o-z)
!         compute the product
!                      n
!              z  =  prod (  x(j)+i*y(j)  )
!                     j=1
!
!         and keep track of the quadrant at the same time.
!         at exit, we have,
!               n
!              sum  atan2( y(j), x(j)) = 2*pi*izc + atan2(im(zc),re(zc))
!              j=1
!
      dimension  x(n), y(n), uv(2)
      complex*16 z, zc
      equivalence (z,uv(1),u), (uv(2),v)
!
      i       =  1
      k       =  1
      u       =  1.d0
      v       =  0.d0
      ierr    =  0
!
      do 505 j = 1,n
          if ( y(j).eq.0.d0) go to 300
                                                  ! was dcmplx
          z       =  z*CMPLX(x(j),y(j),KIND=8)
          if ( y(j).lt.0.d0) go to 200
!                                  y(j) .gt. 0, increasing phase
! 100     continue
          go to (110,120,130,140), k
!
  110     continue
          if ( u.gt.0.d0 ) go to 150
               k       =  k+1
               i       =  i+1
!
  120     continue
          if ( v.gt.0.d0 ) go to 150
               k       =  k+1
               i       =  i+1
!
  130     continue
          if ( u.lt.0.d0 ) go to 150
               k       =  k+1
               i       =  i+1
!
  140     continue
          if ( v.lt.0.d0 ) go to 150
               k       =  k+1
               i       =  i+1
               if ( k.le.6 ) go to 110
               go to 1100
!
  150     continue
          if ( k.gt.4 ) k = k-4
          go to 500
!                                  y(j) .lt. 0, decreasing phase
  200     continue
          go to (210,220,230,240), k
!
  240     continue
          if ( u.gt.0.d0 ) go to 250
               k       =  k-1
               i       =  i-1
  230     continue
          if ( v.lt.0.d0 ) go to 250
               k       =  k-1
               i       =  i-1
!
  220     continue
          if ( u.lt.0.d0 ) go to 250
               k       =  k-1
               i       =  i-1
!
  210     continue
          if ( v.gt.0.d0 ) go to 250
               k       =  k-1
               i       =  i-1
               if ( k.ge.(-1)) go to 240
               go to 1100
  250     continue
          if ( k.lt.1 ) k = k+4
          go to 500
!                                  y(j) = 0, change is either 0 or +pi
  300     continue
          if ( x(j).ne.0 ) go to 310
!                                  x(j) = y(j) = 0, no change, but error
               ierr    =  ierr+1
               go to 500
!                                  x(j).ne.0, y(j)=0
  310     continue
               z       =  z*x(j)
               if ( x(j).gt.0.d0 ) go to 500
                    k       =  k+2
                    i       =  i+2
                    if ( k.gt.4 ) k = k-4
  500 continue
      auv     =  abs(u) + abs(v)
      u       =  u/auv
      v       =  v/auv
  505 continue
!                                  ensure consistency
      izc     =  (i-k)/4 + (k+1)/4
      go to (510,520,530,540), k
  510 continue
      if ( u.ge.0.d0  .and.  v.ge.0.d0 ) go to 600
      go to 1200
!
  520 continue
      if ( u.le.0.d0  .and.  v.ge.0.d0 ) go to 600
      go to 1200
!
  530 continue
      if ( v.eq.0.d0) izc = izc - 1
      if ( u.le.0.d0  .and.  v.le.0.d0 ) go to 600
      go to 1200
!
  540 continue
      if ( u.ge.0.d0  .and.  v.le.0.d0 ) go to 600
      go to 1200
!
  600 continue
      if ( u.eq.0.d0  .and.  v.eq.0.d0 ) go to 1200
!
      zc      =  z /( abs(u) + abs(v) )
!
!
      return
!         *****     *****     *****     *****     *****     *****
!                                  error returns
 1100 continue
 1200 continue
      write (6,6000)
 6000 format ('  zwindg error ')
      stop
      END subroutine zwindg