$
$     ddambma.v707 - 8-24-99
$
$     ddamnewa.v705
$
$     THIS ALTER IS CONFIDENTIAL AND A TRADE SECRET OF THE 
$     MSC.Software 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 MSC.Software CORPORATION.                                
$
$
$         ddama.v705  -- 3-23-98
$
echooff $
$    
$
$
$ DDAM ALTER - UPDATED FOR V70.5 - SOL 103
$
$ updated March, 1998
$
$ updated April, 1994
$
$ updated  Feb 2, 1994 for calculation of mass fractions
$ based on mass which is not at i/f
$
$  updated Sept, 1993
$    added data recovery loop to get past limit in DDRMM
$    controlled by PARAM,NCASES,x - where x = number of 
$    subcases to use for data recovery for the current 
$    superelement- default = 1 (NOTE: if NCASES>1, then
$    at least 'x' subcases must exist for the current 
$    superelement
$
$  updated December, 1992
$  includes Kinetic Energy and Effective weight
$
COMPILE IFPs $
$ALTER 103 $ after equivx on idmindx
$alter 'equivx.*idtindx\/dtindx' $ v68.2
alter 'idtindx.*dtindx'
type parm,,i,n,dummy = 0 $
CALL DBSTORE DMI,DMINDX,,,//0/0/'DBALL'/s,dummy $
$
COMPILE SEMODES $
alter 1
putsys(0,192)
$ALTER 121,121 $ replace CALL POSTREIG - pass output datablocks
alter 'call.*postreig','call.*postreig'
IF ( SESEF>-1 OR SCRSPEC>-1 ) CALL POSTREIG,
                      LAMA    ,CASECC  ,PCDB    ,EMAP    ,XYCDB   ,
                      PVTS    ,USET    ,PHG     ,PHA     ,KAA     ,
                              ,KJJ     ,GOt     ,GOq     ,GM      ,
                      USETD   ,MATPOOLS,EQDYN   ,TFPOOL  ,maa     ,
                      MKAA    ,BAA     ,K4AA    ,DIT     ,KFS     ,
                      CSTMS   ,MPTS    ,EQEXINS ,BGPDTS  ,PHQG    ,
                      EST     ,MR      ,GPLS    ,SILS    ,DYNAMICS,
                      SPECSEL ,GPSNTS  ,GDNTAB  ,MAPS    ,        ,
                              ,        ,        /
                              /
                      RSONLY  /NOUE    /LUSETD  $
$IF ( SESEF>-1 OR SCRSPEC>-1 ) CALL POSTREIG,
$        OLB,CASECC,PCDB,EMAP,XYCDB,PVTS,CASEDR,USET,PHG,PHA,
$        KAA,KLAA,KJJ,GOAT,GOAQ,GM,USETD,MATPOOL,EQDYN,TFPOOL,
$        MMAA,MKAA,BAA,K4AA,DIT,KFS,CSTMS,MPTS,EQEXINS,BGPDTS,
$        PHQG,EST,MR,GPLS,SILS,DYNAMICS,SPECSEL,XYCDBDR,
$         OPHG1,OPHQG1,OPHEF1,OPHES1/sumblok/
$        RSONLY/SESEF/SCRSPEC/NOUE/LUSETD/G/W3/W4/
$        LMODES/LFREQ/HFREQ/CLOSE/OPTION/NOUP/
$        SEID/PEID/MTEMP/LOAD/TEMPLD/DEFORM/
$        MPC/SPC/K2GG/M2GG/B2GG/P2G/DYRD/METH/MFLUID $
$
$ Calculation of RBG replaced with DMAP from ALTER_SOL103.V67
$ ------------------------------
$
compile phase1a $
alter 1
type parm,,i,n,mattyp = 0 $
type parm,,i,y,spcsum=-1,dummy $
TYPE PARM,,I,Y,(CHKSTIF=-1)
$alter 40 $
alter 'if.*(.*sema1.*).*then'
$
$ create qsetdof if this is superelement has upstreams
$
if (noup>0) call qsetup  KJJ,MAPS,,EQEXINS,bgpdts,
             SLIST,EMAP,,gdntab/
             doftemp/seid/lusets $
$
$ check KJJ
putsys(1,109)
CALL CHECK USET0,//MATTYP/SEID/SEID/noup $
putsys(0,109)
$
$ -------------------------------------------------------------------
COMPILE CHECK $
$
SUBDMAP CHECK USETB,INMAT//MATTYP/SEID/PEID/NOUP $
$
$  MATTYP = FLAG FOR MATRIX TYPE AND SET
$
$         0 = CALC. "RIGID" BODY MATRICES
$         1 = KGG
$         2 = KNN
$         3 = KAA
$         4 = MGG
$         5 = MNN
$         6 = MAA
$        11 = XGG1 from SEMA1 - KJJ+KAA only
$
$ ALTERS FOR SOLUTION 103 TO PERFORM STIFFNESS CHECKS
$      AND CALCULATE KINETIC ENERGY AND MODAL WEIGHT BY S.E.
$      BOTH WITH AND WITHOUT UPSTREAM COONTRIBUTIONS
$
$ 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 $
$  SET DEFAULTS
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=1.e-05) $ - DEFAULT
$
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 $
TYPE PARM,NDDL,CHAR8,N,APRCH,K2GG
TYPE PARM,,I,N,,FOUNDIT $
TYPE PARM,,I,N,ASIZE,GSIZE,noup $
$
TYPE DB,EQEXINS,SLIST,EMAP,BGPDTS,CSTMS $
TYPE DB,KGG,KAA,MGG,MAA $
TYPE DB,GPLS,SILS $
TYPE DB,USET,KLAA,MAPS $
$
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 $
  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 $
  endif $
