$
$     THIS ALTER IS CONFIDENTIAL AND A TRADE SECRET OF THE 
$     MACNEAL-SCHWENDLER CORP.  THE RECEIPT OR POSSESSION OF
$     THIS ALTER DOES NOT CONVEY ANY RIGHTS TO REPRODUCE OR
$     DISCLOSE ITS CONTENTS, OR TO MANUFACTURE, USE, OR SELL
$     ANYTHING HEREIN, IN WHOLE OR IN PART, WITHOUT THE 
$     SPECIFIC WRITTEN CONSENT OF THE MACNEAL-SCHWENDLER CORPORATION.     
$
$  checka.v707 - 9/7/99, 9/20/99
$
$  checka.v706 -- 11/30/98, 2/9/99, Aug 9, 1999, Sept 3, 1999 (store GPLS)
$
$ updated May, 1999 to allow for data recovery on the results of 
$  rigid-body checks - output will include any results requested in
$  the first SUBCASE in your case control
$  Also allows for data recovery on mechnisms (PARAM,MECHOUT,-1)
$
$ updated Aug 9, 1999 - corrected for internal resequencing in dcmp module
$
$  user interface:
$
$  PARAM,POST,-1 = write results for PATRAN to display (will write to 
$                  OUTPUT2 file for PATRAN - note: results will not be labeled
$                  for each check case, there will be 6 static vectors ("modes"
$                  in SOL 103) created for each check (G-, N-, and A-set) 
$                  performed
$  
$  PARAM,OUNITRB,i = unit number for post-processing output of rigid-body checks
$                   default value = ounit2
$
$  PARAM,CHECKDR,i = enable data recovery for model failed check results
$                  -1 = default = matrix printout as in prior versions
$                   0 = for all failed checks (G, N, and A)
$                   1 = G-set check only
$                   2 = N-set check only
$                   3 = F-set check only (requires PARAM,CHKSTIFF,1)
$                   4 = A-set check only
$
$  PARAM,QUITDR,-1 = flag to quit as soon as first data recovery on failed
$                    rigid body test is printed
$                   -1 = default = quit after first data recovery for failure
$                    1 = keep on going
$
$  PARAM,MECHOUT,-1 = flag for mechanism output - if the run has a singular
$                     stiffness matrix, this parameter will cause the alter
$                     to perform data recovery using unit displacements on
$                     the identified dof. They will be labeled as 0.0 hz
$                     modes and the output will be available for MSC/PATRAN
$                    1 = default = do not perform data recovery on mechanisms
$                   -1 = perform data recovery on mechanisms (set PARAM,POST,-1
$                        to write the results for MSC/PATRAN)
$
$  PARAM,OUNITMCH,i = unit number for post-processing output of mechanisms
$                   default value = ounit2
$
$ updated April, 1999 to correct row and column identification on
$ effective weight output
$
$ updated March, 1999 - added F-set stiffness check
$ controlled by PARAM,CHKSTIFF,1 (default = -1) in addition to 
$    PARAM,CHKSTIF or CHECKA being set 
$
$   added:
$   PARAM,TOLF - acceptable strain energy tolerance for check
$    on KFF before run will terminate.
$    default = -1.0 => do not terminate due to strain energy tolerance
$
$ 
$
$ CHECKA is recommended for SOL 101 and 103
$
echooff
$  checka.v705 -- 4-13-98
$
$ added mechanism check for normal modes. This check is not
$ done by default, as it is possible that your model may
$ have intentional mechanisms. If your model should not have
$ any mechanisms or rigid-body modes, then use this check 
$ before you waste too much cpu....
$ Interface:
$
$ PARAM,CKMCHNSM,YES   (default = no) - only works in modal sol's
$
$     updated for v70   6-13-97
$ Following new PARAM's are Available:
$
$
$    PARAM,TOLGN - acceptable strain energy tolerance for check
$    on KGG and KNN before run will terminate.
$    default = -1.0 => do not terminate due to strain energy tolerance
$
$    PARAM,CHECKTOL - acceptable strain energy tolerance before the
$    alter will print that a direction has failed the check. 
$    default = the program will calculate a value
$ 
$    PARAM,TOLKAA - acceptable strain energy in the check of
$    KAA before the run will terminate
$    default = -1. => do not terminate due to KAA strain energy check
$
$    PARAM,PRINTOL - tolerance on printout of normalized reactions
$    when performing rigid-body tests.
$    default = .1
$
$    PARAM,QUIT - manual  exit point during checka evaluation. Value 
$    determines if run terminates after (1) G-size (2) N-size or
$    (3) - A-size reduction.
$    default = no manual termination
$ 
$ DMAP alter checka.v691 - updated March, 1997
$
$
$
$ file checka.v691
$
$ updated March, 1997 to clean up printing.
$  and add automated calculation of checktol
$
$ added PARAM,CHECKA - stiffness check parameter - 
$      default = 'NO'  = same as chkstif=-1
$                'YES' = same as chkstif=1
$
$ added PARAM,TOLGN - acceptable strain energy tolerance for check
$    on KGG and KNN before run will terminate.
$    default = -1.0 => do not terminate due to strain energy tolerance
$    
$ added PARAM,TOLKAA - acceptable strain energy in the check of
$    KAA before the run will terminate
$    default = -1. => do not terminate due to KAA strain energy check
$
$ added PARAM,PRINTOL = tolerance on printout of normalized reactions
$   when performing rigid-body tests. 
$   default = .1
$
$ updated Jan, 1997 - added rotational KE plots
$                     added fix for CSR 7789 - at start of alter
$
$
$          new parameters:
$           NOKENG = print and plot kinetic energy
$                  -1 => default = no formatted print of plots
$                  <>-1 => formatted print and create plots
$
$           NOROKEPL => plots of rotational kinetic energy
$                  -1 => default => no plots of rotational KE
$                 <> -1 => plot rotational KE
$
$           NOREKRPL => plots of translational KE - needs NOKENG<>-1
$                  -1 => default = no plots of translational KE
$                  <>-1 => plot translational KE
$           NOROUPPL => upstream plots of kinetic energy - needs NOKENG<>-1
$                  -1 => default = translational KE upstream plots
$                  <>-1 => rotational KE upstream plots
$
$
$           added Lanczos SUPORT capability - this will make Lanczos treat a
$           SUPORT entry like Givens, Housholders, and Inverse Power
$           controlled by PARAM,LANSUP
$
$      if LANSUP = 1 treat SUPORT in Lanczos the same as other methods
$      if LANSUP <>1 (default)Lanczos as usual
$
$
$ updated 8/1996 - update for v69. No change on algorithm (Zhonglin Han)
$
$
$ updated 4/1995 - added PARAM,FRACT - determines which weight is used to
$             determine the effective weight fractions -
$             fract => 1 = g, 2 = a
$             default = 1
$             if A and an exterior point of an upstream superelement
$             is constrained, then the fractions may be incorrect
$           - this is due to the GUYAN reduction producing off-diagonal
$             terms in the mass matrix and constraining may change the
$             A-set mass properties.
$
$
$ updated 3/5/1995 - changed defaults for chkmass(1), chkstif(1)
$                                         keprt(1), efwgt(2)
$                    by default, they are all performed, instead of
$                    requiring the user to turn them on.
$
$
$
$ ALTER TO COMPUTE KINETIC ENERGY AND EFFECTIVE WEIGHT
$         FROM U.C. PAPER (1988) BY T. ROSE
$ Designed to work in SOLs 101 and 103
$
$  W A R N I N G - KINETIC ENERGY AND EFECTIVE WEIGHT CALCULATION ASSUME THAT
$                  MODES ARE NORMALIZED TO UNIT MASS. THERE IS NO CHECK IN THE
$                  DMAP ALTER FOR THIS.
$
$
$   modified 8/17/94
$        added param,quit -
$               if quit>-0 then alter will terminate after checking
$                (that is, the processing will move to the next superelement
$                 without completing the current one - this can reduce the cost
$                 of model checkout)
$                      1 = quit after checking kgg
$                      2 = quit after checking knn
$                      3 = quit after checking kaa
$
$    CURRENT VERSION - April, 1994 - V68
$
$                    - 11-18-1993 - V675 - added param,oldefw -
$                      oldefw=-1 -> retain sign of effective weight (default)
$                      oldefw>-1 -> absolute value of effective weight
$
$                     Also added element kinetic energy printout -
$                       this is controlled by the ESE case control command
$                       and a parameter, elemke.
$                      elemke = -1 -> no element kinetic energy (default)
$                      elemke>-1 and ESE in case control -> element KE
$
$                    - 7-26-1993 - V675 - added param,spcsum -
$                      spcsum = -1 (default) don't sum autospc forces
$                      spcsum = 1 = provide summation of forces from dof
$                                   constrained by autospc
$
$                     4-28-1993 - V67.5
$
$                        added kinetic energy summaries by direction
$
$                    12-08-1992 - V67
$
$                        added PARAM,KEFILTER - default .01
$                        filter on kinetic energy terms for printout.
$                        Any dof with kinetic energy fraction greater than
$                        KEFILTER will be printed if KEPRT>=0
$
$                    10-12-1992 - V67
$
$                        added option to set all SEQSET dof to 0.0 for output
$                        (this allows scaling for plots based on the physical
$                         deformations only)
$                        also changed so that stiffness checks, mass checks,
$                        and
$                        effective weight don't include Q-set dof)
$                        also modified effective weight calculation so that
$                        the DMAP alter may be used on a restart, even if it
$                        wasn't in the original run.
$
$              10-6-92 - correction to assembly plots if GRID points
$                        are used for component modes - also removed
$                        Qset dof from kinetic energy printout
$                        controlled by parameter DONTQSET -
$                        default = -1 => no qset data recovery
$                                     (plots will not be scaled by qset dof)
$                                = 1 => normal data recovery
$
$              9-8-92 - corrected problem if no reduction is performed
$
$              7-21-1992 - ADDED PARAM,CHECKTOL - tolerance on
$        stiffness matrix rigid body checks - if the diagonal
$        values of the strain energy in the check matrices
$        are less than CHECKTOL, then a message will be printed
$        stating that the matrices passed the rigid-body check
$                         default = 1.e-5
$
$              7-10-1992 - skip CHECKING KAA and MAA if
$       there is no A-set reduction from the last check 7-10-1992
$
$              6-12-1992 TO ADD EFFECTIVE WEIGHT FRACTIONS
$                 IF EFWGT=2  - CALCULATE EFFECTIVE WEIGHT FRACTIONS
$                    3/4/1995 removed requirement for chkmass to get fractions
$
$              1-27-1992 TO FIX CHECK OF MNN AND KNN AND ADD OPTIONS TO
$             CHKSTIF AS FOLLOWS
$                 IF CHKSTIF = 1 - CHECK KGG, KNN, AND KAA
$                 IF CHKSTIF = 2 - CHECK KGG AND KNN
$                 IF CHKSTIF = 3 - CHECK KGG ONLY
$             (CHKMASS IS SIMILAR)
$
$     CONVERTED FROM V66A TO V67 1-27-1992
$
$     MODIFIED TO ADD GPWG WITH UPSTREAMS AND STIFFNESS CHECK
$          WITHOUT KLAA - NOV, 1991
$
$     MODIFIED FOR VERSION 66A - APRIL, 1990
$
$     MODIFIED JULY 17, 1990 - CHANGED USET TO USETB ON MATGPR FOR REACN
$
$       INCLUDES SECONDARY S.E.
$
$       ADD CALLS FROM SEKR FOR CHECKS AND "RIGID" BODY VECTORS
$
$     MODIFIED JULY 11, 1990 - ADDED TYPE PARM,,I,Y,(GRDPNT=0) TO
$                              SUBDMAP CHECK TO ALLOW CHECKS ABOUT USER
$                              SPECIFIED GRIDPOINT
$
$    MODIFIED APRIL 19, 1990 - SKIP ASET IF NO REDUCTION
$
$    MODIFIED NOV 1, 1989 - NORMALIZE 'REAC' VECTORS
$
$$ -------------------------------------------------------------------
$
compile sekrrs, list
$
$ mechanism data recovery - added 5/21/99 - param,mechout,-1
$
alter '9050'(,-1)
type parm,,i,y,mechout=1 $
type parm,nddl,i,y,post,ounit2 $
type parm,,i,y,ounitmch=-1 $
type parm,,i,n,ountmch=-1  $
$message //'mechout='/mechout $
   if(mechout=-1)then $
$ 
$ data recovery on mechanisms
$
     DIAGONAL kll/MATRD $                                                         
$ handle resequencing inside DECOMP
     matmod lll,,,,,/d,l/21 $
$     matprn d,l// $
     paraml l//'trailer'/1/s,n,nocol $
     paraml l//'trailer'/2/s,n,norow $
     matgen ,/partit/6/nocol/norow/norow $
     partn l,partit,/left,,reseq,/1 $
$     matprn reseq// $
     smpyad reseq,d,reseq,,,/dres/3////1 $
$     matprn dres// $
$
$     matmod dres,,,,,/factd,/7 $ max terms = diagonal terms in proper order
     diagonal dres/factd $
$     matprn factd,matrd// $
$     DIAGONAL LLL/FACTDiag $ 
$     matprn factdiag// $                                                        
     ADD      MATRD,FACTD/RATIOS///2 $
     MATMOD   RATIOS,,,,,/BIGRATS,/2////maxratio $                                 
     PARAML   BIGRATS//'TRAILER'/5/S,N,NB=0 $                                     
     IF ( NB>0 ) THEN $                                                           
      message //' data recovery performed for the following '/
            ' singular dof' $
      message //' ' $
type db,gpls,cases $
      MATGPR   GPLS,USET,SILS,BIGRATS//'h'/'l' $                                               
      PARTN    KLL,BIGRATS,/mkZZa,,kxa, $                                           
      DECOMP   MkZZa/LMU,umu,/////////16 $                                               
      fbs      lmu,umu,kxa/ux/-1/-1/0/0 $
      paraml   kxa//'trailer'/1/s,n,nodof $
      matgen   ,/ident/1/nodof $
      merge    ux,ident,,,,bigrats/mechmat/1 $
type db,got,gm,kfs,kss,cstms,mpts,dit,bgpdts,ett,est
type db,gpsnts,deqatn,deqind,ditid $
      SDR1     USET,,mechmat,,,GOT,GM,,KFS,KSS,/              
               UGmech,,QGa/NSKIP/'reig'/NOQG $                                    
      case cases,/case1dr/'tran' $
      matgen ,/zeromat/7/5/nodof $
      lamx zeromat,/zerolama $
      SDR2     CASE1DR,CSTMS,MPTS,DIT,EQEXINS,,ETT,zerolama,BGPDTS,                      
              ,qga,ugmech,EST ,,,,,GPSNTS,                  
              DEQATN,DEQIND,DITID/                                                
              OPG1,OQG1,OUGV1,OES1,OEF1,PUGV/'reig'/S,N,NOSORT2/                    
              NOCOMPS/////ACOUT/PREFDB/-1./-1./                                   
              ADPTINDX/ADPTEXIT/FALSE $ 
     message //' ' $
     message //' the following output is the mechanisms in your model' $
     message //' ' $  
     ofp opg1,oqg1,ougv1,oes1,oef1// $
     message //' ' $
     message //' the previous output is the mechanisms in your model' $ $
     message //' ' $ 
      if(ounitmch=-1)then $
        ountmch=ounit2 $ 
      else $
        ountmch=ounitmch $
      endif $
     if(post=-1)output2 oqg1,ougv1,oes1,oef1///ounitmch $                                        
    ENDIF $                                                                      
   else $ mechout<>-1
  message //'if these dof were moved 1.0 units. Then determine what'/
            ' is causing the singularities' $
  message //' ' $
  message //' this can be done by setting PARAM,mechout,-1 - then the'/
        ' alter will perform data recovery using unit displacements' $
  message //'  of the singular dof - the results will be given '/
         'eigenvalues of 0.0 and written for MSC/PATRAN to view' $
$
  message //'if the cause of the singularities is not obvious, then'/
            ' perform a sol 101 run with enforced displacements of ' %
  message //'1.0 units at each of the indicated dof.' $
  message //'the resulting deformed shapes should make the mechanisms'/
            ' obvious' $
   endif $ mechout=-1
$$ -------------------------------------------------------------------
compile moders $
$ 
$ check for mechanisms - added 4/13/98 - V70.5
$ updated 5/21/99 - perform data recovery on mechanisms if MECHOUT=-1
$
alter 8
type parm,,char8,y,ckmchnsm='no' $
type parm,nddl,i,y,post,ounit2 $
type parm,,i,y,ounitmch=-1 $
type parm,,i,n,ountmch=-1 $
type parm,,i,y,mechout=1 $ flag for data recovery on mechanisms
$
$
if(ckmchnsm='yes')then $
$
$ check for mechanisms
$
 message //' ' $
 message //'based on user request, the alter checka is '/
           'checking the model for mechanisms' $
 message //' ' $
 DCMP   USET,SILS,EQEXINS,mkaa,,/
        LLLaa,ULLaa,LRSEQaa/
        -1/0/0/1.+7/'a'/1.E-20/-1//////
        S,N,SING/S,N,NBRCHG/S,N,ERR $ - BAILOUT set manually to 0
$       -1/0/BAILOUT/MAXRATIO/'L'/1.E-20/DECOMP//////
 if(sing<0 or err<0)then $
  if(sing<0)then $
   message //' ' $
   message //'stiffness is singular' $
   message //' ' $
  else if(err<0)then $
   message //' ' $
   message //'mechanisms found in stiffness' $
   message //' ' $
  endif $
  message //' ' $
  message //'immediately preceding this message, there is a table'/
            'provided indicating potential singularities' $
  message //'the dof identified in this table are the final dof'/
            'in the matrix which can define the singularities' $
  message //'do not simply constrain these dof. Usually it is better'/
            ' to determine what the motion of the model would be' $
   if(mechout=-1)then $
$ 
$ data recovery on mechanisms
$
     DIAGONAL Mkaa/MATRD $                                                         
     DIAGONAL Lllaa/FACTD $                                                         
     ADD      MATRD,FACTD/RATIOS///2 $
type parm,nddl,rs,n,maxratio                                            
     MATMOD   RATIOS,,,,,/BIGRATS,/2////maxratio $                                 
     PARAML   BIGRATS//'TRAILER'/5/S,N,NB=0 $                                     
     IF ( NB>0 ) THEN $                                                           
      message //' data recovery performed for the following '/
            ' singular dof' $
      message //' ' $
      MATGPR   GPLS,USET,SILS,BIGRATS//'a' $                                               
      PARTN    Mkaa,BIGRATS,/mkZZa,,kxa, $                                           
      DECOMP   MkZZa/LMU,umu,/////////16 $                                               
      fbs      lmu,umu,kxa/ux/-1/-1/0/0 $
      paraml   kxa//'trailer'/1/s,n,nodof $
      matgen   ,/ident/1/nodof $
      merge    ux,ident,,,,bigrats/mechmat/1 $
type db,got,gm,kfs,kss,cstms,mpts,dit,bgpdts,ett,est
type db,gpsnts,deqatn,deqind,ditid $
      SDR1     USET,,mechmat,,,GOT,GM,,KFS,KSS,/              
               UGmech,,QGa/NSKIP/'reig'/NOQG $                                    
      case cases,/case1dr/'tran' $
      matgen ,/zeromat/7/5/nodof $
      lamx zeromat,/zerolama $
      SDR2     CASE1DR,CSTMS,MPTS,DIT,EQEXINS,,ETT,zerolama,BGPDTS,                      
              ,qga,ugmech,EST ,,,,,GPSNTS,                  
              DEQATN,DEQIND,DITID/                                                
              OPG1,OQG1,OUGV1,OES1,OEF1,PUGV/'reig'/S,N,NOSORT2/                    
              NOCOMPS/////ACOUT/PREFDB/-1./-1./                                   
              ADPTINDX/ADPTEXIT/FALSE $ 
     message //' ' $
     message //' the following output is the mechanisms in your model' $
     message //' ' $  
     ofp opg1,oqg1,ougv1,oes1,oef1// $
     message //' ' $
     message //' the previous output is the mechanisms in your model' $ $
     message //' ' $  
      if(ounitmch=-1)then $
        ountmch=ounit2 $ 
      else $
        ountmch=ounitmch $
      endif $
     if(post=-1)output2 oqg1,ougv1,oes1,oef1///ountmch $                                        
    ENDIF $                                                                      
   else $ mechout<>-1
  message //'if these dof were moved 1.0 units. Then determine what'/
            ' is causing the singularities' $
  message //' ' $
  message //' this can be done by setting PARAM,mechout,-1 - then the'/
        ' alter will perform data recovery using unit displacements' $
  message //'  of the singular dof - the results will be given '/
         'eigenvalues of 0.0 and written for MSC/PATRAN to view' $
$
  message //'if the cause of the singularities is not obvious, then'/
            ' perform a sol 101 run with enforced displacements of ' %
  message //'1.0 units at each of the indicated dof.' $
  message //'the resulting deformed shapes should make the mechanisms'/
            ' obvious' $
   endif $ mechout=-1
  message //' ' $
  message //' r u n  t e r m i n a t e d - DMAP alter fatal' $
  exit $
 endif $
endif $ ckmchnsm  
$
$
$alter 'REIGL    KXX,MXX,DYNAMICS'
alter 'read.*kxx.*mxx' $
type parm,,i,y,lansup=1 $
$
if (lansup = 1 and norset>0) then $
TYPE    PARM,,I,N,OTHER $
PARAML  phix//'TRAILER'/1/S,N,NMODES $
PARAML  phix//'TRAILER'/2/S,N,Ndofxx $
OTHER = NMODES-NORSET $
MATGEN  ,/PARTEIG/6/NMODES/NORSET/OTHER $
PARTN   phix,PARTEIG,/,,ULVNOR,/1 $
PURGEX/ phix,,,,/ALWAYS $
MATGEN  ,/DMI/1/NORSET $
MATGEN  ,/MERGDM/6/Ndofxx/NORSET/NOLSET $
$MERGE   DMI,Dar,,,,MERGDM/DM1/1 $ DM changed to DAR
 equivx dar/dm1/-1 $ 
$UMERGE  USET,DMI,Dar/DM1/'A'/'R'/'L' $ DN changed to DAR
$
$ gram-schmidt orthogonalization
call ortho dm1,kxx,mxx/dm2/norset/1.e-10/1 $ Gram Schmidt
$
$ mass normalize
$
SMPYAD  DM2,Mxx,DM2,,,/NEWMRR/3////1////6 $
DIAGONAL NEWMRR/FACTORS//-.5 $ 1/SQRT OF TERMS
MATGEN  ,/AUNIT/6/Ndofxx//Ndofxx $ UNIT MATRIX
FILE    NEWDMMAT=APPEND $
PARAM   //'NOP'/S,N,ROWNO=0 $
PARAM   //'NOP'/S,N,NOWCOL=0 $
$
DO WHILE (NOWCOL<NORSET) $
  ROWNO = ROWNO + 1 $
  PARAML  FACTORS//'DMI'/1/ROWNO/S,N,SCALIT $
  PARAMR  //'COMPLEX'//SCALIT//S,N,SCALEC $
  ADD     AUNIT,/COLUM/SCALEC $
  APPEND  COLUM,/NEWDMMAT/2 $
  PARAML  NEWDMMAT//'TRAILER'/1/S,N,NOWCOL $
ENDDO $
ADD    DM2,NEWDMMAT/NEWDM///1 $
purgex /phix,,,,/always $
MERGE  NEWDM,,ULVNOR,,PARTEIG,/phix/1 $
$ SET SUPORT MODES TO 0.0
LAMX,  ,LAMA/LMAT/-1 $
MATGEN ,/COL34/6/5/2/2/1 $ COLUMN PARTIONING VECTOR
PARTN  LMAT,COL34,/m1,m2,MAT1,m4/1 $
matgen ,/twocol/6/2/1/1 $
partn mat1,twocol,/col1,,col2,/1 $
$
$ replace eigenvalues for r-set with zeros
$
PARTN  col1,,PARTEIG/,phinor,,U4/1 $
merge ,,phinor,,,,parteig/col1a/1 $
merge col1a,,col2,,twocol,/mat2/1 $
$
TRNSP  MAT2/MAT $
MATGEN ,/ROW13/6/3//1/1/1 $ ROW MERGING VECTOR
MERGE, ,mat,,,,ROW13/LAMA2/1 $
LAMX   LAMA2,/NEWLAMA $
purgex /lama,,,,/always $
equivx newlama/lama/always $
$ done
endif $
$smpyad phix,mxx,phix,,,/tempsm/3////1 $
$smpyad phix,kxx,phix,,,/tempsk/3////1 $
$matprn tempsm,tempsk// $
$ -------------------------------------------------------------------
compile sestatic $
$ disable LTU logic for scr=yes
alter 1
putsys(0,192)
$
$--------------------------------------------------------------------
compile semodes $
$ disable LTU logic for scr=yes
alter 1
putsys(0,192)
$
$ -------------------------------------------------------------------
$
compile phase1dr $
alter 'call.*phase1a'
VECPLOT,
       Pg,BGPDTS,SCSTM,CSTMS,CASESx,,MEDGE,//
       GRDPNT/S,N,ZERO/+1/'pgtot'///ALTSHAPE//SEID $
$
$ -------------------------------------------------------------------
$
compile phase1a $
$
$
alter 1 $ after SUBDMAP 
type parm,,i,n,mattyp = 0,pass=-1 $
type parm,,i,y,spcsum=-1,dummy $
type parm,,i,y,quit=-1
TYPE PARM,,I,Y,(CHKSTIF=1)
type parm,,char8,y,checka='no' $
$alter 41,47 $ between "IF (SEKR ) THEN $" and "ENDIF $ SEKR" $
$alter 'ENDIF $ SEMG AND NOT(IMAGE)'(1,1),'ENDIF $ SEKR'(,-1)
alter 'IF.*not(image).*then'(2,1),'ENDIF $ SEKR'
$
$
$ store a q-set partitioning vector for this se
$
$    unused in the dynamic soln - store current and upstream q-set
$
type db,aagds,ptga $
type parm,,i,n,nouset0,nqset
$
PARAML  USET0//'USET'////S,N,NOUSET0//'Q'/S,N,NqSET $
$message //'nouset0 ='/nouset0/' nqset= '/nqset $
if (nqset>0)then $
vec uset0/currentq/'G'/'COMP'/'Q' $ current q-set
$matprn currentq// $
else $
 matgen ,/currentq/6/lusets/lusets $ empty matrix
endif $
$
$ create qsetdof - now aagds - if superelement has upstreams
$
temp = seid $
if (noup>0)then $
call sela1 currentq,fore,ptga,maps,slist,emap,bgpdts,gdntab/
$           aagds/statics/cyclic/noup/seid/nopg $
           aagds/statics/cyclic/noup/seid/nopg/'PA    ' $
$DBVIEW PAUP   = ptga (WHERE SEDWN=TEMP AND SEID=* AND PEID=*) $
$DBVIEW MAPUPL = MAPS (WHERE SEDWN=TEMP AND SEID=* AND PEID=*) $
$dbdict datablk=(aagds,ptga),select=(name,size,sedwn,seid,peid)
$SELA     currentq,SLIST,EMAP,BGPDTS,PAUP,MAPUPL,GDNTAB/
$         aagds /
$         SEID/'SEID'/0/S,N,NOPGS  $
$$ CALL SELA1  currentq,FORE,PSSC,MAPS,SLIST,
$$                 EMAP,EQEXINS,GDNTAB/aagds/
$$                 STATICS/CYCLIC/NOUP/SEID/SEDWN $
else $
 equivx currentq/aagds/always $
endif $
$
$    ext. dof which have been used as Q-set
$ correct error if no reduction occurs - 11/30/98
paraml uset0//'uset'//////'a'/s,n,noasetx/'G'/s,n,nogsetx  $
if(noasetx<>nogsetx)then $ 
 upartn uset0,aagds/ptga,,,/'G'/'A'/'S'/1 $
else $
 equivx aagds/ptga/always $
endif $
$
type parm,,i,n,cond1=0 $
$ corrected storing gpls in special cases
$   Sept 3, 1999
type db,zuzr11 $
type parm,nddl,i,n,zuzr1 $
type parm,nddl,char8,n,zname $
zuzr1 = seid $
zname = 'gpls    ' $
equivx gpls/zuzr11/-1 $
$call dbstore gpls,,,,//seid/0/'DBALL'/s,cond1 $
$dbdict datablk=(zuzr11), select=(zname,size,zuzr1,zuzr2,zuzr3) $
putsys(1,109)
CALL CHECK USET0,//MATTYP/SEID/SEID/noup/s,pass $
putsys(0,109)
$
$
  IF ( SEKR ) THEN $
         EQUIVX  KJJ/KGG/NOUP $
         IF ( NOUP >=0 ) THEN $ ASSEMBLE UPSTREAM STIFFNESS
              CALL SEMA1  KJJ,MAPS,KAA,BGPDTS,SLIST,
              EMAP,GDNTAB/
              KGG/
              SEID/ERROR/LUSETS/-1/noup/2 $
$
            IF ( SKIPSE ) RETURN $
         ENDIF $
      ENDIF $
$ LAST PARAMETER IS MASSFLG, VALUE OF 2 SAYS TO CALL CHECK WITH XGG1
$
$                          AFTER GP4
MATTYP=1 $ CHECK KGG
if (checka='yes')chkstif=1 $
$message //'checka='/checka/' chkstif='/chkstif $
IF (CHKSTIF >-1) THEN $
putsys(1,109)
CALL CHECK USET0,/dummy/MATTYP/SEID/SEID/-1/s,pass $
type parm,,i,y,checkdr=-1,quitdr=-1
type parm,,i,n,foundit=-1 $
type parm,nddl,i,y,post,ounit2 $
type parm,,i,y,ounitrb=-1 $
type parm,,i,n,ounitrbi=-1 $
if(checkdr=0 or checkdr=1)then $
 if(pass=1)then $
$ perform data recovery on G-stiffness check tttttttttttttttttttttttttttttttttttttttttt
  CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
  case cases,/case1dr/'tran' $
  matgen ,/zeromat/7/5/6 $
  lamx zeromat,/zerolama $
  SDR2     CASE1DR,CSTMS,MPTS,DIT,EQEXINS,,ETT,zerolama,BGPDTS,                      
              ,dummy,rbg1,EST ,,,,,GPSNTS,                  
           DEQATN,DEQIND,DITID/                                                
           OPG1,OQG1,OUGV1,OES1,OEF1,PUGV/'reig'/S,N,NOSORT2/                    
           NOCOMPS/////ACOUT/PREFDB/-1./-1./                                   
           ADPTINDX/ADPTEXIT/FALSE $ 
  message //' ' $
  message //' the following output is from the G-set rigid body check' $
  message //' ' $  
  ofp opg1,oqg1,ougv1,oes1,oef1// $
  message //' ' $
  message //' the previous output is from the G-set rigid body check' $
  message //' ' $  
      if(ounitrb=-1)then $
        ounitrbi=ounit2 $ 
      else $
        ounitrbi=ounitrb $
      endif $
  if(post=-1)output2 oqg1,ougv1,oes1,oef1///ounitrbi $                                        
  if(quitdr=-1)then $
   message //'terminating run due to failure of check on G-set' $
   exit $
  endif $ quitdr=-1
endif $ pass=1
endif $ checkdr
putsys(0,109)
if (quit>0)return  $
ENDIF $
$
$ALTER 52,52 $ replace CALL SEMA1 .... $
alter 'CALL SEMA1  MJJ,MAPS','CALL SEMA1  MJJ,MAPS'
CALL SEMA1  MJJ,MAPS,MAA,bgpdtS,SLIST,EMAP,gdntab/
            MGG/
            SEID/ERROR/LUSETS/0/noup/1 $ 1 => MASS REDUCTION
$alter 57,57 $ replace CALL SEMA1 ....
alter 'CALL SEMA1  BJJ,MAPS','CALL SEMA1  BJJ,MAPS'
CALL SEMA1  BJJ,MAPS,BAA,bgpdtS,SLIST,EMAP,GDNTAB/
                BGG/
                SEID/ERROR/LUSETS/0/noup/0 $
$
$alter 62,62 $ replace CALL SEMA1 k4jj 2
alter 'CALL SEMA1  K4JJ,MAPS','CALL SEMA1  K4JJ,MAPS'
CALL SEMA1  K4JJ,MAPS,K4AA,bgpdtS,SLIST,EMAP,GDNTAB/
                K4GG/
                SEID/ERROR/LUSETS/0/noup/0 $
$ -------------------------------------------------------------------
$ F-set stiffness check - added march, 1999
$
compile sekr
$ add seid to argument list
alter 1,1
SUBDMAP SEKR  KGG,USET,EQEXINS,SILS,GPLS,KNN/                                   
              KSF,KFS,KSS,KTT,KFF,LOO,GOT,LAO,ORSEQ/                            
              ERROR/FIXEDB/ALTRED/STATICS/SEID $
type parm,,i,n,seid $                                     
$
$ perform F_set checks if requested
$
alter 'IF.*NOSSET.*UPARTN.*USET,KNN.*KFF,KSF,KFS,KSS' $                  
type parm,,i,y,chkstif=-1,chkstiff=-1,mattyp,checkdr=-1,quitdr=-1
type parm,,char8,y,checka='no' $
type parm,,i,n,pass=-1,foundit $
if (checka='yes')chkstif=1 $
type parm,nddl,i,y,post,ounit2 $
type parm,,i,y,ounitrb=-1 $
type parm,,i,n,ounitrbi=-1 $
IF (CHKSTIF >-1 AND CHKSTIFF > -1) THEN $
  IF (NOSSET<>-1) THEN $
    MATTYP=25 $ CHECK KFF
    putsys(1,109)
    CALL CHECK USET,KFF/dummyf/MATTYP/SEID/SEID/-1/s,pass $
    putsys(0,109)
$  message //'pass='/pass/' checkdr='/checkdr/'quitdr='/quitdr $
    if(pass=1)then $
     if(checkdr=0 or checkdr=3)then $
$ data recovery of failed check
$
$ expand rbn to G-size using GM nnnnnnnnnnnnnnnnnnnnnnnnnnnn
     CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
     upartn uset,rbg1/rbf,rbm,,/'g'/'f'/'m'/1 $
     umerge uset,rbf,/rbn/'n'/'f'/'s' $
     type db,gm,cases
     mpyad gm,rbn,/um $
     umerge uset,rbn,um/ugn/'g'/'n'/'m' $
     umerge uset,dummyf,/dummyg/'g'/'n'/'m' $
$
     case cases,/case1dr/'tran' $
     matgen ,/zeromat/7/5/6 $
     lamx zeromat,/zerolama $
     type db,mpts,dit,ett,gpsnts,deqatn,deqind,ditid
     type db,cstms,bgpdts,est
     SDR2   CASE1DR,CSTMS,MPTS,DIT,EQEXINS,,ETT,zerolama,BGPDTS,                      
              ,dummyg,ugn,EST ,,,,,GPSNTS,                  
            DEQATN,DEQIND,DITID/                                                
            OPG1,OQG1,OUGV1,OES1,OEF1,PUGV/'reig'/S,N,NOSORT2/                    
            NOCOMPS/////ACOUT/PREFDB/-1./-1./                                   
            ADPTINDX/ADPTEXIT/FALSE $ 
     message //' ' $
   message //' the following output is from the n-set rigid body check' $
     message //' ' $  
     ofp opg1,oqg1,ougv1,oes1,oef1// $
     message //' ' $
   message //' the previous output is from the n-set rigid body check' $
     message //' ' $  
      if(ounitrb=-1)then $
        ounitrbi=ounit2 $ 
      else $
        ounitrbi=ounitrb $
      endif $
     if(post=-1)output2 oqg1,ougv1,oes1,oef1///ounitrbi $                                        
     if(quitdr=-1)then $
       message //'run terminated due to failure of checks' $
       exit $
     endif $ quitdr=-1
     endif $ checkdr=0 or 2
    endif pass=1 
  ELSE IF (CHKSTIF<>-1) THEN $
    message //' ' $
    MESSAGE //'No S-set for this superelement - KFF not checked' $
    message //' ' $
  ENDIF $
ENDIF $
$ 
$ -------------------------------------------------------------------
COMPILE SEKR0 $
$ALTER 11 $                         AFTER LAST "TYPE" CARD
alter 'TYPE.*PARM.*usetprt.*usetsel'
TYPE PARM,,I,N,MATTYP=0,pass=-1,foundit $
type parm,,i,y,spcsum=-1,dummy,checkdr=-1,quitdr=-1 $
TYPE PARM,,I,Y,(CHKSTIF=1)
type parm,nddl,i,y,post,ounit2 $
type parm,,i,y,ounitrb=-1 $
type parm,,i,n,ounitrbi=-1 $
type parm,,char8,y,checka='no' $
$
vec uset0/spcbefor/'G'/'S'/'COMP' $
$alter 29 $ after GPSP
alter 'GPSP'
vec uset/spcafter/'G'/'S'/'COMP' $
add spcbefor,spcafter/spcauto/(-1.,0.) $
call dbstore spcauto,,,,//seid/0/'DBALL'/s,dummy $ store in database
$
compile sekmr $
$
$ modify call to sekr to provide seid - march, 1999
$
alter 'IF.*NOKTT.*CALL.*SEKR.*KGG.*KSF','' $                         
IF ( NOKTT=-1                                     
    ) CALL SEKR  KGG     ,USET    ,EQEXINS ,SILS    ,GPLS    ,                
                 KNN     /                                                    
                 KSF     ,KFS     ,KSS     ,KTT     ,KFF     ,                
                 LOO     ,GOT     ,LAO     ,ORSEQ   /                         
                 ERROR   /FIXEDB  /ALTRED  /STATICS /SEID $                         
$
$
$ALTER 114 $               BEFORE RETURN
alter 'ENDIF.*SEMR'
type parm,,i,n,mattyp,pass=-1 $
type parm,,i,y,chkstif=1
type parm,,char8,,y,checka='no'
if (checka='yes')chkstif=1 $
IF (CHKSTIF >-1 AND CHKSTIF < 2) THEN $
  TYPE PARM,,I,N,noasetx,nusetxx $
  PARAML USET//'USET'////S,N,NUSETXx//'A'/S,N,NOASETx $
  IF (NOASETx<>-1) THEN $
    MATTYP=3 $ CHECK KAA
    putsys(1,109)
    CALL CHECK USET,/dummya/MATTYP/SEID/SEID/-1/s,pass $
    putsys(0,109)
    type parm,,i,y,checkdr=-1,quitdr=-1
    type parm,nddl,i,y,post,ounit2
    type parm,,i,y,ounitrb=-1
    type parm,,i,n,ounitrbi=-1
  message //'pass='/pass/' checkdr='/checkdr/'quitdr='/quitdr $
    type parm,,i,n,foundit
    if(pass=1)then $
     if(checkdr=0 or checkdr=4)then $
$ data recovery of failed check
$
$ expand rba to G-size  nnnnnnnnnnnnnnnnnnnnnnnnnnnn
     CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
     upartn uset,rbg1/rbl,rbx,,/'g'/'l'/'m'/1 $
     SDR1     USET,,rbl,,,GOT,GM,,KFS,KSS,/              
           UGa,,QGa/NSKIP/'reig'/NOQG $                                    
$
     case cases,/case1dr/'tran' $
     matgen ,/zeromat/7/5/6 $
     lamx zeromat,/zerolama $
$     type db,mpts,ett,gpsnts,deqatn,deqind,ditid
     type db,mpts,ett,gpsnts,deqatn,deqind,ditid
     SDR2   CASE1DR,CSTMS,MPTS,DIT,EQEXINS,,ETT,zerolama,BGPDTS,                      
              ,qga,uga,EST ,,,,,GPSNTS,                  
            DEQATN,DEQIND,DITID/                                                
            OPG1,OQG1,OUGV1,OES1,OEF1,PUGV/'reig'/S,N,NOSORT2/                    
            NOCOMPS/////ACOUT/PREFDB/-1./-1./                                   
            ADPTINDX/ADPTEXIT/FALSE $ 
     message //' ' $
   message //' the following output is from the n-set rigid body check' $
     message //' ' $  
     ofp opg1,oqg1,ougv1,oes1,oef1// $
     message //' ' $
   message //' the previous output is from the n-set rigid body check' $
     message //' ' $  
        if(ounitrb=-1)then $
        ounitrbi=ounit2 $ 
      else $
        ounitrbi=ounitrb $
      endif $
   if(post=-1)output2 oqg1,ougv1,oes1,oef1///ounitrbi $                                        
     if(quitdr=-1)then $
       message //'run terminated due to failure of checks' $
       exit $
     endif $ quitdr=-1
     endif $ checkdr=0 or 2
    endif pass=1 
  ELSE $
    MESSAGE //' There is no reduction from the last check' $
    MESSAGE //' Therefore, the A-set stiffness check is not'/
              ' performed' $
  ENDIF $
ENDIF $
$
$
$
$ ADD PEID TO SEMRM AND PASS TO SEMR2 - FOR SECONDARY S.E.
$
$
$ -------------------------------------------------------------------
COMPILE SEMRM $ 
$
alter 1
type parm,,i,n,peid
$              REPLACE  EXISTING CALL SEMR2
alter 'IF.*NOMTT=-1.*CALL SEMR2',''
   IF ( NOMTT=-1 ) CALL SEMR2  MGG,GOT,USET,GM/
                   MTT,MFF,MMG,MSF/
                   ERROR/NOMSET/NOSSET/NOOSET/NORC/NOQSET/
                   NOTSET/peid/seid $
$
$
$ MODIFY SEMR2 TO HAVE SEID AND PEID - TO PASS ON FOR MASS CHECKS
$
$
$ -------------------------------------------------------------------
COMPILE SEMR2 $
ALTER 1,1
SUBDMAP SEMR2  MGG,GOT,USET,GM/
               MTT,MFF,MMG,MSF/
               ERROR/NOMSET/NOSSET/NOOSET/NORC/NOQSET/
               NOTSET/peid/seid  $
$
TYPE PARM,NDDL,I,N,SEID,PEID $
$ALTER 6 $           AFTER LAST "TYPE" STATEMENT
alter 'TYPE PARM,,I,N,ERROR'
TYPE PARM,,I,N,MATTYP=0,pass=-1 $
MATTYP=4 $ CHECK MGG
putsys(1,109)
CALL CHECK USET,//MATTYP/SEID/PEID/-1/s,pass $
putsys(0,109)
$ALTER 15 $ AFTER ENDIF (  NOMSET......
alter 'ENDIF $ NOMSET>-1'
MATTYP=5 $ CHECK MNN
putsys(1,109)
IF ( NOMSET > -1 )CALL CHECK USET,MNN//MATTYP/SEID/PEID/-1/s,pass $
putsys(0,109)
$ALTER 36 $   AFTER ENDIF $ IF ( NOOSET.....
$
compile phase1b $
$
alter 'call.*sekr0'
$
TYPE PARM,,I,N,MATTYP=0,pass=-1,foundit $
type parm,,i,y,spcsum=-1,dummy,checkdr=-1,quitdr=-1 $
TYPE PARM,,I,Y,(CHKSTIF=1)
type parm,nddl,i,y,post,ounit2 $
type parm,,i,y,ounitrb=-1
type parm,,i,n,ounitrbi=-1
type parm,,char8,y,checka='no' $
$ALTER 22 $          AFTER ENDIF $ NOMSET>=0
if (checka='yes')chkstif=1 $
IF (CHKSTIF >-1 AND CHKSTIF < 3) THEN $
  IF (NOMSET<>-1) THEN $
    MATTYP=2 $ CHECK KNN
    putsys(1,109)
    CALL CHECK USET0,KNN/dummyn/MATTYP/SEID/SEID/-1/s,pass $
    putsys(0,109)
$ message //'pass='/pass/' checkdr='/checkdr $
    if(pass=1)then $
     if(checkdr=0 or checkdr=2)then $
$ data recovery of failed check
$
$ expand rbn to G-size using GM nnnnnnnnnnnnnnnnnnnnnnnnnnnn
     CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
     upartn uset0,rbg1/rbn,rbm,,/'g'/'n'/'m'/1 $
     mpyad gm,rbn,/um $
     umerge uset0,rbn,um/ugn/'g'/'n'/'m' $
     umerge uset0,dummyn,/dummyg/'g'/'n'/'m' $
$
     case cases,/case1dr/'tran' $
     matgen ,/zeromat/7/5/6 $
     lamx zeromat,/zerolama $
     type db,mpts,ett,gpsnts,deqatn,deqind,ditid
     SDR2   CASE1DR,CSTMS,MPTS,DIT,EQEXINS,,ETT,zerolama,BGPDTS,                      
              ,dummyg,ugn,EST ,,,,,GPSNTS,                  
            DEQATN,DEQIND,DITID/                                                
            OPG1,OQG1,OUGV1,OES1,OEF1,PUGV/'reig'/S,N,NOSORT2/                    
            NOCOMPS/////ACOUT/PREFDB/-1./-1./                                   
            ADPTINDX/ADPTEXIT/FALSE $ 
     message //' ' $
   message //' the following output is from the n-set rigid body check' $
     message //' ' $  
     ofp opg1,oqg1,ougv1,oes1,oef1// $
     message //' ' $
   message //' the previous output is from the n-set rigid body check' $
     message //' ' $  
       if(ounitrb=-1)then $
        ounitrbi=ounit2 $ 
      else $
        ounitrbi=ounitrb $
      endif $
    if(post=-1)output2 oqg1,ougv1,oes1,oef1///ounitrbi $                                        
     if(quitdr=-1)then $
       message //'run terminated due to failure of checks' $
       exit $
     endif $ quitdr=-1
     endif $ checkdr=0 or 2
    endif pass=1 
  ELSE IF (CHKSTIF<>-1) THEN $
    message //' ' $
    MESSAGE //'No M-set for this superelement - KNN not checked' $
    message //' ' $
  ENDIF $
ENDIF $
$
alter 'call.*sekmr'
IF (NOOSET<>-1 OR NOSSET<>-1) THEN $
  TYPE PARM,,I,N,NOASETx,nusetxx $
  PARAML USET//'USET'////S,N,NUSETXx//'A'/S,N,NOASETx $
  IF (NOASETx<>-1) THEN $
    MATTYP=6 $ CHECK MAA
    putsys(1,109)
    CALL CHECK USET,//MATTYP/SEID/PEID/-1/s,pass $
    putsys(0,109)
  ELSE $
    MESSAGE //' There is no reduction from the last check' $
    MESSAGE //' Therefore, the A-set mass check is not'/
              ' performed' $
  ENDIF $
ENDIF $
$
$
$ MODIFY SEDRCVR - ADD CALLS FOR KE AND EFW AND PASS PEID FOR SECONDARY S.E.
$
$
$ -------------------------------------------------------------------
COMPILE SEDRCVR $
$ALTER 1,1 $ replace SUBDMAP
$$
$SUBDMAP SEDRCVR  UG      ,QG      ,BGPDTn  ,EQEXINS ,CSTMS   ,
$                 CASEDR  ,MPTS    ,DIT     ,ETT     ,OL2     ,
$                 PJ1     ,EST     ,XYCDBDR ,GEOM2S  ,GEOM3S  ,
$                 POSTCDB ,ECTS    ,GPLS    ,EPTS    ,SILS    ,
$                 INDTA   ,KELM    ,KDICT   ,GPECT   ,VELEM   ,
$                 FORCE   ,XYCDB   ,PCDBDR  ,USET    ,SLT     ,
$                 UH1     ,OL1     ,DLT     ,FRL     ,SPSEL   ,
$                 DYNAMICS,RDESTR  ,OEFNLXX ,OESNLXX ,PTELEM  ,
$                 PJ      ,FORE    ,MELM    ,MDICT   ,EDT     ,
$                 ERROR1  ,MEDGE   ,VIEWTB  ,RECMR   ,BGPDTVU ,
$                 GPSNTS  ,EHT     ,DEQATN  ,DEQIND  ,QMG     ,
$                 OLAMA   ,OINT    ,PELSETS ,SCSTM   ,DITID   ,
$                 MAR     ,MEA     ,iugv1   ,iqg1    ,ief1    ,
$                 ies1    ,istr1   ,iugv2   ,iqg2    ,ief2    ,
$$                 ies2    ,istr2   ,ESTNL   ,OESNLX ,bgpdts  /
$                 ies2    ,istr2   ,ESTNL   ,OESNLX  ,GEOM1   ,
$                 GEOM2   ,GEOM3   ,EPT     ,ERRORG  ,bgpdts  ,
$                 spcpart /
$                 PUGV    ,OUGV1   ,OPG1    ,OQG1    ,OEF1X   ,
$                 OES1X   ,OSTR1   ,OGS1    ,OUGV2   ,OPG2    ,
$                 OQG2    ,OEF2    , OES2   , OSTR2  ,OGS2    ,
$                 OES1M   ,OES1G   ,OSTR1M  ,OSTR1G  ,EGPSTR  ,
$                 EGPSF   ,ONRGY1  ,OGPFB1  /
$                 APP     /APP1    /NOCOMPS /PFILE   /SEID    /
$                 CARDNO  /SCRSPEC /RSPECTRA/INREL   /GPFDR   /
$                 NLHEAT  /AERO    /ICYCLIC /DBCCONV /CP      /
$                 OUGCORDX/DESCYCLE/PEXIST  /ADPTINDX/ADPTEXIT/
$                 NOQG    /NOQMG   /DISOFP  $     
$$
alter 2
TYPE DB PG1 $ SCRATCH
TYPE PARM,NDDL,I,N,PEID $
type parm,,i,y,elemke=-1 $
$
$alter 12
alter 'TYPE PARM,,CHAR8,N,DBCCONV'
type parm,,i,y,spcsum=-1, dummys $
$alter 19 $ TED
alter 'IF ( PRTRESLT='
if (spcsum>-1) then $
  message //'DMAP alter information message ' $
  message //'the following spcforce summary is the summation of'/
            ' all forces resulting from the application of'/
            ' autospc' $
  call dbfetch /spcauto,,,,/SEID/0/0/0/S,dummys   $
  paraml spcauto//'presence'////s,n,nopar $
  if (nopar<>-1) then $
    matmod spcauto,,,,,/nullcols,/12/s,n,nulcol/1 $
    if (nulcol=-1) then $
      partn qg,,spcauto/userspc,autspc,,/1 $
      merge userspc,,,,,spcauto/userspcg/1 $
      merge ,,autspc,,,,spcauto/autspcg/1 $
$
$ calculate totals for user-specified SPCs and AUTOSPC
$
VECPLOT  userspcg,BGPDTn,scstm,CSTMS,CASEDR,,medge,SILS/
         QGSUMu/GRDPNT/0/1/
         'USERSPC'///altshape $
VECPLOT  autspcg,BGPDTn,scstm,CSTMS,CASEDR,,medge,SILS/
         QGSUMa/GRDPNT/0/1/
         'AUTOSPC'///altshape $
    else $
      message //'no dof were constrained by autospc for this se' $
    endif $
   endif $
endif $
$
$   assembly plots without scaling by upstream modes
$
$alter 30,30 $ replace SDR2
alter 'SDR2','SDR2'
type parm,,i,y,dontqset=-1 $
if (dontqset>=0) then $
SDR2     CASEDR,CSTMS,MPTS,DIT,EQEXINS,,ETT,OL2,BGPDTn,
         ,,UG,EST ,XYCDBDR,OINT,PELSETS,VIEWTB,
         GPSNTS,DEQATN,DEQIND,DITID/
         ,,OUGV1,OES1,OEF1,PUGV/
         APP1//NOCOMPS/////ACOUT/PREFDB/TABS/SIGMA/
         ADPTINDX/ADPTEXIT/FALSE $
else $
  type parm,,i,n,gotit=0 $
type db aagds $ upstream and current q-set dof
  dbstatus aagds//s,n,gotit $ gotit = 1 if available
  if (gotit=1) then $
    equivx aagds/qsetdof/always $
    matmod qsetdof,,,,,/nullcol1,/12/s,n,nulcol/1 $
    paraml qsetdof//'TRAILER'/1/s,n,nocol $
    if (nocol<>nulcol) then $
      partn    ug,,qsetdof/ugvnq,,,/1 $
      merge    ugvnq,,,,,qsetdof/ugvnq1/1 $
    else $
      equivx ug/ugvnq1/always $
    endif$
  else $
    equivx ug/ugvnq1/always $
  endif $
$  PARAML   USET//'USET'////S,N,NOUSETZ//'Q'/S,N,NOQSET $
$  if (noqset>0) then $
$    upartn uset,ugvnq1/,ugnoq,,/'g'/'q'/'s'/1 $
$    umerge uset,,ugnoq/ugvsnq/'g'/'q'/'s' $
$  else $
    equivx ugvnq1/ugvsnq/always $
$  endif $
SDR2     CASEDR,CSTMS,MPTS,DIT,EQEXINS,,ETT,OL2,BGPDTn,
          ,,UGvsnq,EST ,XYCDBDR,OINT,PELSETS,VIEWTB,
          GPSNTS,DEQATN,DEQIND,DITID/
          ,,OUGV1,OES1,OEF1,PUGV/APP1/S,N,NOSORT2/
          NOCOMPS/////ACOUT/PREFDB/TABS/SIGMA/
          ADPTINDX/ADPTEXIT/FALSE $
$                                 qset dof = 0.0
endif $
$
$ end of set q-set disp - 0.0 for plotting
$
$ALTER 217 $        AFTER OFP  OUGV1,OPG1,.......
alter 'OFP      OUGV1,OPG1,OQG1'
$ added check on APP - Jan, 1997
if(APP='REIG')THEN $
 CALL KEEFW UG/TEST99,kess2,kessmm2/SEID/PEID $
$
$ dec, 1995 - plot kinetic energy if requested
 type parm,,i,y,nokeng=-1, NOROKEPL=-1, NOTRKEPL=-1, NOROUPPL=-1
 type parm,nddl,i,n,zuzr1 $
$ phidlg,phidrg used for upstream plots instead of zuzr05 and zuzr06
$ this avoids error for SEMA and PLTVEC modules in V68
 type db,phidlg,phidrg,emap
$
   if(nokeng<>-1 and app='reig')then $ print and plot kinetic energy
$
         SDR2     CASEDR,CSTMS,MPTS,DIT,EQEXINS,,ETT,OL2,BGPDTn,PJ1,
               QG,KESS2,EST,XYCDBDR,,,,,,,/,,okess2,,,PKESS2/
               APP1/S,N,NOSORT2/NOCOMPS $        DR FOR TRANS KIN EN
         SDR2     CASEDR,CSTMS,MPTS,DIT,EQEXINS,,ETT,OL2,BGPDTn,PJ1,
               QG,KESSMM2,EST,XYCDBDR,,,,,,,/,,okemm2,,,PKEMM2/
               APP1/S,N,NOSORT2/NOCOMPS $          DR FOR ROT KIN EN
$
         ZUZR1=SEID $
         EQUIVX   PKESS2/phidrg/ALWAYS $                         DBSTORE
$         EQUIVX   PKEMM/phidlg/ALWAYS $                         DBSTORE
         EQUIVX   PKEMM2/phidlg/ALWAYS $                         DBSTORE
    message //'The following output is the calculated kinetic energy' $
         OFP      okess2// $
         PARAML   PCDBDR//'PRESENCE'////S,N,JPLOT $
     if(jplot>=0)then $plotting
         PLTSET   PCDBDR,bgpdtn,ECTS/PLTXm,PLTPARm,GPSETSm,ELSETSm/
                                   S,N,NSILS/S,N,JPLOT $
       if(notrkepl<>-1)then $     plot kinetic energy - translations
         PLOT     PLTPARm,GPSETSm,ELSETSm,CASEDR,BGPDTn,
                  PKESS2,PKESS2,GPECT,/PLOTKE/NSILS/0/JPLOT/-1/S,N,PFILE $
         PRTMSG   PLOTKE//V,Y,PDRMSG $               PRINT PLOT MESSAGE
       endif  $ notrkep<>-1
       if(norokepl<>-1)then $     plot kinetic energy - rotations
         PLOT     PLTPARm,GPSETSm,ELSETSm,CASEDR,BGPDTn,
                  PKEMM2,PKEMM2,GPECT,/PLKEMM/NSILS/0/JPLOT/-1/
                  S,N,PFILE $
         PRTMSG   PLKEMM//V,Y,PDRMSG $               PRINT PLOT MESSAGE
       endif $ norokepl<>-1
     endif $ plotting
    endif $ nokeng<>-1
endif $ (APP='REIG')
$
$dbdict select(name,size,seid,peid,zuzr1,zuzr2,zname,vers) $
$
$  element kinetic energy
$alter 297 $ after DBVIEW KDICTX
alter 'DBVIEW  KDICTX=KDICT'
$
$ add option for element kinetic energy
$
  if (elemke>-1) then $
   message //'The following element strain energy printout is'/
             ' the kinetic energy for each element' $
   GPFDR    CASEDR,UG,MELM,MDICT,ECTS,EQEXINS,GPECT,PG1,QG,
            BGPDTn,SILS,CSTMS,VELEM,,/
            ENRGY1,temp99/APP2/TINY $
  ofp enrgy1// $
  endif $ Element ke
$
$ -------------------------------------------------------------------
$
compile super3 $
$
alter 'if.*rsonly.*nopcdb'
type parm,,i,y,nokeng=-1
if(nokeng=-1)then $
$
alter 'ELSE IF ( NOPCDB>0 '(,-1)
endif $
$
alter 'ectf'   
$
$ kinetic energy plots
$
type parm,,i,y, NOROKEPL=-1, NOTRKEPL=-1, NOROUPPL=-1
$ phidrg and phidlg used to avoid error in SEMA and VECPLOT in V68
type db,phidrg,phidlg
type parm,nddl,i,n,zuzr1
$
if(nokeng<>-1 and app='reig')then $ kinetic energy seupplots
$dbdict select(name,size,seid,peid,zuzr1,zuzr2,zuzr3,zname,vers) $
$
$        KINETIC ENERGY SEUPPLOT, FORM A MERGED PLOT VECTOR
$
COND     TRKEUPPL,NOROUPPL $   IF NOROUPPL=-1 JUMP TO TRKEUPPL
$
DBVIEW   PUGVSFMR=phidlg (WHERE seid=* AND WILDCARD=TRUE ) $
$
$dbdict datablk=(phidlg,phidrg,pug),
$         select(name,size,seid,peid,zname,version) $
$message //'seid ='/seid
$PLTVEC   EMAP,DRLIST,PCDB,EQEXINX,SILX,SILSF,GPLSF,PUGVSFMR/
$         PUGX,PCDBX/seid/'seid' $
        DO WHILE ( PLTCNT>-1 ) $
            SEPLOT   PCDB,EMAP,SCSTM,BGPDTF,ECTF,PUGVSFMR/
                     BGPDTX,PUGX,PLTXY,PLTPARY,GPSETSY,ELTSETSY/
                     'PEID'/'SEID'/S,N,PLTCNT/S,N,NSILS/S,N,JPLOT $
               PRTMSG   PLTXY//PDRMSG  $
               IF ( JPLOT>=0 ) THEN $
                  PLOT     PLTPARY,GPSETSY,ELTSETSY,CASECC,BGPDTX,
                        PUGX,PUGX,GPECT,OES1X/
                           PLOTY2a/NSILS/0/JPLOT/-1/S,N,PFILE $
                  PRTMSG   PLOTY2a//PDRMSG $
               ENDIF $ JPLOT>=0
        ENDDO $
$
JUMP     GOONGUY
$
LABEL    TRKEUPPL $
$
DBVIEW   PUGVSFWT=phidrg (WHERE seid=* AND WILDCARD=TRUE ) $
$
        DO WHILE ( PLTCNT>-1 ) $
            SEPLOT   PCDB,EMAP,SCSTM,BGPDTF,ECTF,PUGVSFWT/
                     BGPDTX,PUGX,PLTXY,PLTPARY,GPSETSY,ELTSETSY/
                     'PEID'/'SEID'/S,N,PLTCNT/S,N,NSILS/S,N,JPLOT $
               PRTMSG   PLTXY//PDRMSG  $
               IF ( JPLOT>=0 ) THEN $
                  PLOT     PLTPARY,GPSETSY,ELTSETSY,CASECC,BGPDTX,
                        PUGX,PUGX,GPECT,OES1X/
                           PLOTY2aa/NSILS/0/JPLOT/-1/S,N,PFILE $
                  PRTMSG   PLOTY2aa//PDRMSG $
               ENDIF $ JPLOT>=0
        ENDDO $
$
$PLTVEC   EMAP,DRLIST,PCDB,EQEXINX,SILX,SILSF,GPLSF,PUGVSFWT/
$         PUGX,PCDBX/seid/'seid' $
$
LABEL    GOONGUY  $
$
$-------------------------------------------------------------
else $ normal plotting
$
ALTER 'enddo.*pltcnt'                
$
endif $ nokeng<>-1
$
$ -------------------------------------------------------------------
$
$  SUBDMAP CHECK - CALC "RIGID-BODY" VECTORS AND CHECK K AND M
$
$
$ -------------------------------------------------------------------
COMPILE CHECK $
$
SUBDMAP CHECK USETB,INMAT/dummy/MATTYP/SEID/PEID/NOUP/pass $
$
$  MATTYP = FLAG FOR MATRIX TYPE AND SET
$
$         0 = CALC. "RIGID" BODY MATRICES
$         1 = KGG
$         2 = KNN
$         25= KFF    $ added March, 1999
$         3 = KAA
$         4 = MGG
$         5 = MNN
$         6 = MAA
$        11 = XGG1 from SEMA1 - KJJ+KAA only
$
$  PASS = indicate if rigid-body check passed -
$        -1 = default = passed
$         1 = failed
$
$ ALTERS FOR SOLUTION 103 TO PERFORM STIFFNESS CHECKS
$      AND CALCULATE KINETIC ENERGY AND MODAL WEIGHT BY S.E.
$      BOTH WITH AND WITHOUT UPSTREAM COONTRIBUTIONS
$
$ updated 3/1999 to add F-set ctiffness check
$
$ updated 1/1997 - changed the qsetup logic
$
$ modified 10/8/1993 to correct problem if no upstream q-set
$
$  MODIFIED 7-21-1992 to add CHECKTOL
$
$  MODIFIED 1/27/1992 - fixed check of KNN and MNN
$
$ QUALIFIERS AND PARAMETERS
$
TYPE PARM,NDDL,I,N,PEID,MTEMP,MPC $
TYPE PARM,,I,N,SEID,IDOF,pass=-1 $
$  SET DEFAULTS
type parm,,char8,y,checka='no'
TYPE PARM,,I,Y,(GRDPNT=0) $ ADDED 7/11/90 ********
TYPE PARM,,I,Y,(CHKSTIF=1) $ - DEFAULT = NO STIFFNESS CHECKS
TYPE PARM,,I,Y,(CHKMASS=1) $ - DEFAULT = NO MASS CHECKS
TYPE PARM,,RS,Y,(CHECKTOL=0.0) $ - DEFAULT
type parm,,rs,n,chktol=0.0 $ replacement for checktol
$
TYPE PARM,,I,N,(NOPAR=0)) $
TYPE PARM,NDDL,RS,Y,(WTMASS) $
TYPE PARM,,RS,N,(MW) $
TYPE PARM,,CS,Y,(MASSWT) $
TYPE PARM,,I,N,MATTYP,temp $
TYPE PARM,NDDL,CHAR8,N,APRCH,K2GG
TYPE PARM,,I,N,,FOUNDIT $
TYPE PARM,,I,N,ASIZE,GSIZE,noup $
type parm,,rs,y,printol=.1
type parm,,rs,y,tolgn=-1.0, tolf=-1.0 $
type parm,,i,n,icount=0,icm1=0,gotitg
$
TYPE DB,EQEXINS,SLIST,EMAP,BGPDTS,CSTMS $
type db scstm $
TYPE DB,KGG,KAA,MGG,MAA $
TYPE DB,SILS $
TYPE DB,USET,KLAA,MAPS $
type db,aagds
$dbdict datablk=(zuzr11), select=(zname,size,zuzr1,zuzr2,zuzr3) $
call dbfetch /gpls,,,,/seid/0/0/0/s,gotitg $
$message //'gotitg ='/gotitg $
$
if(checka='yes')chkstif=1 $
$
IF(WTMASS=0.)WTMASS=1. $
MW=1./WTMASS $
MASSWT=CMPLX(MW,0.) $
$
$  DBVIEW RBG=ZUZR02(WHERE ZUZR1=SEID)
$  DBVIEW RBTG=ZUZR03(WHERE ZUZR1=SEID)
$
IF(MATTYP=0) THEN $
 $
 $ UPSTREAM Q-SET PARTITION VECTOR
 $
  PARAML   USETB//'USET'////S,N,NOUSETZ//'Q'/S,N,NOQSET $
$IF(NOUP>0) THEN   $
$  type parm,,i,n,gotit $
$  call     dbfetch /qsetdof,,,,/seid/0/0/0/s,gotit $
$  equivx  qsetdof/vguq/always $ $
$  $
$  $ CREATE Q-SET PARTITION VECTOR & COMBINE W/UPSTREAM PARTITION
$  $
$    type parm,,i,n,nullts $
$  if (noqset>0) then $
$    VEC USETB/qset03/'G'/'COMP'/'Q'/ $
$    ADD qset03,VGUQ/temp01/ $
$    purgex /qsetdof,,,,/always $
$    equivx temp01/qsetdof/always $
$    call dbstore qsetdof,,,,//seid/0/'DBALL'/s,nullts $
$$dbdict select(name,size,seid,peid,zuzr1,zuzr2,zname,vers) $
$  else $
$    equivx vguq/temp01/always $
$  endif $
$else $
$  noop() $
$  if (noqset>0) then $
$    VEC USETB/temp01/'G'/'COMP'/'Q'/ $
$    equivx temp01/qsetdof/always $
$    call dbstore qsetdof,,,,//seid/0/'DBALL'/s,nullts $
$$dbdict select(name,size,seid,peid,zuzr1,zuzr2,zname,vers) $
$  endif $
$endif $
$paraml temp01//'presence'////s,n,nopar $
temp = peid $
dbview qsetdof=aagds, where(peid=temp and wildcard=true) $
dbstatus qsetdof//s,n,nopar $
$
VECPLOT ,,BGPDTS,scstm,CSTMS,,,,/RBTG1/GRDPNT//4 $
if (nopar<>-1) then $
   matmod qsetdof,,,,,/nullcol3,/12/s,n,nulcol/1 $
   paraml qsetdof//'TRAILER'/1/s,n,nocol $
  if (nocol<>nulcol) then $
$  fix for no upstream q-set - 10/8/1993
$  matmod temp01,,,,,/nullcols,/12/s,n,nulcol/1 $
$  if (nulcol<>-1) then $
    PARTN RBTG1,qsetdof,/RBX,,,/1 $
    PURGEX /RBTG1,,,,/ALWAYS $
    MERGE RBX,,,,qsetdof,/RBTG1/1 $
  endif $ (nocol<>nulcol)
endif $ (nopar<>-1)
 TRNSP RBTG1/RBG1/ $
 CALL DBSTORE RBG1,RBTG1,,,//SEID/0/'DBALL'/0 $
$MATGPR GPLS,USETB,SILS,rbg1//'H'/'G'//printol $
$ EQUIVX RBG1/ZUZR02/ALWAYS $
$ EQUIVX RBTG1/ZUZR03/ALWAYS $
ENDIF $
$
IF (CHKSTIF>-1 AND MATTYP=1)THEN $
  $ CHECK KGG FOR CONSTRAINTS
  CALL DBFETCH /RBG1,RBTG1,,,/SEID/0/0/0/S,FOUNDIT $
$MATGPR GPLS,USETB,SILS,rbg1//'H'/'G'//printol $
  MPYAD KGG,RBG1,/REACG/ $
  MPYAD RBTG1,REACG,/CHKKGG/ $
$ CHECK IF CHECKTOL IS EXCEEDED
  if(checktol=0.)then $ scale by largest term
   message //' ' $
   message //' no value provided for parameter checktol' $
   message //' ' $
   matmod kgg,,,,,/maxcol,/6 $
   matmod maxcol,,,,,/biggestg,/7 $
   paraml biggestg//'DMI'/1/1/s,n,largest $
   chktol=largest/(1.e10) $
   message //' calculated value of checktol ='/chktol $
   message //' ' $
  else $
   chktol=checktol $
  endif $
  DIAGONAL CHKKGG/DIAGKGG/'COLUMN'/1.0 $
  MATMOD DIAGKGG,,,,,/BIGGEST,/7 $
  PARAML BIGGEST//'DMI'/1/1/S,N,TEST $
  message //' '
  message //' Model checking is invoked - MSC recommends that a'/
            'separate run using PARAM,CHECKOUT,YES should also'/
            ' be done to insure model accuracy.' $
  message //' ' $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX KGG FOLLOW' $
$ 
  message //' ' $
  message //' all 6 directions are checked, only those dofs which'/
               ' fail will be printed' $
  message //' ' $
  IF (TEST>CHKTOL) THEN $
    message //' ' $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TEST/
            ' EXCEEDS LIMIT OF'/CHKTOL $
  pass = 1 $
  equivx reacg/dummy/-1 $
  icount = 1 $
  message //' ' $
  message //' the following directions have failed the test'
  message //' ' $
  do while(icount<7) $
   paraml diagkgg//'dmi'/1/icount/s,n,strain $
   strain=abs(strain) $
$message //'icount='/icount/'strain ='/strain/
$        ' chktol='/chktol $ $
   if(strain>chktol)then $
    message //' ' $
    message //'direction'/icount/' has strain energy ='/
     ' ='/strain $
    message //' ' $
   endif $
   icount=icount+1 $
  enddo $
   message //' ' $
   message //' some possible reasons for this are - ' $
   message //' ' $
   message //' 1) CELASi elements connecting to only one grid point' $
   message //' ' $
   message //' 2) CELASi elements connection to non-coincident points' $
   message //' ' $
   message //' 3) CELASi elements connecting to non-colinear dof' $
   message //' ' $
   message //' 4) Improperly defined DMIG matrices' $
   message //' ' $
    NORM  REACG/REACGNRM/ $
$    MATPRN CHKKGG,diagkgg// $
$    MATGPR GPLS,USETB,SILS,REACGNRM//'H'/'G'//printol $
$ loop for printout
$
  file reaccolg=ovrwrt $
  file outreac=ovrwrt $
  file partreac=ovrwrt $
  icount = 1 $
  do while(icount<7) $
   paraml diagkgg//'dmi'/1/icount/s,n,strain $
   strain=abs(strain) $
$message //'icount='/icount/'strain ='/strain/
$        ' chktol='/chktol $ $
   if(strain>chktol)then $
    message //' ' $
    message //'strain energy for direction'/icount/
     ' ='/strain $
    message //' ' $
    message //'Reaction forces for this check follow -' $
    message //' these terms are normalized to a maximum value of ' $
    message //'1.OE+0.  Only terms larger than'/printol/' are printed' $
    message //' ' $
    message //' use param,printol to change this value' $
    message //' ' $
    icm1=icount - 1 $
    matgen ,/partreac/6/6/icm1/1 $
    partn reacgnrm,partreac,/,,reaccolg,/1 $
    MATGPR GPLS,USETB,SILS,REACcolg//'H'/'G'//printol $
   endif $
   icount = icount + 1 $
  enddo $
  ELSE $
    MESSAGE //'MATRIX KGG PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHKTOL $
  ENDIF $
  if(tolgn>0. and test>tolgn)then $
   message //' ' $
   message //'check of kgg has failed strain energy test' $
   message //'largest strain energy term of'/test/' is greater'/
             ' than param tolgn('/tolgn/') run terminated' $
   exit $
  endif $

ENDIF $
$
$
$ CHECK KNN
$
IF (CHKSTIF>-1 AND MATTYP=2) THEN $
  $ CHECK KNN FOR CONSTRAINTS
  CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
$ fix error if no M-set defined
  paraml usetb//'uset'//////'m'/s,n,nomsetx $
  if(nomsetx>0)then $
   UPARTN USETB,RBG1/RBN,,,/'G'/'N'/'M'/1 $
  else $
   equivx rbg1/rbn/always $
  endif $
  TRNSP RBN/RBTN $
  MPYAD INMAT,RBN,/REACN/ $
  MPYAD RBTN,REACN,/CHKKNN/ $
$ CHECK IF CHECKTOL IS EXCEEDED
  DIAGONAL CHKKNN/DIAGKNN/'COLUMN'/1.0 $
  MATMOD DIAGKNN,,,,,/BIGNEST,/7 $
  PARAML BIGNEST//'DMI'/1/1/S,N,TESTN $
  message //' ' $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX KNN FOLLOW' $
  message //' ' $
$
  message //' all 6 directions are checked, only those dofs which'/
               ' fail will be printed' $
  if(checktol=0.)then $ scale by largest term
   message //' ' $
   message //' no value provided for parameter checktol' $
   message //' ' $
   matmod inmat,,,,,/maxcol,/6 $
   matmod maxcol,,,,,/biggestn,/7 $
   paraml biggestn//'DMI'/1/1/s,n,largest $
   chktol=largest/(1.e10) $
   message //' calculated value of checktol ='/chktol $
   message //' ' $
  else $
   chktol=checktol $
  endif $
$
  IF (TESTN>CHKTOL) THEN $
   message //' ' $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TESTN/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHKTOL $
   message //' ' $
  pass = 1 $
  equivx reacn/dummy/-1 $
  icount = 1 $
  message //' ' $
  message //' the following directions have failed the test'
  message //' ' $
  do while(icount<7) $
   paraml diagknn//'dmi'/1/icount/s,n,strain $
   strain=abs(strain) $
$message //'icount='/icount/'strain ='/strain/
$        ' chktol='/chktol $ $
   if(strain>chktol)then $
    message //' ' $
    message //'direction'/icount/' has strain energy ='/
     ' ='/strain $
    message //' ' $
   endif $
   icount=icount+1 $
  enddo $
   message //' ' $
   message //' Some possible causes of this are -' $
   message //' ' $
   message //' 1) MPC equations which do not satisfy rigid-body motion' $
   message //' ' $
   message //' 2) RBE3 elements for which the independent dof '/
                 'cannot describe all possible rigid-body motions' $
   message //' ' $
    NORM  REACN/REACNNRM/ $
$    MATPRN CHKKNN // $
$    MATGPR GPLS,USETB,SILS,REACNNRM//'H'/'N'//printol $
$ loop for printout
$
  file outreac=ovrwrt $
  file reaccoln=ovrwrt $
  icount = 1 $
  do while(icount<7) $
   paraml diagknn//'dmi'/1/icount/s,n,strain $
   strain = abs(strain) $
   if(strain>chktol)then $
    message //' ' $
    message //'strain energy for direction'/icount/
     ' ='/strain $
    message //' ' $
    message //'normalized reactions for that check follow' $
    message //'only terms larger than'/printol/' are printed' $
    message //' ' $
    message //' use param,printol to change this value' $
    icm1=icount - 1 $
    matgen ,/partreac/6/6/icm1/1 $
    partn reacnnrm,partreac,/,,reaccoln,/1 $
    MATGPR GPLS,USETB,SILS,REACcoln//'H'/'N'//printol $
   endif $
   icount = icount + 1 $
  enddo $
$
  ELSE $
    MESSAGE //'MATRIX KNN PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHKTOL $
  ENDIF $
  if(tolgn>0. and testn>tolgn)then $
   message //'check of knn has failed strain energy test' $
   message //'largest strain energy term of'/testn/' is greater'/
             ' than param tolgn('/tolgn/') run terminated' $
   exit $
  endif $
$
ENDIF $
$
$$$$$$$$$$$ added March, 1999 - check F-set stiffness
$
$
$ CHECK KFF
$
IF (CHKSTIF>-1 AND MATTYP=25) THEN $
  $ CHECK KFF FOR CONSTRAINTS
  CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
  UPARTN USETB,RBG1/RBF,,,/'G'/'F'/'M'/1 $
  TRNSP RBF/RBTF $
  MPYAD INMAT,RBF,/REACF/ $
  MPYAD RBTF,REACF,/CHKKFF/ $
$ CHECK IF CHECKTOL IS EXCEEDED
  DIAGONAL CHKKFF/DIAGKFF/'COLUMN'/1.0 $
  MATMOD DIAGKFF,,,,,/BIGFEST,/7 $
  PARAML BIGFEST//'DMI'/1/1/S,N,TESTF $
  message //' ' $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX KFF FOLLOW' $
  message //' ' $
$
  message //' all 6 directions are checked, only those dofs which'/
               ' fail will be printed' $
  if(checktol=0.)then $ scale by largest term
   message //' ' $
   message //' no value provided for parameter checktol' $
   message //' ' $
   matmod inmat,,,,,/maxcol,/6 $
   matmod maxcol,,,,,/biggestf,/7 $
   paraml biggestf//'DMI'/1/1/s,n,largest $
   chktol=largest/(1.e10) $
   message //' calculated value of checktol ='/chktol $
   message //' ' $
  else $
   chktol=checktol $
  endif $
$
  IF (TESTF>CHKTOL) THEN $
   message //' ' $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TESTF/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHKTOL $
   message //' ' $
  equivx reacf/dummy/-1 $
  pass = 1 $
  icount = 1 $
  message //' ' $
  message //' the following directions have failed the test'
  message //' ' $
  do while(icount<7) $
   paraml diagkff//'dmi'/1/icount/s,n,strain $
   strain=abs(strain) $
$message //'icount='/icount/'strain ='/strain/
$        ' chktol='/chktol $ $
   if(strain>chktol)then $
    message //' ' $
    message //'direction'/icount/' has strain energy ='/
     ' ='/strain $
    message //' ' $
   endif $
   icount=icount+1 $
  enddo $
   message //' ' $
   message //' Some possible causes of this are -' $
   message //' ' $
   message //' 1) Constraints which prevent rigid-body motion' $
   message //' ' $
   message //' ' $
    NORM  REACF/REACFNRM/ $
$    MATPRN CHKKFF // $
$    MATGPR GPLS,USETB,SILS,REACFNRM//'H'/'F'//printol $
$ loop for printout
$
  file outreac=ovrwrt $
  file reaccolf=ovrwrt $
  icount = 1 $
  do while(icount<7) $
   paraml diagkff//'dmi'/1/icount/s,n,strain $
   strain = abs(strain) $
   if(strain>chktol)then $
    message //' ' $
    message //'strain energy for direction'/icount/
     ' ='/strain $
    message //' ' $
    message //'normalized reactions for that check follow' $
    message //'only terms larger than'/printol/' are printed' $
    message //' ' $
    message //' use param,printol to change this value' $
    icm1=icount - 1 $
    matgen ,/partreac/6/6/icm1/1 $
    partn reacfnrm,partreac,/,,reaccolf,/1 $
    MATGPR GPLS,USETB,SILS,REACcolf//'H'/'F'//printol $
   endif $
   icount = icount + 1 $
  enddo $
$
  ELSE $
    MESSAGE //'MATRIX KFF PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHKTOL $
  ENDIF $
  if(tolf>0. and testn>tolf)then $
   message //'check of kff has failed strain energy test' $
   message //'largest strain energy term of'/testf/' is greater'/
             ' than param tolgn('/tolf/') run terminated' $
   exit $
  endif $
$
ENDIF $
$
IF (CHKSTIF>-1 AND MATTYP=3) THEN $
$ Sept 8, 1992 - check if no reduction to A-set
  PARAML KAA//'TRAILER'/2/S,N,ASIZE $
  CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
  PARAML RBG1//'TRAILER'/2/S,N,GSIZE $
  IF (GSIZE=ASIZE) THEN $
    EQUIVX RBG1/RBA/ALWAYS $
  ELSE $
    UPARTN USETB,RBG1/RBA,,,/'G'/'A'/'O'/1 $
  ENDIF $
  $ CHECK KAA FOR CONSTRAINTS
  TRNSP RBA/RBTA $
  MPYAD KAA,RBA,/REACA/ $
  MPYAD RBTA,REACA,/CHKKAA/ $
$ CHECK IF CHECKTOL IS EXCEEDED
  DIAGONAL CHKKAA/DIAGKAA/'COLUMN'/1.0 $
  MATMOD DIAGKAA,,,,,/BIGAEST,/7 $
  PARAML BIGAEST//'DMI'/1/1/S,N,TESTA $
  message //' ' $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX KAA FOLLOW' $
    message //' ' $
  message //' all 6 directions are checked, only those dofs which'/
               ' fail will be printed' $
  message //' ' $
  if(checktol=0.)then $ scale by largest term
   message //' ' $
   message //' no value provided for parameter checktol' $
   message //' ' $
   matmod kaa,,,,,/maxcol,/6 $
   matmod maxcol,,,,,/biggesta,/7 $
   paraml biggesta//'DMI'/1/1/s,n,largest $
   chktol=largest/(1.e10) $
$matprn kaa,maxcol,biggesta// $
$message //' largest='/largest $
   message //' calculated value of checktol ='/chktol $
   message //' ' $
  else $
   chktol=checktol $
  endif $
$
  IF (TESTA>CHKTOL) THEN $
    NORM  REACA/REACANRM/ $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TESTA/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHKTOL $
    message //' ' $
$ 
    message //' If the G- or N- checks have failed, they '/
              'should be resolved before looking at the a-'/
              'set checks' $
$  
  equivx reaca/dummy/-1 $
  pass = 1 $
  icount = 1 $
  message //' ' $
  message //' the following directions have failed the test'
  message //' ' $
  do while(icount<7) $
   paraml diagkaa//'dmi'/1/icount/s,n,strain $
   strain=abs(strain) $
$message //'icount='/icount/'strain ='/strain/
$        ' chktol='/chktol $ $
   if(strain>chktol)then $
    message //' ' $
    message //'direction'/icount/' has strain energy ='/
     ' ='/strain $
    message //' ' $
   endif $
   icount=icount+1 $
  enddo $
    message //' ' $
    message //' if the model has passed the previous G and N checks'/
              ' possible reasons for failing this test are -' $
    message //' ' $
    message //' 1) the structure is not intended to be free-free' $
    message //'     - if this is the case (a constrained structure)'/
              ' failing this check is a sign that the structure' $
    message //'       is properly constrained to ground' $
    message //' ' $
    message //' 2) param,grdpnt is located far from the cg of the'/
            ' model. MSC recommends that GRDPNT should be located' $
    message  //' as close as possible to the geometric center of'/
              ' the model (see GPWG output)' $
    message //' ' $
    message //' 3) Autospc constrains near-singular dof.' $
    message //'    When a finite element model with AUTOSPC fails' $
    message //'    the KAA test, it is NOT evidence that grounding ' $
    message //'    has occurred.  The use of PARAM,SNORM will not' $
    message //'    eliminate the spurious failure' $
    message //' ' $
$    MATPRN CHKKAA // $
$    MATGPR GPLS,USETB,SILS,REACANRM//'H'/'A'//printol $
$ loop for printout
$
  file outreac=ovrwrt $
  file reaccola=ovrwrt $
  icount = 1 $
  do while(icount<7) $
   paraml diagkaa//'dmi'/1/icount/s,n,strain $
   strain = abs(strain) $
   if(strain>chktol)then $
    message //' ' $
    message //'strain energy for direction'/icount/
     ' ='/strain $
    message //'normalized reactions for that check follow' $
    message //'only terms larger than'/printol/' are printed' $
    message //' ' $
    message //' use param,printol to change this value' $
    icm1=icount - 1 $
    matgen ,/partreac/6/6/icm1/1 $
    partn reacanrm,partreac,/,,reaccola,/1 $
    MATGPR GPLS,USETB,SILS,REACcola//'H'/'A'//printol $
   endif $
   icount = icount + 1 $
  enddo $

  ELSE $
    MESSAGE //'MATRIX KAA PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHKTOL $
  ENDIF $
type parm,,rs,y,tolkaa=-1.0 $
$message //' testing tolkaa, input value = '/tolkaa $
  if(tolkaa>0.) then $
   if(testa>tolkaa) then $
   message //' ' $
   message //'check of kaa has failed strain energy test' $
   message //'largest strain energy term of'/testa/' is greater'/
             ' than param tolkaa('/tolkaa/') run terminated' $
   exit $
   endif $
  endif $

  $ LABEL NOKAACHK $
ENDIF
$
$ CHECK MGG
$
IF (CHKMASS>-1 AND MATTYP=4) THEN $
  CALL DBFETCH /RBG1,RBTG1,,,/SEID/0/0/0/S,FOUNDIT $
  MPYAD MGG RBG1,/MGRB/ $
  MPYAD RBTG1,MGRB,/MASS/ $
  ADD MASS,/WGHTG/MASSWT $
  MESSAGE //'RESULTS OF CHECK OF MGG' $
  CALL DBSTORE WGHTG,,,,//PEID/0/'DBALL'/0 $
  MATPRN WGHTG// $
  PRTPARM //0/'MASSWT' $
  PRTPARM //0/'GRDPNT' $
ENDIF $
$
$ CHECK MNN
$
IF (CHKMASS>-1 AND CHKMASS <3 AND MATTYP=5) THEN $
  CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
$ check for safety (shouldn't be needed) - 11/30/98
  paraml usetb//'uset'//////'m'/s,n,nomsetx $
  if(nomsetx>0)then $
   UPARTN USETB,RBG1/RBN,,,/'G'/'N'/'M'/1 $
  else $
   equivx rbg1/rbn/always $
  endif $
  MPYAD INMAT,RBN,/MNRB/ $
  MPYAD RBN,MNRB,/MASS/1 $
  ADD MASS,/WGHTN/MASSWT $
  MESSAGE //'RESULTS OF CHECK OF MNN' $
  MATPRN WGHTN// $
  PRTPARM //0/'MASSWT' $
  PRTPARM //0/'GRDPNT' $
ENDIF $
$
$ AFTER MAA STORE
$
IF(CHKMASS>-1 AND CHKMASS<2 AND MATTYP=6) THEN $
$ Sept 8, 1992 - fix if no reduction
  PARAML MAA//'TRAILER'/2/S,N,ASIZE $
  CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
  PARAML RBG1//'TRAILER'/2/S,N,GSIZE $
  IF (GSIZE=ASIZE) THEN $
    EQUIVX RBG1/RBA/ALWAYS $
  ELSE $
    UPARTN USETB,RBG1/RBA,,,/'G'/'A'/'O'/1 $
  ENDIF $
$matprn rbg1,rba// $
  MPYAD MAA,RBA,/MARB $
  TRNSP RBA/RBTA/ $
  MPYAD RBTA,MARB,/MASSA/ $
  ADD MASSA,/WGHTA/MASSWT $
  MESSAGE //'RESULTS OF CHECK OF MAA' $
  MATPRN WGHTA// $
$ SAVE WGTHA FOR USE ON EFFECTIVE WEIGHT FRACTION CALCULATIONS
  CALL DBSTORE WGHTA,,,,//PEID/0/'DBALL'/0 $
  PRTPARM //0/'MASSWT' $
  PRTPARM //0/'GRDPNT' $
ENDIF $
$
$ CHECK XGG1 = KJJ+KAA
$
IF (CHKSTIF>-1 AND MATTYP=11)THEN $
  $ CHECK KJJ+KAA FOR CONSTRAINTS
  CALL DBFETCH /RBG1,RBTG1,,,/SEID/0/0/0/S,FOUNDIT $
  MPYAD INMAT,RBG1,/REACX/ $
  MPYAD RBTG1,REACX,/CHKXGG/ $
  MESSAGE //'CHECK OF KJJ+KAA = CURRENT STIFFNESS AND UPSTREAM '/
            'STATICALLY REDUCED STIFFNESS' $
  MESSAGE //'  SHOULD BE USED INSTEAD OF CHKKGG WHEN UPSTREAM '/
            'MODES ARE ATTACHED TO GRID POINTS' $
$ CHECK IF CHECKTOL IS EXCEEDED
  DIAGONAL CHKXGG/DIAGRGG/'COLUMN' $
  MATMOD DIAGRGG,,,,,/BIGREST,/7 $
  PARAML BIGREST//'DMI'/1/1/S,N,TESTR$
  message //' ' $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX XGG FOLLOW' $
  message //' ' $
  if(checktol=0.)then $ scale by largest term
   message //' ' $
   message //' no value provided for parameter checktol' $
   message //' ' $
   matmod inmat,,,,,/maxcol,/6 $
   matmod maxcol,,,,,/biggestr,/7 $
   paraml biggestr//'DMI'/1/1/s,n,largest $
   chktol=largest/(1.e10) $
   message //' calculated value of checktol ='/chktol $
   message //' ' $
  else $
   chktol=checktol $
  endif $
  IF (TESTR>CHKTOL) THEN $
    NORM  REACX/REACXNRM/ $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TESTR/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHKTOL $
  file outreacx=ovrwrt $
  file reaccolx=ovrwrt $
  icount = 1 $
  do while(icount<7) $
   paraml diagrgg//'dmi'/1/icount/s,n,strain $
   if(strain>chktol)then $
    message //'strain energy for direction'/icount/
     ' ='/strain $
    message //'normalized reactions for that check follow' $
    message //'only terms larger than'/printol/' are printed' $
    message //' use param,printol to change this value' $
    icm1=icount - 1 $
    matgen ,/partreac/6/6/icm1/1 $
    partn reacxnrm,partreac,/,,reaccolx,/1 $
    MATGPR GPLS,USETB,SILS,REACcolx//'H'/'G'//printol $
   endif $
   icount = icount + 1 $
  enddo $
$    MATPRN CHKXGG // $
$    MATGPR GPLS,USETB,SILS,REACXNRM//'H'/'G'//printol $WAS USETB
  ELSE $
    MESSAGE //'MATRIX XGG PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHKTOL $
  ENDIF $
ENDIF $
$
RETURN $
END $
$ -------------------------------------------------------------------
$
$ SUBDMAP KEEFW - CALCULATE KE AND EFW IF REQUESTED
$
$ -------------------------------------------------------------------
COMPILE KEEFW $
$
SUBDMAP KEEFW UGVS1/TEST99,ENRGnUPM,kessmm/SEID/PEID $
$
$ SUBDMAP KEEFW - CALCULATE KE AND EFW IF REQUESTED
$
TYPE DB,EQEXINS,GPLS,SILS,USET,MGG,MJJ,zuzr04,zuzr06 $
type db,bgpdts,cstms $ added for rbg if it doesn't exist
type db,aagds $ dof used as q-set in current or upstrm se
TYPE PARM,NDDL,I,N,SEID $
TYPE PARM,,I,N,(LUSETD),temp $
TYPE PARM,,I,Y,(KEPRT=1,EFWGT=2,KEEFW=1) $
TYPE PARM,,I,Y,dontqset=-1 $
TYPE PARM,NDDL,I,N,NOUP,PEID,zuzr1 $
TYPE PARM,NDDL,RS,Y,(WTMASS) $
TYPE PARM,,RS,N,(MW) $
TYPE PARM,,CS,Y,(MASSWT) $
TYPE PARM,,I,N,FOUNDITR=0, founditw=0, gotit $
TYPE PARM,,I,N,NOMODES=0 $
TYPE PARM,,RS,Y,KEFILTER=.01 $ filter on kinetic energy print 12-08-1992
type parm,,i,y,oldefw=-1 $ flag for absolute value on effective weight
type parm,,i,n,elemke=-1 $ element ke if ESE is in case control 11/18/1993
type parm,,i,y,nokeng=-1, NOROKEPL=-1, NOTRKEPL=-1, NOROUPPL=-1
type parm,,i,y,massg=-1 $ If MASSG<>-1, use J- mass matrices with collectors
$                         for kinetic energy plot calculations
$
 temp = peid $
$message //'peid ='/peid/' qsetdof should follow' $
$dbdict datablk=(ptga,aagds), select(name,size,seid,peid) $
dbview qsetdof=aagds, where(peid=temp and wildcard=true)
$matprn qsetdof// $
$
if(keprt=-1)keprt=nokeng $ get value from either source
IF(WTMASS=0.)WTMASS=1. $
MW=1./WTMASS $
MASSWT=CMPLX(MW,0.) $
$
$ AFTER SDR1 - SYSTEM K.E.
$
IF (KEPRT<0 AND EFWGT<0)KEEFW=-1
 $
IF (KEEFW>-1)THEN $ REQUEST MADE FOR KE OR EFW OR BOTH
       if (dontqset=-1 and keprt>-1) then $
$
$        following added to remove Q-set dof from the kinetic
$        energy output 10/12/1992
$
$      call dbfetch /qsetdof,,,,/peid/0/0/0/s,gotit $
$         if (gotit=-1) then $
         matmod qsetdof,,,,,/nullcol5,/12/s,n,nulcol/1 $
         paraml qsetdof//'TRAILER'/1/s,n,nocol $
         if (nocol<>nulcol) then $
           PARTN ugvs1,,qsetdof/ugX,,,/1 $
           MERGE ugX,,,,,qsetdof/ugvs2/1 $
         else $
           equivx ugvs1/ugvs2/always $
         endif $
       else $
           equivx ugvs1/ugvs2/always $
       endif $
   if(efwgt>-1) then $ get rbg1
     CALL DBFETCH /RBG1,,,,/PEID/0/0/0/S,FOUNDITR $
       if (founditr<>-1)then $ no rbg
$
$    calculate RBG1 if it doesn't exist 10/12/1992
$
         VECPLOT ,,BGPDTS,EQEXINS,CSTMS,,,,/RBTG1/GRDPNT//4 $
$         paraml qsetdof//'presence'////s,n,gotit $
$         if (gotit=-1) then $
$           call dbfetch /qsetdof,,,,/peid/0/0/0/s,gotit $
$         else $
$           gotit = -1 $
$         endif $
$         if (gotit=-1) then $
          matmod qsetdof,,,,,/nullcol6,/12/s,n,nulcol/1 $
          paraml qsetdof//'TRAILER'/1/s,n,nocol $
          if (nocol<>nulcol) then $
           PARTN RBTG1,qsetdof,/RBX,,,/1 $
           PURGEX /RBTG1,,,,/ALWAYS $
           MERGE RBX,,,,qsetdof,/RBTG1/1 $
          endif $
         trnsp rbtg1/rbg1 $
         CALL DBSTORE rbg1,,,,//SEID/0/'DBALL'/s,gotit $
       endif $
   endif $ get rbg1
   CALL DBFETCH /WGHTA,,,,/PEID/0/0/0/S,FOUNDITW $
   IF (NOUP>0) THEN $
$
$    superelement has upstream superelements -
$      get assembly ke and efwgt
$
    PARAML   USET//'USET'////S,N,NOUSET//'Q'/S,N,NOQSET $
    if(noqset>0)then $ remove q-set for current se
$
$ remove displacements for current q-set
$
     upartn uset,ugvs1/,ugnoq,,/'G'/'Q'/'S'/1 $
     umerge uset,,ugnoq/ugvsnew/'G'/'Q'/'S' $
     equivx ugvsnew/ugvs1/always $
    endif $
     MPYAD UGVS1,MGG,/PHITM/1//// $
     IF (EFWGT>-1)THEN $
       MPYAD PHITM,RBG1,/MER///// $
       TRNSP MER/MERT $
       TRNSP MER/MERTA $
$ get plus or minus sign on effective weight 10/12/1992
$  add option for absolute value of effective weight 11/18/93
     IF (oldefw>-1) then $ absolute value of efwgt
       add mert,merta/efwwup/masswt//1 $
     else $ retain sign convention
       diagonal mert/mert2/'whole'/1. $
       ADD MERT2,MERT/EFWWUP/MASSWT//1 $
     endif $ oldefw
$
     message //' ' $
     message //' the following output - efwwup - is the modal'/
               ' effective weight of the assembly' $
     message //' ' $
     message //' each column represents a mode and each row'/
               ' represents a direction (1=x, etc)' $
     message //' ' $
       MATPRN EFWWUP// $
       IF (EFWGT=2) THEN $      EFFECTIVE WEIGHT FRACTIONS
         IF (FOUNDITW=-1) THEN $  FOUND WGHTA
          DIAGONAL WGHTA/WGHT $
          TRNSP WGHT/WGHTT $
          MPYAD MERT,MER,/MERTMER $
          MESSAGE //'PERFORMING EFFECTIVE WEIGHT FRACTION CALCULATIONS'/
                    ' FOR CURRENT SUPERELEMENT' $
          MESSAGE //' ' $
          MESSAGE //'MATRIX MERTMERW IS THE TOTAL EFFECTIVE WEIGHT FOR'/
                    ' THE ASSEMBLY OF THIS SUPERELEMENT AND ALL '/
                    'UPSTREAMS FOR THE MODES OBTAINED' $'/
          message //'and should be compared to the total weight'/
                    ' available' $
          message //' ' $
          ADD MERTMER,/MERTMERW/MASSWT $
          MATPRN MERTMERW// $
          ADD MERTMERW,WGHTA/FRACT///2 $
          DIAGONAL FRACT/FRACTOT $
          MESSAGE //' ' $
          MESSAGE //' MATRIX FRACTOT IS THE FRACTION OF THE TOTAL '/
                   'ASSEMBLY'/
                   ' WEIGHT AFTER REDUCTION IN EACH DIRECTION ' $
          MESSAGE //' WHICH CAN BE REPRESENTED BY THE MODES' $
          MESSAGE //' ONCE AGAIN THIS IS FOR THE ASSEMBLY OF THIS'/
                    ' SUPERELEMENT WITH ALL UPSTREAM CONNECTIONS' $
          MESSAGE //' (NOTE: THE REDUCED WEIGHT IS USED BECAUSE ANY '/
             'MASS ATTACHED TO CONSTRAINED DOF IS NO LONGER AVAILABLE ' $
          MESSAGE //' WHEN THE EIGENVALUE SOLUTION IS PERFORMED)' $
          message //' ' $
          message //' each row represents the fraction in the'/
                    ' associated direction (1=x, etc)' $
          message //' ' $
          MATPRN FRACTOT// $
$         NOW FIND THE FRACTION FOR EACH MODE
          PARAML EFWWUP//'TRAILER'/1/S,N,NOMODES $
          MATGEN ,/IDENTM/1/NOMODES $
          DIAGONAL IDENTM/IDENTM1 $
          MPYAD IDENTM1,WGHTT,/WGHTA1 $
          MATMOD WGHTA1,,,,,/WGHT2,/2////.00001 $ Get rid of small terms
          TRNSP WGHT2/WGHT1 $
          ADD   EFWWUP,WGHT1/EFWFRACT///2 $
          MESSAGE //' '$
          MESSAGE //' MATRIX EFWFRACT IS THE FRACTION OF THE '/
                    'EFFECTIVE WEIGHT FOR EACH MODE' $
          MESSAGE //' (ONCE AGAIN, FOR THE ASSEMBLY)' $
     message //' ' $
     message //' each term represents the fraction of the total'/
               ' available weight in the associated direction'/
               ' which that mode can represent' $
     message //' ' $
     message //' each column represents a mode and each row'/
               ' represents a direction (1=x, etc)' $
     message //' ' $
          MATPRN EFWFRACT// $
         ELSE $
          message //' Effective weight fractions requested for '/
             'superelement'/seid/', but the mass checks were' $
          message //' not run. Therefore, the weight after '/
              'reduction is not available for use in the '/
              'calculation' $
          message //' Effective weight fractions not calculated' $
         ENDIF $ FOUNDIT=1
       ENDIF $ EFWGT=2
     ENDIF $ EFWGT>-1
     IF (KEPRT>-1) THEN $
       TRNSP PHITM/PHITMT $
       ADD PHITMT,UGVS2/ENERGWUP///1 $
       MPYAD PHITM,UGVS1,/TOTEN1/ $
       DIAGONAL TOTEN1/TOTENWUP $
$
     message //' the following output - totenwup - is the fraction'/
               ' of the total kinetic energy for each mode which' $
     message //' the current superelement assembly (including '/
               'upstreams) can represent' $'/
     message //' '
     message //' each term represents the fraction of the kinetic'/
              ' energy for the associated mode which is contained'/
               ' in this assembly' $
     message //' ' $
       MATPRN TOTENWUP// $
     message //' ' $
      message //'Summation of kinetic energy for the assembly' $
     message //'Only the translation terms are correct in the '/
              ' summation. The rotational terms are incorrect' $
     message //' if you have output coordinate sysems, the summations'/
               ' may be incorrect' $
     vecplot ENERGWUP,bgpdts,eqexins,cstms,,,,/ener1/0/0/1/
              'enerwup'///ALTSHAPE//SEID  $
     message //' ' $
     message //' the following output - energwup - is the fraction'/
               ' of the total kinetic energy contained in the' $
     message //' current assembly - it includes the contributions'/
               ' of upstream masses' $
     message //' ' $
     message //' each column represents a mode any dof which have'/
               ' more than 1% of the kinetic energy are printed' $
     message //' ' $
         MATGPR GPLS,USET,SILS,ENERGWUP//'H'/'G'//kefilter $FILTER ON ENERGY
      endif $ keprt>-1
     $
  ENDIF $ noup>0
  $
  $
  MPYAD UGVS1,MJJ,/PHITMJ/1//// $
   IF(EFWGT>-1) THEN $
     MPYAD PHITMJ,RBG1,/MERJ///// $
     TRNSP MERJ/MERJT $
     TRNSP MERJ/MERJTA $
$ get plus or minus sign on effective weight 10/12/1992
$  add option for absolute value of effective weight 11/18/93
     IF (oldefw>-1) then $ absolute value of efwgt
       add merjt,merjta/efwnoup/masswt//1 $
     else $ retain sign convention
       diagonal merjt/merjt1/'whole'/1. $
       ADD MERJT1,MERJTA/EFWNOUP/MASSWT//1 $
     endif $ oldefw
     message //' ' $
     message //' the following output - efwnoup - is the modal'/
               ' effective weight of the current superelement' $
     message //' without the contributions of upstream'/
               ' superelement mass' $
     message //' ' $
     message //' each column represents a mode and each row'/
               ' represents a direction (1=x, etc)' $
     message //' ' $
     MATPRN EFWNOUP// $
       IF (EFWGT=2) THEN $      EFFECTIVE WEIGHT FRACTIONS
         paraml wghtt//'presence'////s,n,nowgt $
         IF (nowgt=-1) THEN $
           DIAGONAL WGHTA/WGHT $
           TRNSP WGHT/WGHTT $
         ENDIF $
         IF (FOUNDITW=-1) THEN $  FOUND WGHTA
          MPYAD MERJT,MERJ,/MERTMER9 $
          message //' ' $
          MESSAGE //'PERFORMING EFFECTIVE WEIGHT FRACTION CALCULATIONS'/
                    ' FOR THIS SUPERELEMENT WITHOUT UPSTREAM'/
                    ' CONTRIBUTIONS' $
          MESSAGE //' ' $
          MESSAGE //'MATRIX MERTMERJ IS THE TOTAL CONTRIBUTION OF THIS'/
                    ' SUPERELEMENT TO THE EFFECTIVE WEIGHT FOR'/
                   ' THE MODES OBTAINED' $
          message //'  once again, this does not include upstream'/
                  ' superelement mass contributions' $
          ADD MERTMER9,/MERTMERJ/MASSWT $
          MATPRN MERTMERJ// $
          ADD MERTMERJ,WGHTA/FRACTJ///2 $
          DIAGONAL FRACTJ/FRACTOTJ $
          MESSAGE //' ' $
          MESSAGE //' MATRIX FRACTOTJ IS THE FRACTION OF THE '/
                   'REDUCED SUPERELEMENT'/
                   ' WEIGHT IN EACH DIRECTION ' $
          MESSAGE //' (FOR THIS SUPERELEMENT WITHOUT '/
                    'UPSTREAM CONTRIBUTIONS)' $
          MESSAGE //'WHICH CAN BE REPRESENTED BY THE MODES' $
          MESSAGE //' (NOTE: THE REDUCED WEIGHT IS USED BECAUSE'/
                    ' ANY MASS '/
                   'ATTACHED TO CONSTRAINED DOF IS NO LONGER AVAILABLE ' $
          MESSAGE //'WHEN THE EIGENVALUE SOLUTION IS PERFORMED' $
          message //' ' $
          MATPRN FRACTOTJ// $
          IF (NOUP<=0) THEN $
           PARAML EFWNOUP//'TRAILER'/1/S,N,NOMODES $
           MATGEN ,/IDENTM/1/NOMODES $
           DIAGONAL IDENTM/IDENTM1 $
           MPYAD IDENTM1,WGHTT,/WGHTA1 $
           MATMOD WGHTA1,,,,,/WGHT2,/2////.00001 $ get rid of small terms
           TRNSP WGHT2/WGHT1 $
          ENDIF $ NOUP<=0
          ADD   EFWNOUP,WGHT1/EFWFRACJ///2 $
          MESSAGE //' '$
          MESSAGE //' MATRIX EFWFRACJ IS THE FRACTION OF THE '/
                    'EFFECTIVE WEIGHT FOR EACH MODE' $
          MESSAGE //' (ONCE AGAIN WITHOUT UPSTREAM CONTRIBUTIONS)' $
          message //' ' 
     message //' each column represents a mode and each row'/
               ' represents a direction (1=x, etc)' $
     message //' ' $
          MATPRN EFWFRACJ// $
         ENDIF $ FOUNDIT=1
       ENDIF $ EFWGT=2
   ENDIF $ EFWGT>-1
   $
   IF(KEPRT>-1) THEN $
     TRNSP PHITMJ/PHITMJT $
     ADD PHITMJT,UGVS2/ENERNOUP///1 $
     MPYAD PHITMJ,UGVS1,/TOTEN2/ $
     DIAGONAL TOTEN2/TOTENOUP $
     MATPRN TOTENOUP// $
$ 
     message //'Summation of kinetic energy for ths superelement' $
     message //'Only the translation terms are correct in the '/
              ' summation. The rotational terms are incorrect' $
     message //' ' $
       vecplot ENERNOUP,bgpdts,eqexins,cstms,,,,/ener/0/0/1/
             'enernoup'///ALTSHAPE//SEID  $
       if(nokeng<>-1)then $
$         paraml qsetdof//'presence'////s,n,gotit $
$         if (gotit=-1) then $
$           call dbfetch /qsetdof,,,,/peid/0/0/0/s,gotit $
$         endif $
         matmod qsetdof,,,,,/nullcol7,/12/s,n,nulcol/1 $
         paraml qsetdof//'TRAILER'/1/s,n,nocol $
         DIAGONAL UGVS2/UGVSABS/'WHOLE'/1.0 $ ABSOLUTE
         if(noup<0 or massg=1)then $
         ADD PHITMjT,UGVSabs/ENRGnUPM///1 $ kinetic energy with sign convention
         else $ upstream superelements exist
         ADD PHITMT,UGVSabs/ENRGnUPM///1 $ kinetic energy with sign convention
         endif $ noup<0
$         if(gotit=-1)then $
         if (nocol<>nulcol) then $
           PARTN    enrgnupm,,qsetdof/KESSP,KESSQ,,/1 $       PARTITION
         else $
           equivx enrgnupm/kessp/always $
         endif $
         PARAML   KESSP//'TRAILER'/2/S,N,NROWP $NUMBER OF ROWS IN KESSP
         MATGEN   ,/TTTRRR/4/1/NROWP/1/3/4/1 $    GENERATE PARTN VECTOR
         MATGEN   ,/RRRTTT/4/1/NROWP/1/3/4/4 $    GENERATE MERGE VECTOR
$matprn tttrrr,rrrttt// $
         PARTN    KESSP,,TTTRRR/KESSR,KESST,,/1 $ PRTN INTO ROT & TRANS
         MERGE    KESSR,KESST,,,,RRRTTT/KESSMq/1 $ USE NEW MERGE VECTOR
$ mw
$        SUMMATION OF KINETIC ENEGIES
         PARTN    ENERGWUP,,QSETDOF/KESP,KESQ,,/1 $           PARTITION
         TRNSP    TTTRRR/TTTRRRT $                     BUILD ROW VECTOR
         TRNSP    RRRTTT/RRRTTTT $                     BUILD ROW VECTOR
         MPYAD    TTTRRRT,KESP,/KESTRS $  SUM UP TRANSLATIONAL ENERGIES
         MPYAD    RRRTTTT,KESP,/KESROT $  SUM UP    ROTATIONAL ENERGIES
         MATPRN   KESTRS// $   PRINT THE SUMS OF TRANSLATIONAL ENERGIES
         MATPRN   KESROT// $   PRINT THE SUMS OF    ROTATIONAL ENERGIES 
$ mw
         if (nocol<>nulcol) then $
          merge    kessmq,,,,,qsetdof/kessm/1 $
         else $
          equivx   kessmq/kessm/always $
         endif $
         if(gotit=-1)then $
          MERGE    KESSM,,,,,qsetdof/KESSMM/1 $                  MERGE
         else $
          equivx kessm/kessmm/always $
         endif $ gotit=-1
$ mw
$  MATGPR GPLS,USET,SILS,kessmm//'H'/'G'//kefilter $FILTER ON ENERGY
   MATGPR GPLS,USET,SILS,ENRGNUPM//'H'/'G'//kefilter $FILTER ON ENERGY
$ mw
       else $
     message //' ' $
     message //' the following output - energwup - is the fraction'/
               ' of the total kinetic energy contained in the' $
     message //' current superelement - it does not include'/
               'any contributions of upstream masses' $
     message //' ' $
     message //' each column represents a mode. any dof which have'/
               ' more than 1% of the kinetic'/' energy are printed' $
     message //' ' $
          MATGPR GPLS,USET,SILS,ENERNOUP//'H'/'G'//kefilter $FILTER ON ENERGY
       endif $ nokeng<>-1
$
   ENDIF $ keprt>-1
  $
ENDIF $
RETURN $
END $
$ -------------------------------------------------------------------
$
COMPILE SEKDR $
$ALTER 57,57 $ replace IF(NOUP>=0) CALL SEMA1
alter 'IF ( NOUP>=0 ) CALL SEMA1,','IF ( NOUP>=0 ) CALL SEMA1,'
IF(NOUP>=0) CALL SEMA1,
            KDjj,MAPS,KDAA,bgpdtS,SLIST,EMAP,/
            KDGGX/
            SEID/ERROR/LUSETS/0/NOUP/0 $
$
$ Replacement for SEMA1 from MSC - allow for assembly GPWG
$
$ -------------------------------------------------------------------
COMPILE SEMA1 $ REPLACEMENT FOR SEMA1 SUBDMAP
$
SUBDMAP SEMA1  XJJ,MAPS,XAA,BGPDTS,SLIST,EMAP,GDNTAB/                           
               XGG/                                                             
               SEID/ERROR/LUSETS/UPFM/noup/massflg  $                                         
$                                                                               
TYPE DB XAAV,aagds $                                                                  
TYPE PARM,,CHAR8,N,SUBDMAP='SEMA1   '  $                                        
TYPE PARM,,I,N,LUSETS,UPFM,SEID,NP,ERROR,NP1,LPFLG,NPP,NQ1,NQ2 $                
TYPE PARM,NDDL,LOGI,N,GOPH2,SKIPSE $                                            
TYPE PARM,NDDL,I,N,PEID,SEDWN,DESITER,PVALID $                                  
$                                                                               
type db,cstms
type parm,nddl,rs,y,wtmass
type parm,,i,y,grdpnt
type parm,,i,n,mattyp=11
type parm,,i,n,noup,massflg
type parm,,i,n,temp
temp = seid $
dbview qsetdof=aagds, where(peid=temp and wildcard=true)
$
NQ1=DESITER $                                                                   
NQ2=PVALID $                                                                    
SEDWN=SEID $ SET QUALIFIER FOR SEP2DR AND EQUIVX XAAP                           
NP=SEID  $ CAPTURE CURRENT SEID                                                 
NPP=PEID $ CAPTURE CURRENT PEID                                                 
DBVIEW XAAP =  XAA  WHERE ( SEID=NP1 AND WILDCARD ) $                           
SEID=-1 $                                                                       
DO WHILE ( LPFLG>=0 ) $                                                         
   SEP2DR   SLIST,EMAP//S,N,SEID/S,N,PEID/SEDWN/S,N,LPFLG/                      
            /////S,N,SCNDRY/S,N,EXTRN//'SEDWN'//-2 $                            
   IF ( SEID>0 ) THEN $                                                         
      NP1=PEID $ JUST IN CASE IT IS AN IMAGE                                    
      IF ( EXTRN=-1 ) NP1=SEID $                                                
      EQUIVX   XAAP/XAAV/-1 $                                                   
   ENDIF $                                                                      
ENDDO $                                                                         
SEID=NP  $ RESTORE CURRENT SEID                                                 
PEID=NPP $ RESTORE CURRENT PEID                                                 
$                                                                               
DBVIEW XAAUP  = XAAV WHERE (SEDWN=NP AND WILDCARD) $                            
DBVIEW MAPUP  = MAPS WHERE (SEDWN=NP AND EXTERN='     ' AND                     
                            DESITER=NQ1 AND PVALID=NQ2 AND WILDCARD) $          
$                                                                               
$ NOTE THAT G SIZE WHEN DISCUSSING SUPERELEMENTS MEANS FOR EXAMPLE              
$ CONSIDERING ONLY PHYSICAL GRIDS 6 X (TOTAL NUMBER OF INTERIOR                 
$ GRIDS PLUS TOTAL NUMBER OF BOUNDARY GRIDS(EXTERIOR GRIDS))                    
$                                                                               
$ THIS CALL TO SEMA TAKES UPSTREAM BOUNDARY MATRICES XAAV EXPANDS               
$ THEM TO G SIZE AND ADDS IN CURRENT SUPERELEMENT                               
PARAML   XAAUP//'PRESENCE'////S,N,NOXAAUP $                                     
IF ( NOXAAUP>-1 OR UPFM=-1 ) THEN $                                             
   SEMA     BGPDTS,SLIST,EMAP,XJJ,XAAUP,MAPUP,GDNTAB/                           
            XGG/                                                                
            SEID/LUSETS/'SEID'/UPFM $                                           
   IF ( NOGO = -1 ) THEN $                                                      
      CALL ERRPH1 //SUBDMAP/0/ERROR/S,GOPH2 $ LOOPER                            
      RETURN $  CONTINUE TO NEXT SE ALTHOUGH                                    
   ENDIF $             ERROR FOUND IN CURRENT SE                                
ELSE $                                                                          
   EQUIVX  XJJ/XGG/ALWAYS $                                                     
ENDIF $ NOXAAUP>0                                                               
$ 
$ assembly mass calculation
$
IF (noup>0 and MASSFLG = 1 AND GRDPNT >=0) THEN $  GRD PT WEIGHT GENERATOR
$ remove any upstream Q-set dof for GPWG - 10/12/1992
    matmod qsetdof,,,,,/nullcol8,/12/s,n,nulcol/1 $
    paraml qsetdof//'TRAILER'/1/s,n,nocol $
    if (nocol<>nulcol) then $
     partn xgg,qsetdof,/xggtemp,,, $
     merge xggtemp,,,,qsetdof,/xggnew $
   else $
     equivx xgg/xggnew/always $
   endif $
   MESSAGE //'GRID POINT WEIGHT GENERATOR OUTPUT WITH UPSTREAMS'/
          ' - WEIGHT INLCUDING UPSTREAM SUPERELEMENTS' $
   MESSAGE //'  (NOTE: ANY MASS ATTACHED TO DOF WHICH ARE '/
             'CONSTRAINED IN UPSTREAM'/
             ' SUPERELEMENTS WILL NOT BE INCLUDED)' $
type db,scstm,sils$
VECPLOT   XGGNEW,BGPDTS,SCSTM,CSTMS,,,,SILS/OGPWG/
              GRDPNT//7////ALTSHAPE/WTMASS/SEID $
$   GPWG     BGPDTS,CSTMS,EQEXINS,XGGNEW,,/OGPWG/GRDPNT/WTMASS $
   OFP      OGPWG // $
ENDIF $ GRD PT WEIGHT GENERATOR
$
$$ remove qset dof from rigid-body vectors
$  if(massflg=2) then $ 
$    type parm,,i,n,gotit = 0 $
$    type parm,,i,n,nullts1=0
$    putsys(1,109)
$    CALL DBFETCH /RBG1,,,,/PEID/0/0/0/S,nullts1  $
$    $matprn qsetdof,rbg1// $
$    PARTN RBG1,,qsetdof/RBX,aa,ss,dd/1 $
$    PURGEX /RBG1,,,,/ALWAYS $
$    MERGE RBX,,,,,qsetdof/RBG1/1 $
$    nullts1=0 $
$    putsys(0,109)
$    $dbdict select(name,size,seid,peid,zuzr1,zuzr2,zname,vers) $
$  endif $  
$$
RETURN $                                                                        
END $ SEMA1                                                                     
$
$ -------------------------------------------------------------------
$
$ SUBDMAP QSETUP  - FINDS THE UPSTREAM QSET DOF
$
COMPILE QSETUP $ REPLACEMENT FOR SEMA1 SUBDMAP
SUBDMAP QSETUP   XJJ,XLAA,MAPS,XAA,EQEXINS,
                 SLIST,EMAP,USETB,gdntab/
             XGG/SEID/lusets $
$
$
$ created 10-12-1992 to allow assembly plotting without
$  scaling to component modal dof
$
TYPE PARM,,I,N,SEID $
DBVIEW XLAAUP = XLAA (WHERE SEID=* AND WILDCARD=TRUE) $
DBVIEW MAPUP  = MAPS (WHERE SEID=* AND WILDCARD=TRUE) $
$
TYPE PARM,,CHAR8,N,SUBDMAP='QSETUP  '  $
TYPE PARM,,I,N,LUSETS,UPFM $
$
$ THIS CALL TO SEMA TAKES UPSTREAM BOUNDARY MATRICES XLAA EXPANDS
$ THEM TO G SIZE TO INDICATE ALL QSET DOF USED
$
SEMA     EQEXINS,SLIST,EMAP,,XLAAUP,MAPUP,gdntab/XGG1/
          SEID/LUSETS/'SEID'/UPFM $ ERROR ONLY FOR NO KAAUP
$$
$$ find non-null column in XGG1 = upstream qset dof used
$$
$  type parm,,i,n,nullts=0 $
$  paraml xgg1//'presence'////s,n,noxgg $
$  if (noxgg > -1) then $
$  matmod xgg1,,,,,/qsett,/12/s,n,nullts/1 $
$  if (nullts>0) then $
$    paraml xgg1//'trailer'/2/s,n,ncol $
$    matgen ,/ones/6/ncol/0/ncol $
$    add ones,qsett/qsetdof//(-1.,0.) $
$    nullts = 0 $
$$    call dbstore qsetdof,,,,//seid/0/'DBALL'/s,nullts $
$  endif $
$  endif $
$$
return
END $
$ -------------------------------------------------------------------
compile ortho $
subdmap ortho resvec,mkaa,mmaa/resnew2/nloads/thres/itype $
$
$ Feb 16, 1993  ortho.dat
$
type parm,,rs,n,scfac $
type parm,,rs,y,thres=-1. $
type parm,,i,n,nloads $
type parm,,i,n,iload $
type parm,,i,n,nloads2 $
type parm,,i,n,itype $
file resnew2=save $
file resnew=append $
$
if(itype = 2) then
  copy mkaa/mmaajc/always
  message //' ' $
  message //' sweeping on stiffness matrix ' $
  message //' ' $
else
  copy mmaa/mmaajc/always
  message //' ' $
  message //' sweeping on mass matrix ' $
  message //' ' $
endif
    iload = 1 $
    nloads2 = nloads
    do while(iload < nloads) $
$
      matgen ,/cp1/6/nloads2/0/1 $
      purgex /resleft,,,,/always $
      partn resvec,cp1,/resleft,,rescol,/1 $
      smpyad rescol,mmaajc,rescol,,,/stt/3////1 $
      paraml stt//'dmi'/1/1/s,n,stt2
      purgex /stt,,,,/always $
      if (abs(stt2) > thres or iload = 1) then
        smpyad rescol,mmaajc,rescol,,,/mmass/3////1 $
        paraml mmass//'dmi'/1/1/s,n,mmass2
        if (mmass2<0.) then $                          ***
          if (mmass2<-.00001) then
            message //'Taking square root of a '
            'negative number in subdmap ortho' $
            message //'at column'/iload/' in DM - value set to 0.0' $
          endif $
          mmass2 = 0.
        endif $
        purgex /mmass,,,,/always $
        scfac =1. / sqrt(mmass2) $
        paramr //'complex'//scfac//s,n,scfac2 $
        purgex /rescol2,,,,/always $
        add rescol,/rescol2/scfac2 $
        smpyad rescol2,mmaajc,resleft,,,/respart/3////1 $
        mpyad rescol2,respart,/respart2 $
        purgex /resvec,,,,/always $
        add respart2,resleft/resvec/-1. $
$
        if(iload = 1 ) then $
          equivx rescol/resnew/always $
        else
          append rescol,/resnew/2 $
        endif
        message //iload/stt2/'            yes' $
       else
        message //iload/stt2/'            no' $
        purgex /resvec,,,,/always $
        copy resleft/resvec/always $
       endif
$
   iload = iload +1
   nloads2 = nloads2 - 1 $
   enddo
$
   smpyad resvec,mkaa,resvec,,,/stt/3////1 $ *** resleft to resvec 2/15
   paraml stt//'dmi'/1/1/s,n,stt2
   purgex /stt,,,,/always $
   if (abs(stt2) > thres) then
     message //iload/stt2/'            yes' $
     append resnew,resvec/resnew2 $ *** resleft to resvec 2/15
     purgex /resvec,,,,/always $
   else
     message //iload/stt2/'            no' $
     copy resnew/resnew2/always $
   endif
$
$ sweeping complete
$
return $
end alter$
echoon $