! **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