endif $
paraml temp01//'presence'////s,n,nopar $
$
VECPLOT ,,BGPDTS,EQEXINS,CSTMS,,,,/RBTG1/GRDPNT//4 $
if (nopar<>-1) then $
$  fix for no upstream q-set - 10/8/1993
  matmod temp01,,,,,/nullcols,/12/s,n,nulcol/1 $
  if (nulcol<>-1) then $
    PARTN RBTG1,temp01,/RBX,,,/1 $
    PURGEX /RBTG1,,,,/ALWAYS $
    MERGE RBX,,,,temp01,/RBTG1/1 $
  endif $
endif $
 TRNSP RBTG1/RBG1/ $
 CALL DBSTORE RBG1,RBTG1,,,//SEID/0/'DBALL'/0 $
$ 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 $
  MPYAD KGG,RBG1,/REACG/ $
  MPYAD RBTG1,REACG,/CHKKGG/ $
$ CHECK IF CHECKTOL IS EXCEEDED
  DIAGONAL CHKKGG/DIAGKGG/'COLUMN' $
  MATMOD DIAGKGG,,,,,/BIGGEST,/7 $
  PARAML BIGGEST//'DMI'/1/1/S,N,TEST $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX KGG FOLLOW' $
  IF (TEST>CHECKTOL) THEN $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TEST/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHECKTOL $
    NORM  REACG/REACGNRM/ $
    MATPRN CHKKGG // $
    MATGPR GPLS,USETB,SILS,REACGNRM//'H'/'G'//1.-2 $
  ELSE $
    MESSAGE //'MATRIX KGG PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHECKTOL $
  ENDIF $
ENDIF $
$
$
$ CHECK KNN
$
IF (CHKSTIF>-1 AND MATTYP=2) THEN $
  $ CHECK KNN FOR CONSTRAINTS
  CALL DBFETCH /RBG1,,,,/SEID/0/0/0/S,FOUNDIT $
  UPARTN USETB,RBG1/RBN,,,/'G'/'N'/'M'/1 $
  TRNSP RBN/RBTN $
  MPYAD INMAT,RBN,/REACN/ $
  MPYAD RBTN,REACN,/CHKKNN/ $
$ CHECK IF CHECKTOL IS EXCEEDED
  DIAGONAL CHKKNN/DIAGKNN/'COLUMN' $
  MATMOD DIAGKNN,,,,,/BIGNEST,/7 $
  PARAML BIGNEST//'DMI'/1/1/S,N,TESTN $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX KNN FOLLOW' $
  IF (TESTN>CHECKTOL) THEN $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TESTN/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHECKTOL $
    NORM  REACN/REACNNRM/ $
    MATPRN CHKKNN // $
    MATGPR GPLS,USETB,SILS,REACNNRM//'H'/'N'//1.-2 $
  ELSE $
    MESSAGE //'MATRIX KNN PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHECKTOL $
  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' $
  MATMOD DIAGKAA,,,,,/BIGAEST,/7 $
  PARAML BIGAEST//'DMI'/1/1/S,N,TESTA $
  MESSAGE //' RESULTS OF RIGID BODY CHECKS OF MATRIX KAA FOLLOW' $
  IF (TESTA>CHECKTOL) THEN $
    NORM  REACA/REACANRM/ $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TESTA/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHECKTOL $
    MATPRN CHKKAA // $
    MATGPR GPLS,USETB,SILS,REACANRM//'H'/'A'//1.-2 $
  ELSE $
    MESSAGE //'MATRIX KAA PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHECKTOL $
  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,/WGHT/MASSWT $
  MESSAGE //'RESULTS OF CHECK OF MGG' $
  MATPRN WGHT// $
  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 $
  UPARTN USETB,RBG1/RBN,,,/'G'/'N'/'M'/1 $
  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 $
  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 //' RESULTS OF RIGID BODY CHECKS OF MATRIX XGG FOLLOW' $
  IF (TESTR>CHECKTOL) THEN $
    NORM  REACX/REACXNRM/ $
    MESSAGE //'LARGEST STRAIN ENERGY OF'/TESTR/' EXCEEDS'/
            ' PROVIDED LIMIT OF'/CHECKTOL $
    MATPRN CHKXGG // $
    MATGPR GPLS,USETB,SILS,REACXNRM//'H'/'G'//1.-2 $   WAS USETB
  ELSE $
    MESSAGE //'MATRIX XGG PASSED RIGID-BODY CHECKS. THE '/
              'STRAIN ENERGY IN EACH DIRECTION WAS LESS '/
              'THAN'/CHECKTOL $
  ENDIF $
ENDIF $
$
RETURN $
END $
$
$ SUBDMAP KEEFW - CALCULATE KE AND EFW IF REQUESTED
$
$ -------------------------------------------------------------------
COMPILE KEEFW $
$
SUBDMAP KEEFW UGVS1/TEST99/SEID/PEID $
$
$ SUBDMAP KEEFW - CALCULATE KE AND EFW IF REQUESTED
$
TYPE DB,EQEXINS,GPLS,SILS,USET,MGG,MJJ $
type db,bgpdts,cstms $ added for rbg if it doesn't exist
TYPE PARM,NDDL,I,N,SEID $
TYPE PARM,,I,N,(LUSETD) $
TYPE PARM,,I,Y,(KEPRT=-1,EFWGT=-1,KEEFW=1) $
TYPE PARM,,I,Y,dontqset=-1 $
TYPE PARM,NDDL,I,N,NOUP,PEID $
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 ese if ESE is in case control 11/18/1993
$
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 $
           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 $
           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
$
     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
       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' $'/
          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' $
          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)' $
          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 $
       MATPRN TOTENWUP// $
       message //'Summation of kinetic energy for the assembly' $
     message //'Only the translation terms are correct in the '/
              ' summation. The rotational terms are incorrect' $
       vecplot energwup,bgpdts,eqexins,cstms,,,,/ener/0/0/1/
              'enerwup' $
       MATGPR GPLS,USET,SILS,ENERGWUP//'H'/'G'//kefilter $FILTER ON ENERGY
     ENDIF
     $
  ENDIF $
  $
  $
  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
     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 //'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' $
          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' $
          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)' $
          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' $
     vecplot enernoup,bgpdts,eqexins,cstms,,,,/energg/0/0/1/
             'enernoup' $
     MATGPR GPLS,USET,SILS,ENERNOUP//'H'/'G'//kefilter $FILTER ON ENERGY
   ENDIF $
  $
ENDIF $
RETURN $
END $
$
$ SUBDMAP QSETUP  - FINDS THE UPSTREAM QSET DOF
$
COMPILE QSETUP $ REPLACEMENT FOR SEMA1 SUBDMAP
SUBDMAP QSETUP   XJJ,MAPS,XAA,EQEXINS,bgpdts,
                 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     BGPDTS,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 MODERS $
$alter 7,12 $ was 8,13 $ was 7,13
$alter 'if.*(.*readapp=\'buck','else.*\$.*readapp=\'buck'
alter 2
type parm,,i,n,nsub1=-1
$alter 63,104 $ was 46,83
$alter 'equivx.*mkaa\/kxx\/noared','endif.*\$.*lanczos.*\>.*-1' $ V70
$alter 'equivx.*mkaa\/kxx\/noared','if.*nasout.*ofp.*lama'(,-1) $ V70
$
$        STEP 1 IN PROCEDURE INCLUDES-
$
$                (1) CALCULATION OF BASE FIXED MODES WHERE
$                    R-SET SUPPORTS DEFINE THE FOUNDATION
$
$                (2) PREPARATION OF MATRIX DATA FOR DDAM
$                    ENVIRONMENT DETERMINATION
$
$                (3) DISPLAY OF DATA TO ASSESS COMPLIANCE
$                    OF MODAL DATA WITH DDAM COMPLETENESS
$                    CRITERIA
$
$$EQUIV    MKAA,KXX/NOARED/MMAA,MXX/NOARED/DMLQ,DMX/NOARED/
$EQUIV    MKAA,KXX/NOARED/MMAA,MXX/NOARED/DM,DMX/NOARED/
$         VACMPR,VXCOMPR/NOARED $
$COND     LBLNORED,NOARED $
$PRTPARM  //4415/'DMAP' $
$MATGPR   GPLS,USET,SILS,VAXW//'H'/'A' $
$IF ( ASING = -1 ) CALL ERRPH2 //SUBDMAP/0 $
$$COND     RFERR,ASING $
$PARTN    MMAA,VAXW,/MXX,,,/-1 $
$PARTN    MKAA,VAXW,/KXXBAR,KWX,,KWW1/-1 $
$EQUIV    KXXBAR,KXX/INVPOW $
$COND     KINV2,INVPOW $
$$PARAML   KWX//'NULL'////S,N,NOAOMIT $
$EQUIV    KXXBAR,KXX/NOAOMIT $
$COND     KINV2,NOAOMIT $
$DECOMP   KWW1/LWW1,/1////////58 $
$FBS      LWW1,,KWX/GWX1/1/-1/0/0 $
$MPYAD    GWX1,KWX,KXXBAR/KXX/1////6 $
$LABEL    KINV2 $
$COND     LBLNORED,NORSET $
$PARTN    VACMPR,,VAXW/VXCOMPR,,,/1 $
$VEC      USET/VACMPR/'A'/'COMP'/'R' $
$PARTN    VAXW,,VACMPR/VLQXW,,,/1 $
$PARTN    DMLQ,,VLQXW/DMX,,,/1 $
$LABEL    LBLNORED $
$TYPE PARM,,I,N,NEIGV=-1 $
$SETVAL   //S,NEIGV/-1 $
$$
$$        WE NOW PARTITION THE MXX AND KXX MATRICES INTO
$$        L-SET AND R-SET COMPONENTS. (NOTE: THE "X" SET
$$        IS SIMPLY THE A-SET WITH NULL ROWS AND COLUMNS
$$        OF KAA AND MAA CONSTRAINED OUT).
$$        "1" REPRESENTS THE DOFS FREE TO VIBRATE
$$        "2" REPRESENTS THE FOUNDATION DOFS
$$
$PARTN    MXX,VXCOMPR,/M11,,M12,M22/-1 $ ***2/2/94
$PARTN    KXX,VXCOMPR,/K11,,K12,K22/-1 $
$$
$$ GENERATE RIGID BODY VECTORS AND
$$ PERFORM RIGID BODY CHECK
$$
$RBMG2 K11/L11, $
$RBMG3 L11,,K12,K22/PHBS1 $
$RBMG4    DM,M11,M12,/MELAS $ available elastic mass ***2/2/94
copy mr/melas $
CALL DBSTORE MELAS,,,,//0/0/'DBALL'/0 $ ***2/2/94
PURGEX /MELAS,,,,/ALWAYS $ ***2/2/94
$
$ check if Lanczos or SINV - current alter does not work otherwise
$
alter 'matmod.*cases.*dynamics' $
$
if(methtyp=0)then $
 message //'        D M A P  FATAL  M E S S A G E ' $
 message //'USER HAS REQUESTED GIVENS OR HOUSEHOLDERS METHOD' $
 message //' THE CURRENT VERSION OF THE ALTER WILL ONLY WORK' $
 message //' IF YOU SELECT LANCZOS OR SINV' $
EXIT $
endif $
$
alter 'read.*kxx.*mxx',''   $
$
$ remove R-set before eigensolution for fixed-boundary modes
$
upartn uset,kxx/kll,,,/'A'/'L'/'R' $
upartn uset,mxx/mll,,,/'A'/'l'/'r' $
READ   Kll,Mll,,,EED,USET,CASES,VAXF,SILS,,,,EQEXINS/
       LAMA,PHIl,MIX,OEIGS,EIGVMAT,/
       READAPP/S,N,NEIGV/NSKIP/SECND $
$
umerge uset,phil,/phix/'A'/'L'/'R' $
$
$
$COND     LANCEIG,LANCZOS $ CHECK ON EIGENVALUE SOLUTION
$$
$READ     K11,M11,,,EED,,CASES/LAMA,PHI1,M1,OEIGS/'MODES'/
$         S,N,NEIGV $
$JUMP     LLREAD $
$LABEL    LANCEIG
$$
$$ LANCZOS METHOD
$$
$REIGL    K11,M11,DYNAMICS,CASES,,,,uset,eqexins,sils/
$         LAMA,PHI1,M1,EIGVMAT,/'MODES'/
$         S,N,NEIGV $
$LABEL    LLREAD $
$
$ EIGENSOLUTION DONE
$
$MATGEN   ,/PHBS2/1/NORSET/ $
$MERGE    PHBS1,PHBS2,,,,VXCOMPR/PHBASE/1 $
$MERGE    PHI1,,,,,VXCOMPR/PHIX/1 $
$
$        PHIX IS THE BASE-FIXED SET OF MODAL VECTORS
$        PHBASE IS THE SET OF RIGID BODY VECTORS (X-SET)
$
equivx dar/phbase/always $
SMPYAD   PHIX,MXX,PHBASE,,,/PAB/3/1///1/ $
SMPYAD   PHIl,Kll,PHIl,,,/OMEG2/3/1///1/ $
DIAGONAL OMEG2/OMEGX/'COLUMN'/0.5 $
SMPYAD   PHBASE,MXX,PHBASE,,,/MTOTC/3/1///1/ $
DIAGONAL MTOTC/MTOT/'COLUMN'/1.0 $
MPYAD    PAB,PAB,/MEFFC/1 $
DIAGONAL MEFFC/MEFF/'COLUMN'/1.0 $
MATPRN   MTOTC,MEFFC,PHBASE// $
TYPE PARM,,I,N,FOUNDIT $ ***2/2/94
CALL DBFETCH /MELAS,,,,/0/0/0/0/S,FOUNDIT $  ***2/2/94
IF (FOUNDIT=-1) THEN $ ***2/2/94
$  RESIDUAL STRUCTURE - HAVE ELASTIC MASS AVAILABLE
  DIAGONAL MELAS/MELASD/'COLUMN'/1.0 $
  ADD      MEFF,MELASD/MFRACTE///2 $
  MESSAGE //'MFRACTE IS  THE FRACTION OF THE AVAILABLE MASS'/
            ' WHICH CAN BE REPRESENTED BY THE MODES' $ ***/2/2/94
  MATPRN  MFRACTE// $ ***2/2/94
ENDIF $ ***2/2/94
ADD      MEFF,MTOT/MFRACT///2 $
MATPRN   OMEGX,PAB,MTOT,MEFF,MFRACT// $
PARAM    //'NOP'/S,Y,CHKMEF=1 $
COND     MEFCHK,CHKMEF $
$OUTPUT4  OMEGX,PAB,,,//-1/V,Y,IUNIT=11 $
$OUTPUT4  ,,,,//-2/V,Y,IUNIT $
OUTPUT4  OMEGX,PAB,MTOT,MFRACT,//-1/V,Y,IUNIT=11 $
LABEL    MEFCHK $
$
$        THE FOLLOWING MATRIX QUANTITIES ARE CALCULATED AND OUTPUT
$        FOR USER INTERPRETATION:
$
$        (1) PAB    - MODAL PARTICIPATION FACTORS
$        (2) OMEGX  - MODAL FREQS (RAD/SEC)
$        (3) MTOTC  - TOTAL RIGID BODY MASS MATRIX
$        (4) MEFFC  - TOTAL MODAL EFFECTIVE MASS MATRIX
$        (5) MTOT   - DIAGONAL TERMS OF MTOTC
$        (6) MEFF   - DIAGONAL TERMS OF MEFFC
$        (7) MFRACT - FRACTION OF TOTAL MASS REPRESENTED
$                     BY THE TRUNCATED MODE SET
$        (8) PHBASE - RIGID BODY VECTOR SET REF. TO R-SET
$
$
$        END OF DDAM STEP (1) DMAP
$
$
$        STEP (2) IN THE PROCEDURE INCLUDES:
$
$        (1) INPUT OF MODAL SHOCK RESPONSES CALCULATED IN "NAVSHOK"
$
$        (2) CALCULATION OF DDAM PEAK RESPONSES AND LOADS
$            FOR X-,Y-,AND Z-DIRECTED INPUT SHOCKS.
$
$        (3) ADDITIONAL DIAGNOSTIC OUTPUT FOR ENGINEERING EVALUATION
$            OF RESPONSES AND LOADS
$
$
compile super3 $
$alter 213 $ 204 $174 $ before call sedrcvr
alter 'if.*(.*statics.*or.*app=\'reig\'.*or.*app=\'nlst\''
call keefw ug/unused/seid/peid $
$
COMPILE SEDRCVR $
$ALTER 37 $ 38 $ V67 - AFTER SDR1 - SYSTEM K.E.
$alter 'vecplot.*qgsum'
$ALTER 42,42 $ REMOVE IF (SCRSPEC>-1) RETURN
alter 'if.*(.*scrspec\>-1.*).*return','if.*(.*scrspec\>-1.*).*return' $
$
TYPE DB,MGG,MJJ $
TYPE PARM,,RS,N,MW $
TYPE PARM,,CS,N,MASSWT $
TYPE PARM,NDDL,RS,Y,WTMASS $
 MW = 1./WTMASS $
 MASSWT = CMPLX(MW,0.0) $
$PARAMR   //'DIV'/S,N,MW/1.0/V,Y,WTMASS=1.0 $
$PARAMR   //'COMPLEX'//V,N,MW/0.0/S,N,MASSWT $
TYPE PARM,,I,N,PARTDMI=0 $ **********
TYPE PARM,,I,Y,KEPRT=1,ACCNPRT=-1,NODISPP=-1 $
TYPE PARM,,I,Y,EFWGT=1,KEEFM=1 $
$
$ALTER 219 $198
alter 'OUGV1,OPG1,OQG1,OEF1X,OSTR1'(,-1)
IF (SCRSPEC>-1) RETURN $
$
COMPILE POSTREIG $
ALTER 1,1
SUBDMAP POSTREIG  LAMA    ,CASECC  ,PCDB    ,EMAP    ,XYCDB   ,
         PVTS    ,USET    ,PHG     ,PHA     ,KAA     ,
         unused1 ,KJJ     ,GOt     ,GOq     ,GM      ,
         USETD   ,MATPOOL ,EQDYN   ,TFPOOL  ,mmaa    ,
         MKAA    ,BAA     ,K4AA    ,DIT     ,KFS     ,
         CSTMS   ,MPTS    ,EQEXINS ,BGPDTS  ,PHQG    ,
         EST     ,MR      ,GPLS    ,SILS    ,DYNAMICS,
         SPECSEL ,GPSNTS  ,GDNTAB  ,MAPS    ,ougv1   ,
         oqg1    ,oef1    ,oes1    /
                 /
         RSONLY  /NOUE    /LUSETD $
$
$SUBDMAP POSTREIG  OLB,CASECC,PCDB,EMAP,XYCDB,PVTS,CASEDR,USET,PHG,PHA,
$            KAA,KLAA,KJJ,GOAT,GOAQ,GM,USETD,MATPOOL,EQDYN,TFPOOL,
$            MMAA,MKAA,BAA,K4AA,DIT,KFS,CSTMS,MPTS,EQEXINS,BGPDTS,
$            PHQG,EST,MR,GPLS,SILS,DYNAMICS,SPECSEL,XYCDBDR,
$                  OUGV1,OQG1,OEF1,OES1/sumout/
$            RSONLY/SESEF/SCRSPEC/NOUE/LUSETD/G/W3/W4/
$            LMODES/LFREQ/HFREQ/CLOSE/OPTION/NOUP/
$            SEID/PEID/MTEMP/LOAD/TEMPLD/DEFORM/
$            MPC/SPC/K2GG/M2GG/B2GG/P2G/DYRD/METH/MFLUID $
TYPE DB,MPT $
TYPE PARM,,CHAR8,n,APP1='REIG' $
TYPE PARM,,I,Y,ACCNPRT=-1,NODISPP=-1 $
type parm,,i,y,ncases=1 $ counter on subcases for data recovery
type parm,,i,n,icase = 1 $
FILE UGVS=OVRWRT $
copy lama/lama1 $
$
$alter 25 $24
$alter 'if.*(.*noa\>-1.*).*upartn.*phils'
alter 'sedr.*emap.*casecc'
if (seid<>0) then $
  equivx lama1/olb1/always $
  equivx phils/phils1/always $
endif $
$
$ALTER 49,49 $ V67
alter 'if.*(.*seid=0.*scrspec\>-1.*)','if.*(.*seid=0.*scrspec\>-1.*)'
$      'if.*(.*seid=0.*and.scrspec\>-1.*).*then'
IF (SCRSPEC>-1) THEN $
$
$dbdict select=(name,version,size,seid,peid,sedwn,load,spc,mpc,meth)$
alter 'call segoa'
if(seid=0)then $
$
$alter 60,60
alter 'modacc.*olb1.*phils1.*reig'
else $
  equivx goa/god/always $
  equivx gm/gmd/always $
  equivx k4aa/k4dd/always $
endif $
$ALTER  64,100 $
$
alter 'sdr1.*phigh.*qgh.*reig'(,-2)
if(seid=0)then $
alter 'sdr1.*phigh.*qgh.*reig'(,-1)
else $
 equivx phidh/phils1h/always $
endif $
$
alter 'sdr1.*phigh.*qgh.*reig','sdr1.*phigh.*qgh.*reig'    
$
if(seid=0)then $
SDR1     USETD,,PHILS1H,,,GOA,GM,,KFS,,/
                                      PHIGH,,QGH/
                                      1/'REIG' $
else $
SDR1     USET,,PHILS1H,,,GOA,GM,,KFS,,/
                                      PHIGH,,QGH/
                                      1/'REIG' $
endif $
$
alter 'sdr1.*phigh.*qgh.*reig'(,2),'endif.*end.*scaled.*response'
$matprn phils1h,goa,gm,kfs,phigh// $
ofp iqg1,iphig1,ies1,ief1// $
FILE OUPV1=OVRWRT/OQGP1=OVRWRT/DOES1=OVRWRT/DOEF1=OVRWRT
$
$  CHECK IF PARTNVEC EXISTS
$
JUMP     DUMMY1 $
$ INSERT EQUIV AND REMOVE DBFETCH TO FOOL COMPILER
EQUIV    OUGV1,PARTNVEC/ALWAYS $
$DBFETCH  /PARTNVEC,,,,/SOLID/0/0/DBSET2 $
LABEL    DUMMY1 $
$FILE     PARTNVEC=SAVE/PARTN2=APPEND $
FILE     PARTNVEC=SAVE $
TYPE PARM,,I,N,PARTDMI=0 $ **********
IF (PARTDMI=0)THEN $ *********
   TYPE PARM,,I,N,GARBAGE $
   CALL DBFETCH /DMI,DMINDX,,,/0/0/0/0/S,GARBAGE $
   DMIIN  DMI,DMINDX/PARTNVEC,,,,,,,,,/ $ **********
   CALL DBSTORE PARTNVEC,,,,//0/0/'DBALL'/0 $
   PARTDMI=1 $
ENDIF $
PARAML   PARTNVEC//'PRESENCE'////S,N,EXISTS $ CHECK FOR PARTITIONING VECTOR
$
PVT      PVTS,CASEDR// $
$
$        UHVX,UHVY, AND UHVZ ARE MATRICES DIMENSIONED SUCH
$        THAT THERE ARE 3 COLUMNS IN EACH. COLUMN 1 HAS THE
$        PEAK MODAL DISPL'S, COLUMN 2 HAS THE PEAK MODAL
$        VEL'S, AND COLUMN 3 HAS THE PEAK MODAL ACCEL'S.
$
COND     NOACCN,ACCNPRT $
if(seid=0)then $
  SDR1 USETD,,PHILS1H,,,GOA,GM,,KFS,,/PHIDH1,,UGVS/1/'REIGS' $
else $
  SDR1 USET,,PHILS1H,,,GOA,GM,,KFS,,/PHIDH1,,UGVS/1/'REIGS' $
endif $
NORM     UGVS/ACCN/ $
MATMOD   ACCN,,,,,/ACCG,/2////V,Y,ACCMIN=0.1 $
SDR2     CASEDR,CSTMS,MPT,DIT,EQEXINS,,,OLB1,BGPDTS,,,ACCG,
         EST,XYCDBDR,,,,/,,OUACCG,,,/APP1/S,N,NOSORT2/
         NOCOMPS $
OFP      OUACCG//S,N,CARDNO $
LABEL    NOACCN $
$
$ CHECK IF CURRENT S.E. IS R.S.
$
IF (SEID = 0) THEN $
$
$  READ AND STORE RESULTS OF NAVSHOK
$
$ ---------------------------------------------------
$ temporarily read inputt4 ascii
INPUTT4  /UHVX2,UHVY2,UHVZ2,,/3/13/-3 $
$inputt4 /uhvx2,uhvy2,uhvz2,,/3/13/-3/0 $
$  INPUTT4  /UHVX2,UHVY2,UHVZ2,,/3/12/-3 $ **********
  CALL DBSTORE UHVX2,UHVY2,UHVZ2,,//0/0/'DBALL'/0 $
$  LABEL    NOIN4 $
ENDIF $
$TYPE PARM,,I,N,GARBAGE $
purgex /uhvx2,uhvy2,uhvz2,partnvec,/always $
CALL DBFETCH /UHVX2,UHVY2,UHVZ2,PARTNVEC,/0/0/0/0/S,GARBAGE $
$
$        OPERATIONS ON X- DIRECTED SHOCK RESPONSE
$
$ ********* START
$
$ added sept, 1993 for multiple data recovery subcases
type parm,,i,n,repeatit=1, noloop $
repeatit=1 $
DO WHILE (repeatit <> -1 ) $
message //'seid ='/seid/'repeatit='/repeatit/'noloop ='/noloop $
  CASE     CASEDR,/CASERS/'TRAN'/S,N,repeatit/S,N,NOLOOP $
  PVT      PVTS,CASErs// $
$
$
PARAML   PARTNVEC//'PRESENCE'////S,N,EXISTS $ CHECK FOR PARTITIONING VECTOR
COND     STRTLOOP,EXISTS $ SKIP TO STRTLOOP IF NO PARTNVEC
$
$ ADD LOOPING BASED ON PARTNVEC
$
PARAM    //'ADD'/S,N,LCOUNT/0/0 $ INITIALIZE COUNTER TO 0
PARAML   PARTNVEC//'TRAILER'/1/S,N,NCOLP $ NO OF COL IN PARTNVEC
$
LABEL    STRTLOOP $
purgex /uhvx2,uhvy2,uhvz2,partnvec,/always $
CALL DBFETCH /UHVX2,UHVY2,UHVZ2,PARTNVEC,/0/0/0/0/S,GARBAGE $
$
IF (EXISTS<>-1) THEN $
  PARAM    //'ADD'/S,N,LCOUNT/V,N,LCOUNT/1 $  INCREMENT COUNTER
  PARAM    //'SUB'/S,N,GIVEUP/NCOLP/LCOUNT $  GIVEUP=NROWL-LCOUNT
  COND     ALLDON,GIVEUP $ IF GIVEUP<0 THEN QUIT
$
$ GRAB CURRENT COLUMN OF PARTNVEC
$
  MATMOD   PARTNVEC,,,,,/PARTNV1,/1/LCOUNT $ GET COLUMN OF PARTNVEC
$ EXPAND TO 3 IDENTICAL COLUMNS
  APPEND   PARTNV1,PARTNV1/PARTN2/1 $
$  APPEND   PARTNV1,/PARTN2/2 $
  APPEND   partn2,PARTNV1/PARTN3/1 $
  MATPRN   UHVX2,PARTN3// $
$
  ADD      PARTN3,UHVX2/UHVXX///1 $ SCALE UHVX BY PARTN3
  EQUIV    UHVXX,UHVX3/ALWAYS $
$
ELSE $
$
  EQUIV    UHVX2,UHVX3/ALWAYS $
ENDIF $
$
MATPRN   UHVX3// $
DDRMM    CASErs,UHVX3,,iphig1,iQG1,iES1,iEF1,/OUPV1,OQP1,
$         DOES1,DOEF1,/V,Y,OPT='NRL' $
         DOES1,DOEF1,/V,Y,OPTION='NRL' $
OFP      OUPV1,OQP1,DOEF1,DOES1,,//S,N,CARDNO $
$
MATMOD   OUPV1,,,,,/OUGV1,/13 $
MATMOD   OQP1,,,,,/OQG1,/13 $
MATMOD   DOEF1,,,,,/OEF1,/13 $
MATMOD   DOES1,,,,,/OES1,/13 $
OUTPUT2  OUGV1,OQG1,OES1,OEF1,//0/21/ $
DELETE   /OUGV1,OQG1,OES1,OEF1 $
$
COND     NODISPX,NODISPP $
MATMOD   UHVX3,,,,,/UHVX1,/1/1 $
TRNSP    UHVX1/UHVXT $
MPYAD    UHVX1,UHVXT,/UH2/ $
DIAGONAL UH2/UHVX1A/'SQUARE'/0.5 $
if(seid=0)then $
SDR1     USETD,,PHILS1H,,,GOA,GM,,KFS,,/PHIDH2,,UGVS/1/'REIGS' $
else $
SDR1     USET,,PHILS1H,,,GOA,GM,,KFS,,/PHIDH2,,UGVS/1/'REIGS' $
endif $
MPYAD    UGVS,UHVX1A,/DISPX/ $
SDR2     CASErs,CSTMS,MPT,DIT,EQEXINS,,,OLB1,BGPDTS,,,DISPX,
         EST,XYCDBDR,,,,/,,OUDISPX,,,/APP1/S,N,NOSORT2/
         NOCOMPS $
OFP      OUDISPX//S,N,CARDNO $
LABEL    NODISPX $
$
$
$        OPERATIONS ON Y- DIRECTED SHOCK RESPONSE
$
$ *********
COND     NOPARTNY,EXISTS $ SKIP PARTITIONING IF NO PARTNVEC
MATPRN   UHVY2,PARTN3// $
ADD      PARTN3,UHVY2/UHVYY///1 $ SCALE UHVY BY PARTN3
EQUIV    UHVYY,UHVY3/ALWAYS $
JUMP     NOYP2 $ **********
LABEL    NOPARTNY $
EQUIV    UHVY2,UHVY3/ALWAYS $ **********
LABEL    NOYP2 $ **********
$ *********
MATPRN   UHVY3// $
$ ADD DBFETCH FOR SAFETY
DDRMM    CASErs,UHVY3,,iphig1,iQG1,iES1,iEF1,/OUPV1,OQP1,
$         DOES1,DOEF1,/OPT $
         DOES1,DOEF1,/OPTION $
OFP      OUPV1,OQP1,DOEF1,DOES1,,//S,N,CARDNO $
$
MATMOD   OUPV1,,,,,/OUGV1,/13 $
MATMOD   OQP1,,,,,/OQG1,/13 $
MATMOD   DOEF1,,,,,/OEF1,/13 $
MATMOD   DOES1,,,,,/OES1,/13 $
OUTPUT2  OUGV1,OQG1,OES1,OEF1,//0/22/ $
DELETE   /OUGV1,OQG1,OES1,OEF1 $
$
COND     NODISPY,NODISPP $
MATMOD   UHVY3,,,,,/UHVY1,/1/1 $
TRNSP    UHVY1/UHVYT $
MPYAD    UHVY1,UHVYT,/UHY2/ $
DIAGONAL UHY2/UHVY1A/'SQUARE'/0.5 $
MPYAD    UGVS,UHVY1A,/DISPY/ $
SDR2     CASErs,CSTMS,MPT,DIT,EQEXINS,,,OLB1,BGPDTS,,,DISPY,
         EST,XYCDBDR,,,,/,,OUDISPY,,,/APP1/S,N,NOSORT2/
         NOCOMPS $
OFP      OUDISPY//S,N,CARDNO $
LABEL    NODISPY $
$
$
$        OPERATIONS ON Z- DIRECTED SHOCK RESPONSE
$
$ *********
COND     NOPARTNZ,EXISTS $ SKIP PARTITIONING IF NO PARTNVEC
MATPRN   UHVZ2,PARTN3// $
ADD      PARTN3,UHVZ2/UHVZZ///1 $ SCALE UHVZ BY PARTN3
EQUIV    UHVZZ,UHVZ3/ALWAYS $
JUMP     NOZP2 $ **********
LABEL    NOPARTNZ $
EQUIV    UHVZ2,UHVZ3/ALWAYS $ **********
LABEL    NOZP2 $ **********
$ *********
MATPRN   UHVZ3// $
$ ADD DBFETCH FOR SAFETY
DDRMM    CASErs,UHVZ3,,iphig1,iQG1,iES1,iEF1,/OUPV1,OQP1,
$         DOES1,DOEF1,/OPT $
         DOES1,DOEF1,/OPTION $ 
OFP      OUPV1,OQP1,DOEF1,DOES1,,//S,N,CARDNO $
$
MATMOD   OUPV1,,,,,/OUGV1,/13 $
MATMOD   OQP1,,,,,/OQG1,/13 $
MATMOD   DOEF1,,,,,/OEF1,/13 $
MATMOD   DOES1,,,,,/OES1,/13 $
OUTPUT2  OUGV1,OQG1,OES1,OEF1,//0/23/ $
DELETE   /OUGV1,OQG1,OES1,OEF1 $
$
COND     NODISPZ,NODISPP $
MATMOD   UHVZ3,,,,,/UHVZ1,/1/1 $
TRNSP    UHVZ1/UHVZT $
MPYAD    UHVZ1,UHVZT,/UH3/ $
DIAGONAL UH3/UHVZ1A/'SQUARE'/0.5 $
MPYAD    UGVS,UHVZ1A,/DISPZ/ $
SDR2     CASErs,CSTMS,MPT,DIT,EQEXINS,,,OLB1,BGPDTS,,,DISPZ,
         EST,XYCDBDR,,,,/,,OUDISPZ,,,/APP1/S,N,NOSORT2/
         NOCOMPS $
OFP      OUDISPZ//S,N,CARDNO $
LABEL    NODISPZ $
$
$  CHECK FOR LOOPING BASED ON PARTNVEC
$
COND     ALLDON,EXISTS $  QUIT IF PARTNVEC DOESN'T EXIST
REPT     STRTLOOP,100 $  REPEAT PARTITIONING LOOP FOR DATA RECOVERY
LABEL    ALLDON $
$
$ end of case control loop added Sept, 1993
$
enddo $
$
$JUMP LNOEDR $
ENDIF $ SCRSPEC>-1
endalter
echoon $
$