$ file rflaga.v707
$ for Version 70.7, field version.  First release:10/22/99 10:09 AM
$ last revised:   October 25, 1999
$ breadboard.  experimental enforced motion.
$ Only sol 108 supported at present.  
$ errors fixed in last revision:
$ incorrect epsilon calculation when strucutural damping present
$ input for velocity or acceleration input was ignored, treated as disp. input
$ new capabilities:
$ fluid-structure analysis checked out
$ suport entry now allowed 
echooff $ 
$ capabilities in development
$ direct transient analysis

$ file disprsb.alt
compile disprs nolist noref $
$       $       $       $       $       $       $       $      disprsb
alter 1 $ 
type parm,,char4,y,debug='no' $
type parm,,i,n,no1set,nopset $
if (debug='yes') then $
  message //'inputs to disprsb' $
  matprn ,UHF,UDF,PPF,USETD,RPH// $
  matprn rpd,PHDH,CK2DD,CB2DD,CMDD// $
  matprn RGM,MMG1,BMG1,KMG1,QMGF// $
  matprn RGS,MSF1,BSF1,KSF1,QSGF// $
endif $
paraml usetd//'USET'//////'be'/S,N,NOBESET/
     'p'/s,n,nopset $
alter 'EQUIVX   PPF0/PGF0/NOUE','UPARTN   USETD,PPF0/PGF0' $
equivx ppf0/pgf0/always $
alter 'EQUIVX   RPH/UPx/-1','' $
if (nobeset>-1) then $
  call decat rph/upx,,,/0/nobeset $ discard null columns at the end
  call decat uhf1/uhf1x,,,/nobeset/0 $ discard qb variables at bottom
  equivx uhf1x/uhf1/always $
else $
  equivx rph/upx/-1 $
endif $
alter 'IF ( MODACC>-1 ) THEN'
if (nobeset>-1 ) then $
  message //'user fatal message.  mode acceleration method blocked '/
     'at present.  remove param, modacc.' $
  exit $
endif $
$alter 'EQUIVX   UPX/UPF/NOUE','UPARTN   USETD,UPX/UPF' $
$equivx upx/upf/always $
$alter 'UPARTN   USETD,UPF1/UFF','' $
$  equivx upx/uff/always $
$alter 'CALL CFORCE2  USET,RGM,UPF1','' $ replace upf with upx
$CALL CFORCE2  USETd,RGM,UPx,MMG1,BMG1,KMG1,PGF1,FOL1,QMGF/
$     QMPF/APP/APP1/TRUE/SEID $
$  end of disprs alter
 
$ file fdrmgenb.txt
Compile fdrmgen nolist noref $
Alter 18 $
Paraml uset//'uset'//////'be'/s,n,nobeset $
DOSPCF = ( (NOSSET>-1 or nobeset>-1) AND                                                        
 ( ORL(SPCFOR,GPFOR) OR                                               
 SAVERST='SEDR'    OR                                               
 ((APP='TRANRESP' OR APP='FREQRESP') AND DESSPCF) ) ) $ 
dospcffd = (dospcf and nobeset>-1) $ be-spcf now made in freqdep loop
alter 67,71 $ avoid generation of inn for efficiency 
IF ((NOSSET>-1) AND DOSPCF AND NORGS>-1 ) THEN $  FOR SPCFORCES  
  matgen ,/iss/1/s,n,nosset $
  umerge1 uset,iss,,,/rns/'n'/'s'//1 $
  if (nomset>-1) then $
    upartn uset,gm0/gms,,,/'n'/'s'//2 $
    umerge1 uset gms,rns,,/rgs/'g'/'m'/'n'/1 $
  else $
    equivx rns/rgs/always $
  endif $
alter 81,81 $           
DOSPCFFD=(NLRSGG>-1 or nobeset>-1) $                                                    
$ end of fdrmgen alter

compile ifpl nolist noref $
$       $       $       $       $       $       $       $       $ ifpl
alter 'CALL IFPS  CASEXX' $
call dbstore dti,dtindx,dit,,//0/0/'     '/0 $ dit needed by gkams
alter 'ENDIF $ NOT(NOGOIFP' 
call dbstore matpool,,,,//0/0/'     '/0 $
compile mpf nolist noref $ 	$	$	$	$	$	mpf
alter 1 $
message //'user information message.  fluid pressure output'/
     '/ blocked at present.' $
return $

$ file sedispb.txt
compile sedisp souin=mscsou nolist noref $
$       $       $       $       $       $       $       $       sedispb
alter 14 $ after type statements
paraml uset//'uset'//////'be'/s,n,nobeset $
alter 'spcforces are computed here',''(,2) $
if (app1='mmreig' and nobeset>-1) then $
  call decat ug/ug1,,,/0/nobeset $ remove the constraint modes
  call decat uh1/uh2,,,/nobeset/0 $ remove the be-set motion
else $
  equivx ug/ug1/always $
  equivx uh1/uh2/always $
endif $ 
if ( noqg>-1 and newspcf and nosset>-1 ) then $
     upartn   uset,ug1/uf,,,/'g'/'f'/'s'/1 $
     call cforce  uset,,uf,uh2,msf,m2sf,bsf,b2sf,ksf,k4sf,k2sf,
       psx,olx/qg/app/app1/gw3/rw4/c1g/false/seid $ rename uh1
alter '/qmg/','' $
  call cforce  uset,gm,ug1,uh2,mmg,m2mg,bmg,b2mg,kmg,k4mg,k2mg,
     pm,olx/qmg/
     app/app1/gw3/rw4/c1g/true/seid $
alter 'call sesum' (,-1) $
if (nobeset>-1 and noqg>-1) then $
  if (app='statics') then $
    call dbfetch /qb,,,,/0/seid/0/0/0 $ 
  else $
    call dbfetch /qbd,,,,/0/seid/0/0/0 $ 
    equivx qbd/qb/always $
  endif $
    umerge1 uset,qb,,,/qbg/'g'/'be'/'s'/1 $ 's'=g-be
    add qg,qbg/qg1//-1.0 $
    equivx qg1/qg/always $ 
endif $
$ end of sedisp alters

$ FILE RUTIL8.txt  A COLLECTION OF utility SUBDMAPS
$ subset needed for sol 108.  Date last revised 10.21.99
$ FILE AUGMENTB   
COMPILE AUGMENTB nolist NOREF $
$       $       $       $       $       $       $       $     AUGMENTB
SUBDMAP AUGMENTB USETD,KXX/                 
     K11/XSET $                                     
$ AUGMENT THE STIFFNESS MATRIX BY ADDING CONSTRAINT EQUATIONS AT ITS
$ END.  
TYPE PARM,,CHAR4,N,XSET $                              
TYPE PARM,,I,N,NOBESET,NO1,NOXX $                           
PARAML KXX//'PRESENCE'////S,N,NOKXX $
IF (NOKXX=-1) RETURN $                    
PARAML USETD//'USET'//////'D'/S,N,NODSET/'A'/S,N,NOASET/
     'L'/S,N,NOLSET/'BE'/S,N,NOBESET $                  
IF (NOBESET=-1) THEN $ DON'T AUGMENT
  EQUIVX KXX/K11/ALWAYS $
  RETURN $
ENDIF $
PARAML KXX//'TRAILER'/4/S,N,KTYPE $ 1 OR 2 IF REAL, 3 OR 4 IF COMPLEX
MATGEN ,/IBB/1/NOBESET $
IF (KTYPE>2) THEN $
  ADD IBB,/IBBXx/(1.0,1.E-30) $ MAKE A LEGAL COMPLEX MATRIX IF KXX COMPLEX
  Add5 ibbxx,ibb,,,/ibbx/(0.0,0.0) $ let the first matrix make the trailer
ELSE $
  EQUIVX IBB/IBBX/ALWAYS $
ENDIF $                              
IF (XSET='D') THEN $                                    
  NO1 = NODSET + NOBESET $                              
  UMERGE1 USETD,IBBX,,,/RBD/'D'/'BE'/'C'/2 $ C=D-BE
ELSE IF (XSET='A') THEN $                               
  NO1 = NOASET + NOBESET $                              
  UMERGE1 USETD,IBBX,,,/RBD/'A'/'BE'/'C'/2 $          
ELSE IF (XSET='L') THEN $                               
  NO1 = NOLSET + NOBESET $                              
$ APPEARS TO BE AN ERROR WHEN NEXT CALL USED.  WILL USE MORE RELIABLE 
$ METHOD INSTEAD.
$  UMERGE1 USETD,IBBX,,,/RBD/'L'/'BE'/'C'/2 $          
  VEC USETD/VLBCOMP/'L'/'BE'/'COMP' $
  MERGE IBBX,,,,VLBCOMP,/RBD/1 $
ELSE $  ERROR TRAP                                      
  MESSAGE //'SYSTEM FATAL MESSAGE.  SET '/XSET/'NOT IN AUGMENTB' $      
  EXIT $                                                
ENDIF $ 
IF (XSET='D') THEN $
  CALL CONCAT KXX,RBD,,/K11/'S'/NO1/NO1 $ A-SET, L-SET COME THIS WAY     
ENDIF $
RETURN $                                                   
END $ AUGMENTB                                             

COMPILE CONCAT nolist NOREF $ AN ALTERNATE FORM OF MERGE
$       $       $       $       $       $       $       $    CONCATB
SUBDMAP CONCAT A12,A32X,A14X,A34/A/FORMAC/RA/CA $
$              A12  A14
$     [A] =  [          ]
$              A32  A34
TYPE PARM,,CHAR1,N,FORMAC='X' $ USER REQUEST FOR FORM, S OR U for sym, unsym
TYPE PARM,,I,N,FORMA,FORM12,FORM32,FORM14,FORM34,FORMIJ,RI,CI,
     N1,N2,N3,N4,RA,CA $
TYPE PARM,,I,N,COL12,COL32,COL14,COL34,ROW12,ROW32,ROW14,ROW34 $
TYPE PARM,,LOGICAL,N,INCON=FALSE $
TYPE PARM,,CHAR4,Y,DEBUG='NO' $ 
IF (RA=-1) RA = 0 $ REMOVE IGOROOTIE LOGIC
IF (CA=-1) CA = 0 $
IF (RA<0 OR CA<0) THEN $
  MESSAGE //'USER FATAL MESSAGE.  NEGATIVE R3 OR C4, NOT ALLOWED.'/
  RA/' =RA'/CA/' =CA IN CONCAT' $
  EXIT $
ENDIF $
INCON=(FORMAC<>'U' AND FORMAC<>'S') $
IF (FORMAC<>'U' AND FORMAC<>'S') THEN $
  MESSAGE //'SYSTEM FATAL ERROR IN CONCAT.  FORM='/FORMAC
     'NOT SUPPORTED.' $
  EXIT $
ENDIF $
PARAML A12//'PRESENCE'////S,N,FORM12 $ -1 IF NOT PRESENT
PARAML A32X//'PRESENCE'////S,N,FORM32 $
PARAML A14X//'PRESENCE'////S,N,FORM14 $
PARAML A34//'PRESENCE'////S,N,FORM34 $
FORMIJ=FORM12+FORM32+FORM14+FORM34 $
IF (DEBUG='YES') THEN $
  MESSAGE //'FIRST CHECK FOR FORM12,32,14,34,IJ'/
     FORM12/FORM32/FORM14/FORM34/FORMIJ $
ENDIF $
IF (FORMIJ = -4) RETURN $
IF (FORMAC='U' OR  (FORMAC='S' AND FORM32=0)) COPY A32X/A32 $  PROTECT
$  AGAINST PURGED INPUTS, AVOID MODTRL of INPUTS
IF (FORMAC='U' OR (FORMAC='S' AND FORM14=0)) COPY A14X/A14 $
IF (FORM12=0) PARAML A12//'TRAILER'/3/S,N,FORM12 $
IF (FORM32=0) PARAML A32//'TRAILER'/3/S,N,FORM32 $
IF (FORM14=0) PARAML A14//'TRAILER'/3/S,N,FORM14 $
IF (FORM34=0) PARAML A34//'TRAILER'/3/S,N,FORM34 $
IF (FORMAC='S') THEN $ FILL IN PURGED OFF-DIAGONAL TERMS
  IF (FORM32=-1 AND FORM14>-1) THEN $
    TRNSP A14/A32 $
    FORM32 = 0 $
  ELSE IF (FORM32>-1 AND FORM14=-1) THEN $
    TRNSP A32/A14 $
    FORM14 = 0 $
  ENDIF$
ENDIF $
$ CHECK CONGRUENCE
IF (FORM12>-1) PARAML A12//'TRAILER'/1/S,N,COL12 $
IF (FORM32>-1) PARAML A32//'TRAILER'/1/S,N,COL32 $
IF (FORM14>-1) PARAML A14//'TRAILER'/1/S,N,COL14 $
IF (FORM34>-1) PARAML A34//'TRAILER'/1/S,N,COL34 $
IF (FORM12>-1) PARAML A12//'TRAILER'/2/S,N,ROW12 $
IF (FORM32>-1) PARAML A32//'TRAILER'/2/S,N,ROW32 $
IF (FORM14>-1) PARAML A14//'TRAILER'/2/S,N,ROW14 $
IF (FORM34>-1) PARAML A34//'TRAILER'/2/S,N,ROW34 $
IF (FORM12>-1) THEN $ A12 EXISTS
  IF (FORM14>-1) THEN $
    IF (ROW12><ROW14) INCON=TRUE $ 1
  ENDIF $
  IF (FORM32>-1) THEN $
    IF (COL12><COL32) INCON=TRUE $ 3
  ENDIF $
ENDIF $
IF (FORM34>-1) THEN $ FORM34 EXISTS
  IF (FORM32>-1) THEN $
    IF (ROW34><ROW32) INCON=TRUE $ 2
  ENDIF $
  IF (FORM14>-1) THEN $
    IF (COL34><COL14) INCON=TRUE $ 4
  ENDIF $
ENDIF $								CONCATB
IF (INCON) THEN $
  MESSAGE //'SYSTEM FATAL MESSAGE IN CONCAT.  INCONGRUENT MATRICES '/
     'INPUT TO CONCAT.' $
  MESSAGE //'ROWS OF A12, A14; A32, A34'/ROW12/ROW14/ROW32/ROW34 $
  MESSAGE //'COLUMNS OF A12, A32; A14, A34'/COL12/COL32/COL14/COL34 $
  EXIT $
ENDIF $
N1 = MAX(ROW12,ROW14) $
N2 = MAX(COL12,COL32) $
N3 = MAX(ROW32,ROW34) $
N4 = MAX(COL14,COL34) $
IF (N1>0 AND N3>0 AND RA>0) THEN $
  IF(RA<>(N1+N3)) THEN $
    MESSAGE //'SYSTEM FATAL MESSAGE '/
    'INPUT ROWS DONT MATCH RA, RA N1 N3'/RA/N1/N3 $
  EXIT $
  ENDIF $
ENDIF $
IF (N2>0 AND N4>0 AND CA>0) THEN $
  IF (CA<>(N2+N4)) THEN $
    MESSAGE //'SYSTEM FATAL MESSAGEG '/
    'INPUT COLUMNS DONT MATCH CA, CA N2 N4'/CA/N2/N4 $
  EXIT $
  ENDIF $
ENDIF $  
IF (DEBUG='YES') THEN $
  MESSAGE //'N1 THRU N4, RA, CA'/N1/N2/N3/N4/RA/CA $
ENDIF $
IF (RA>0) THEN $
  IF (N1=0) N1=RA-N3 $
  IF (N3=0) N3=RA-N1 $
ENDIF $
IF (CA>0) THEN $
  IF (N2=0) N2=CA-N4 $
  IF (N4=0) N4=CA-N2 $
ENDIF $
IF ((RA>0 AND RA<(N1+N3)) OR (CA>0 AND CA<( N2+N4))) THEN $
  MESSAGE //'USER FATAL MESSAGE.  THE DIMENSIONS OF RA'/
        ' OR CA IS SMALLER THAN THE SUM OF THE LENGTHS OF'/
     	'THE INPUT MATRICES.' $
  MESSAGE //' RA CA N1 N3 N2 N4'/RA/CA/N1/N3/N2/N4 $
  EXIT $
ENDIF $ 
RI = N1 + N3 $ DIMENSIONS OF A FROM INPUT MATRICES
CI = N2 + N4 $ AND RA AND CA.
IF (DEBUG='YES') THEN $
  MESSAGE //'N1 THRU N4 AFTER RESET, RI, CI'/N1/N2/N3/N4/RI/CI $
ENDIF $
$ 3.  DETERMINE FORMA
IF (RI=CI) FORMA = 1 $
IF (RI<>CI) FORMA = 2 $
IF (FORMAC='S' AND ((FORM12=-1 OR FORM12=6) AND
        (FORM34=-1 OR FORM34=6)) AND (RI=CI)) THEN $
  FORMA=6 $
  IF (RI<CI) RI = CI $
  IF (CI<RI) CI = RI $
  IF (N1=0) N1 = RI - N3 $
  IF (N3=0) N3 = RI - N1 $
  IF (N2=0) N2 = CI - N4 $
  IF (N4=0) N4 = CI - N2 $
ENDIF $
$ 4.  MERGE WHEN YOU HAVE TO, APPEND OR COPY/MODTRL WHEN YOU CAN
IF (N1>0 AND N3>0) MATGEN, /VR13/6/RI/N1/N3 $
IF (FORM32>-1) THEN $
  MERGE A12,A32,,,,VR13/A2/1 $
ELSE IF (FORM32=-1 AND FORM12>-1) THEN $
  IF (FORM14=-1 AND FORM34=-1) THEN $
    COPY A12/A2/ALWAYS $
    MODTRL A2///RI $
  ELSE $
    EQUIVX A12/A2/ALWAYS $
  ENDIF $
ENDIF $								CONCATB
IF (FORM34>-1) THEN $
  MERGE A14,A34,,,,VR13/A4/1 $
ELSE IF (FORM34=-1 AND FORM14>-1) THEN $
  IF (FORM12=-1 AND FORM32=-1) THEN $
    COPY A14/A4/ALWAYS $
  ELSE $
    EQUIVX A14/A4/ALWAYS $
  ENDIF $
  MODTRL A4///RI $
ENDIF $
PARAML A2//'PRESENCE'////S,N,NOA2 $ -1 IF NOT PRESENT
PARAML A4//'PRESENCE'////S,N,NOA4 $
IF (FORMAC='S') THEN $
  IF (NOA2>-1 AND NOA4>-1) THEN $
    APPEND A2,A4/AA $
  ELSE IF (NOA2=-1 AND NOA4>-1) THEN $
    MATGEN ,/VC24/6/CI/N2/N4 $
    MERGE, ,,A4,,VC24,/AA/1 $
  ELSE IF (NOA2>-1 AND NOA4=-1) THEN $
    MATGEN, /NULLA/7/RI/RI $ NULL MATRIX, TO GET THE TRAILER RIGHT
    ADD NULLA,A2/AA $ SHOULD TAKE TRAILER FROM FIRST ONE
  ENDIF $
ELSE IF (FORMAC='U') THEN $ RECTANGULAR MATRICES FOLLOW
  IF (NOA2>-1 AND NOA4>-1) THEN $
    APPEND A2,A4/AA $
  ELSE IF (NOA4=-1) THEN $
    EQUIVX A2/AA/ALWAYS
  ELSE IF (NOA2=-1) THEN $
    MATGEN ,/VC24/6/CI/N2/N4 $
    MERGE, ,,A4,,VC24,/AA/1 $
  ENDIF $
ENDIF $
$  5. FINAL CHECK AND CLEANUP.  FIND ACTUALS, RESET IF NECESSARY
PARAML AA//'TRAILER'/1/S,N,COLSA $
PARAML AA//'TRAILER'/2/S,N,ROWSA
MODTRL AA////FORMA $ V70
IF (ROWSA><RI OR COLSA><CI OR (FORMAC='S' AND RI><CI)) THEN $
$ ADD NULLS ROWS AND/OR COLUMNS
  IF (RA>RI) RI=RA $
  IF (CA>CI) CI=CA $
  IF (FORMAC='S') THEN $
    IF (RI<CI) RI=CI $
    IF (CI<RI) CI=RI $ USE THE MAX
  ENDIF $
  MATGEN ,/NULLRC/7/RI/CI $
  IF (RA<>CA) FORMA = 2 $ V70 GIVES ERROR IN TRD1 LATER
  MODTRL AA////FORMA $  
  ADD NULLRC,AA/A $
ELSE $
  EQUIVX AA/A/ALWAYS $
ENDIF $
RETURN $
END $ CONCAT
$       $       $       $       $       $       $       $       DCMPB

COMPILE DECAT nolist NOREF $
$	$	$	$	$	$	$	$	DECAT
SUBDMAP DECAT A/A12,A32,A14,A34/R3/C4 $
$               A12  A14
$       [A] -> [          ]
$               A32  A34
TYPE PARM,,I,N,FORMA,R1,C2,R3,C4 $
PARAML A//'PRESENCE'////S,N,FORMA $ -1 IF NOT PRESENT
IF (R3=-1) R3 = 0 $ REMOVE IGOROOTIE LOGIC
IF (C4=-1) C4 = 0 $
IF (FORMA=-1) RETURN $
IF (R3<0 OR C4<0) THEN $
  MESSAGE //'USER FATAL MESSAGE.  NEGATIVE R3 OR C4, NOT ALLOWED.'/
  R3/' =R3'/C4/' =C4 IN DECAT' $
  EXIT $
ENDIF $
IF (R3=0 AND C4=0) THEN $
  EQUIVX A/A12/ALWAYS $
  RETURN $
ENDIF $
PARAML A//'TRAILER'/3/S,N,FORMA $ 
PARAML A//'TRAILER'/1/S,N,COLA $ 
PARAML A//'TRAILER'/2/S,N,ROWA $
R1 = ROWA - R3
C2 = COLA - C4
IF (R1=ROWA AND C2=COLA) THEN $
  COPY A/A12/ALWAYS $
  RETURN $
ENDIF $
IF (R1=0 AND C2=0) THEN $
  COPY A/A34/ALWAYS $
  RETURN $
ENDIF $
IF (R1=0 AND C2=COLA) THEN $
  COPY A/A32/ALWAYS $
  RETURN $
ENDIF $
IF (R1=ROWA AND C2=0) THEN $
  COPY A/A14/ALWAYS $
  RETURN $
ENDIF $
IF (R3>ROWA OR C4>COLA) THEN $
  MESSAGE //'USER FATAL MESSAGE.  PARTITIONING VALUES EXCEED'/
        'DIMENSIONS OF A' $
  MESSAGE //ROWA/ ' ROWS, AND'/COLA/' COLUMNS.'/
         'R3 ='/R3/', C42 ='/C4 $
  EXIT $
ENDIF $
MATGEN, /VROW/6/ROWA/R1/R3 $
MATGEN, /VCOL/6/COLA/C2/C4 $
PARTN A,VCOL,VROW/A12,A32,A14,A34/1 $
IF (R1=C2) THEN $
  MODTRL A12////FORMA $
  MODTRL A34////FORMA $
ENDIF $
RETURN $
END $ DECAT

COMPILE FRLG nolist NOREF $      $       $       $       $       $FRLG
SUBDMAP FRLG     CASES,USETD,DLT,FRL,DIT/
                       PPF,ybe,FOL/
                       FREQY/APP $
TYPE PARM,,CHAR4,Y,DEBUG='no' $
TYPE PARM,,CHAR8,N,SOLTYP,APP $
PARAML USETD//'USET'//////'BE'/S,N,NOBESET $
FRLG     CASES,USETD,DLT,FRL,,,DIT,/
           PPFBAR,,,FOL,/
           'DIRECT  '/S,N,FREQY/S,N,APP $ SOLTYP=MODAL WON'T MAKE PDF
CALL LTRANB  USETD,PPFBAR/PPF,YB1 $ 
IF (NOBESET>-1) THEN $
  CALL RINT USETD,FOL,YB1/YBe,OMEG,OMEGSQ $ ACCE, VELO TO DISPL
ENDIF $
IF (DEBUG='YES') THEN $
  MESSAGE //'OUTPUTS FROM FRLGB,PPF,ybe,FOL' $
  MATPrn PPF,ybe,FOL// $
ENDIF $
RETURN
END $ FRLG

COMPILE LTRANB nolist NOREF $ CALLED FROM FRLGL, TRLGL $ 	LTRANB
SUBDMAP LTRANB  USETD,PPXBAR/PPX,YB $
$ TRANSFERS LOADS ON ENFORCED MOTION POINTS TO LMT VARIABLES
$ IF THERE ARE ENFORCED MOTION VARIABLES
type parm,,char4,y,debug='no' $
PARAML  USETD//'USET'//////'BE'/S,N,NOBESET $
IF (NOBESET>-1) THEN $
  VEC USETD/VPCMPB/'P'/'COMP'/'BE' $
  PARTN PPXBAR,,VPCMPB/PCMB,YB,,/1 $
  MERGE PCMB,,,,,VPCMPB/PPX/0 $
ELSE $
  EQUIVX PPXBAR/PPX/ALWAYS $
ENDIF $
If (debug='yes') then $
  Message //'inputs, outputs from ltranb, nobeset'/nobeset $
  Matprn ppxbar
  Matprn ppx,yb// $
Endif $
RETURN $
END $ LTRANB

$ FILE RADD5 
COMPILE RADD5 nolist NOREF $	$	$	$	$	radd5
SUBDMAP RADD5 M1,M2,M3,M4,M5/OUT/A1/A2/A3/A4/A5 $  
$ FOR REASONS OF CONVENIENCE AND DMAP READABILITY, THE INPUT PARAMS
$ ARE REAL SINGLE PRECSION.
TYPE PARM,,RS,N,A1,A2,A3,A4,A5 $
TYPE PARM,,CS,N,CZ=(0.,0.),                    
               A1X,A2X,A3X,A4X,A5X $                                    
TYPE PARM,,LOGI,,DOM1,DOM2,DOM3,DOM4,DOM5 $                             
PARAML M1//'NULL'////S,N,NOM1 $                                         
DOM1=(NOM1>-1 AND A1<>0.0) $                                             
PARAML M2//'NULL'////S,N,NOM2 $                                         
DOM2=(NOM2>-1 AND A2<>0.0) $                                             
PARAML M3//'NULL'////S,N,NOM3 $                                         
DOM3=(NOM3>-1 AND A3<>0.0) $                                             
PARAML M4//'NULL'////S,N,NOM4 $                                         
DOM4=(NOM4>-1 AND A4<>0.0) $                                             
PARAML M5//'NULL'////S,N,NOM5 $                                         
DOM5=(NOM5>-1 AND A5<>0.0) $                                             
IF      ( DOM1 AND A1=1.0 AND NOT(DOM2 OR DOM3 OR DOM4 OR DOM5) ) THEN $      
   EQUIVX   M1/OUT/-1 $                                                 
ELSE IF ( DOM2 AND A2=1.0 AND NOT(DOM1 OR DOM3 OR DOM4 OR DOM5) ) THEN $ 
   EQUIVX   M2/OUT/-1 $                                                 
ELSE IF ( DOM3 AND A3=1.0 AND NOT(DOM1 OR DOM2 OR DOM4 OR DOM5) ) THEN $ 
   EQUIVX   M3/OUT/-1 $                                                 
ELSE IF ( DOM4 AND A4=1.0 AND NOT(DOM1 OR DOM2 OR DOM3 OR DOM5) ) THEN $ 
   EQUIVX   M4/OUT/-1 $                                                 
ELSE IF ( DOM5 AND A5=1.0 AND NOT(DOM1 OR DOM2 OR DOM3 OR DOM4) ) THEN $ 
   EQUIVX   M5/OUT/-1 $                                                 
ELSE IF ( DOM1 OR DOM2 OR DOM3 OR DOM4 OR DOM5 ) THEN $                 
   A1X=CMPLX(A1) $                                                             
   A2X=CMPLX(A2) $                                                             
   A3X=CMPLX(A3) $                                                             
   A4X=CMPLX(A4) $                                                             
   A5X=CMPLX(A5) $                                                             
$ IF MATRIX IS NULL OR PURGED, THEN      
$ ZERO OUT COEFFICIENT SO ADD5 TAKES EFFICIENT PATH                     
  IF ( NOM1=-1 ) A1X=CZ $                                              
  IF ( NOM2=-1 ) A2X=CZ $                                              
  IF ( NOM3=-1 ) A3X=CZ $                                              
  IF ( NOM4=-1 ) A4X=CZ $                                              
  IF ( NOM5=-1 ) A5X=CZ $                                              
   ADD5     M1,M2,M3,M4,M5/OUT/A1X/A2X/A3X/A4X/A5X $                    
ENDIF $                                                                 
RETURN $                                                                
END $ RADD5                                                             

COMPILE RED nolist NOREF $	$	$	$	$	$	red
SUBDMAP RED R,A/B $ B=TRNSP(R)*A*R
TYPE PARM,,CHAR4,Y,DEBUG='NO' $
IF (DEBUG='YES') THEN $
  MESSAGE //'START RED MATPrn R,A' $
  MATPrn R,A// $
ENDIF $
$REDUCE A TO B WITH R
PARAML R//'PRESENCE'////S,N,NOR $ NOR=-1 IF R DOES NOT EXIST
PARAML A//'PRESENCE'////S,N,NOA $ 
IF (NOA=-1) RETURN $ OUTPUT PURGED IF A NOT PRESENT
PARAML A//'TRAILER'/5/S,N,NZWDSA $
IF (NZWDSA=0) RETURN $
IF (NOR=-1) THEN $
  EQUIVX A/B/ALWAYS $
  RETURN $
ELSE $
  PARAML A//'TRAILER'/3/S,N,FORM $
  SMPYAD  R,A,R,,,/B/3////1////FORM $ 
  $MPYAD A,R,/AR $
  $MPYAD R,AR,/B/1////FORM $
ENDIF $
IF (DEBUG='YES') THEN $
  MESSAGE  //'END RED, MATPrn B' $
  MATPrn B// $
ENDIF $
RETURN
END $ RED

COMPILE RINT nolist NOREF $
$       $       $       $       $       $                               RINTB
SUBDMAP RINT USETD,FOL,YB1/YB,OMEG,OMEGSQ $
$ INTEGRATES FREQRESP VELOCITY AND ACCELERATION INPUTS INTO DISPLACEMENT INPUTS
$ SIMLUATE READING TYPE FROM RLOADI ENTRIES WITH DMIG DVA, WHICH HAS
$ 1.0 FOR DISP, 2.0 FOR VELO, AND 3.0 FOR ACCEL ON BE-SET POINTS.  ANY
$ OTHER VALUES ARE IGNORED.  REYMOND'S DSAP TRICK ADDED.
TYPE PARM,,I,N,TSTP1,NZDISP,NZVELO,NZACCE,II $
TYPE PARM,,RS,N,OMEGA $
TYPE PARM,,CS,N,CXOMEGA $
TYPE PARM,,CHAR4,Y,DEBUG='NO' $
FILE OMEGVEC=APPEND $
PARAML USETD//'USET'//////'BE'/S,N,NOBESET $
CALL DBFETCH /DVA,,,,/0/0/0/0/0 $ THIS DATA NORMALLY
$ COMES IN FROM TLOADI ON DYNAMICS DATABLOCK
PARAML DVA//'PRESENCE'////S,N,NODVA $
IF (NODVA=-1) THEN $
  EQUIVX YB1/YB/ALWAYS $
  RETURN $
ENDIF $
UPARTN USETD,DVA/DVAB,ERR,,/'G'/'BE'/'S'/1 $ 'S'=G-BE
PARAML YB1//'TRAILER'/1/S,N,NFREQS $ NUMBER OF EXCITATION FREQUENCIES
PARAML FOL//'DTI'/0/3/S,N,FREQ1 $ FIRST EXCITATION FREQUENCY
IF (FREQ1=0.0) THEN $
  MESSAGE //'USER WARNING MESSAGE.  FIRST EXCITATION FREQUENCY '/
     'IS ZERO.  ENFORCED MOTION VALUES FOR VELOCITY AND'/
     ' ACCELERATION INPUTS SET TO ZERO.' $
ENDIF $
MATGEN, /IF/6/NFREQS/0/NFREQS $ UNIT VECTOR
MATGEN, /IFF/1/NFREQS $ IDENTITY MATRIX
ADD IFF,/IFFX1/(0.,1.) $ DSAP WANTS IT COMPLEX
ADD IFFX1,/IFFX/(0.,-1.) $ ELEMENTS NOW (1.,0.)
ADD IF,/IFX1/(0.,-1.) $ -I*I=1
ADD IFX1,/IFX/(0.,-1.) $ ELEMENTS ARE NOW (1.,0.)
DSAP, ,IFFX,,FOL,/OMEGDIAG/'FREQRESP'  $ EXCIT. FREQUENCIES ON DIAGONAL
EQUIVX OMEGDIAG/OMEGA/ALWAYS $
MPYAD OMEGA,OMEGA,/OMEGSQ $
$ IN IMAGINARY SLOT
MPYAD OMEGDIAG,IF,/OMEGVECX $ IN VECTOR
ADD IF,OMEGVECX/VELVEC///2 $ INVERT. 1/OMEGA
ADD VELVEC,VELVEC/ACCVEC///1 $ SQUARE, 1/(OMEGA*OMEGA)
EQUIVX IFX/DISVEC/ALWAYS $ $ 
MATGEN, /IB/6/NOBESET/0/NOBESET $ UNIT VECTOR
CALL RMAT IB,DVAB,DISVEC/DMASK/NOBESET/1.0/S,NZDISP $
CALL RMAT IB,DVAB,VELVEC/VMASK/NOBESET/2.0/S,NZVELO $
CALL RMAT IB,DVAB,ACCVEC/AMASK/NOBESET/3.0/S,NZACCE $
IF (NZVELO=0 AND NZACCE=0) THEN $
  EQUIVX YB1/YB/ALWAYS $
  RETURN $
ENDIF $
ADD5 DMASK,VMASK,AMASK,,/MASK $
ADD YB1,MASK/YB///1 $ ELEMENT MULTIPLY
IF (DEBUG='YES') THEN $
  MATPrn YB1,MASK,YB// $
  MATPrn ACCVEC,AMASK// $
ENDIF $
RETURN $
END $ RINT

COMPILE RMAT nolist NOREF $		$	$	$	$	rmat
SUBDMAP RMAT IB,DVAB,XMASKT/BEMASK/NOBESET/VALUE/NUMBER $
$ BXMASK IS BE BY NFREQ WITH I/OMEG FOR VELO, -1/OMEQSQ FOR ACCEL
TYPE PARM,,I,N,NOBESET,NUMBER $
TYPE PARM,,RS,N,VALUE $
TYPE PARM,,CS,N,CVALUE $
CVALUE=-CMPLX(VALUE) $
TRNSP XMASKT/XMASK $
ADD DVAB,IB/DAB//CVALUE $ DISP HAS ZERO IN DAB
PARAML DAB//'TRAILER'/5/S,N,NZDISP $
PARAML DAB//'TRAILER'/4/S,N,PREC $
NZDISP = NZDISP/PREC $
IF (NZDISP<NOBESET) THEN $ MUST BE ZERO TERMS, HENCE XAVG HAS NUMBERS
$ EQUAL TO VALUE
  NUMBER = NOBESET - NZDISP $
  IF (NUMBER=1) THEN $
   EQUIVX XMASK/NMASK/ALWAYS $
  ELSE $
    MATGEN, /VNUMBER/6/NUMBER/0/NUMBER $ UNIT VECTOR NUMBER LONG
    MPYAD VNUMBER,XMASK,/NMASK $ REPEAT EACH ROW
  ENDIF $
  MERGE NMASK,,,,,DAB/BEMASK/1 $ PUT ROWS IN PROPER SLOTS
ENDIF $  
RETURN $ 
END $ RMAT

COMPILE SCHKB nolist NOREF $ 	 $ $ 	 $	$	$	schkb
SUBDMAP SHCKB //SAVLOG/DMAPNO $
$ CHECK TO SEE IF SOL SEQ IS SUPPORTED.
$ BLOCK USE OF RFLAGB ALTER IN SOL SEQS WHICH ARE NOT SUPPORTED.
$ CALLED FROM SUPPORTED MAIN SUBDMAPS, PHASE0
TYPE PARM,,I,N,DMAPNO $ PASSED TO PHASE0
TYPE PARM,NDDL,LOGICAL,N,ZUZRL1 $ NDDL VALUE IS FALSE
TYPE PARM,,LOGICAL,N,SAVLOG=FALSE $
IF (SAVLOG) ZUZRL1 = SAVLOG $ SAVE THE VALUE INPUT FROM MAIN
IF (ZUZRL1=FALSE) THEN $
  MESSAGE //'USER FATAL MESSAGE.  THE RFLAGB ALTER PACKAGE '/
     'DOES NOT SUPPORT SOL. SEQ. '/DMAPNO $
  EXIT $
ENDIF $
RETURN 
END $ SCHKB

$END OF RUTIL8.TXT
$
$ change:  multiply k4 by 0.0. old freq. dep. Not supported, based
$ on changing k4 with a table.  New freq. dep. (bush) is supported.
$ File frrd1b.txt
COMPILE FRRD1b nolist NOREF $
$       $       $       $       $       $       $       $       FRRD1
SUBDMAP FRRD1b CASES,DIT,CKDD,CBDD,CMDD,K4DD,PDF,FRL,FOL,edt,sild,
  USETD,partvec,YBE/UDVF,fol1,QbeG/
  SOLTYP/noncup/itseps/itsmax/nskip/zfreq/FIRSTBAD/setname/
  Freqdep/iresx $
$ driver subdmap for frrd1
$ AUGMENT INPUT MATRICES with beset constraints
$ DEAUG THE SOLUTION to displacements udvf, constraint forces qbeg
TYPE PARM,,CHAR8,N,SOLTYP,setname $
TYPE PARM,,I,N,noncup,itseps,itsmax,nskip,zfreq,n1 $ 
Type parm,,logical,n,firstbad,freqdep $ firstbad is output
Type parm,,rs,n,epsfr,epsmax=1.e-10 $
Type parm,,char8,y,debug='no' $
Type parm,,cs,n,cz,cu=(1.,0.),ci=(0.,1.) $
Type parm,,I,n,iresx $ this paramter not on frrd1.  Used to select epsilon calc 
PARAML USETD//'uset'//////'be'/S,N,nobeset/
                          'd'/s,n,nodset $/'a'/s,n,noaset $
IF (nobeset>0) THEN $
  CALL AUGMENTb USETD,CKDD/K11/'d' $ add constraint equations in be-set
  N1 = nobeset + nodset $
  Call concat cbdd,,,/b11/'s'/n1/n1 $
  Call concat cmdd,,,/m11/'s'/n1/n1 $
  Call concat k4dd,,,/k411/'s'/n1/n1 $
  Call concat pdf,ybe,,/p1/'u'/n1/0 $
  $  PUTSYS (4,166) $ DEACTIVATE MAXRATIO TESTS
  if (debug='yes') then $
    matprn k11,b11,m11,k411,p1// $
  endif $
  FRRD1    CASES,DIT,K11,B11,M11,K411,P1,FRL,FOL,edt,sild,
    USETD,partvec/U1,fol1/SOLTYP/noncup/itseps/itsmax/nskip/frrd1sel/
     S,N,FIRSTBAD/setname/freqdep $
  If (debug='yes') then $
    Message //'output from frrd1' $
    Matprn u1,fol1// $
  Endif $
  CALL decat U1/UDVF,Qbe,,/nobeset/0 $
  Umerge1 usetd,qbe,,,/qbeg/'g'/'be'//1 $
  If (iresx=1) then $
    $Call xadd5 k11,k411,,,/kx11/cu/cz/cz/cz/cz $
    $ watch out for k4.  Used only when unusual inputs
    call solchk m11,b11,k11,u1,p1,fol/rh/
     'freqresp'/-1/s,epsfr $
    if (epsfr>epsmax) then $
      message //'epsfr'/epsfr $
    endif $
  endif $
ELSE $
  FRRD1    CASES,DIT,CKDD,CBDD,CMDD,K4DD,PDF,FRL,FOL,edt,sild,
  USETD,partvec/UDVF,fol1/SOLTYP/noncup/itseps/itsmax/nskip/frrd1sel/
        S,N,FIRSTBAD/setname/freqdep $
  If (iresx=1) then $
    call solchk cmdd,cbdd,ckdd,udvf,pdf,fol/rh/
     'freqresp'/-1/s,epsfr $
    if (epsfr>epsmax) then $
      message //'epsfr'/epsfr $
    endif $
  endif $
ENDIF $
RETURN $
END $ FRRD1b

$ file freqrS.  From v707 del file, MODEIFIED EXTENSIVELY
compile freqrs nolist noref $
subdmap freqrs  CASES   ,USETD   ,DLT     ,FRL     ,trl     ,
                rpx     ,DIT     ,EST     ,CSTMS   ,MPTS    ,
                bgpdts  ,gpsnts  ,GPECT   ,SILS    ,edt     ,
                ckdd    ,cmdd    ,cbdd    ,k4dd    ,qhjl    ,
                acpt    ,cstma   ,qhhl    ,sild    ,ditid   ,
                vafs    ,rgdfd   ,rsgg    ,rmgg    ,ppf     ,
                fol     ,vphfs   ,vgfd    ,vgfs    /
                UDF     ,qmgf    ,qsgf    ,pdf     /
                soltyp  /freqdep /noa     /fourier /delta   /
                ndvar   /aero    /bov     /dompcffd/dospcffd/
                fs      /noue    /adjflg  /aeconfig/symxz   /
                symxz   $
$ MAJOR CHANGES MADE FOR INTEGRATING FS, FREQDEP, ENF. MOT., ETC.
$ TESTED IN SOL 108, BUT NOT OTHERS SUCH AS SOL 111, SOL 200, ETC.
type db pdfx,kggf1,ckddf1,ckddf,bggf,cbddf1,cbddf,k4gg,k4ddf1,k4ddf,
        pdfi,udfi,udfx,udfi0,udf1,xggf,qqgfi0,qqgfx,qqgfx0,ppf1,uht1,
        k4ggnf,k4ggf0,k4ggf,kggf $
$
TYPE PARM,NDDL,I,Y,COUPMASS,IFTM $
type parm,nddl,rs,y,g,MACH,Q $
type parm,,rs,n,bov $
type parm,,char8,n,aeconfig $
type parm,,i,n,frqloop=0,zero,nsol,adjflg,
               NOKjjf,NOBjjf,NOK4jjf,NOKjjnf,
               noa,ndvar,np,nosPset,symxz,symxy,newnfreq=0,
               NROWSC $
type parm,,logi,n,dospcffd,dompcffd,delta,freqdep,aero,fs,acsyml,
                  fourier,firstbad $
type parm,,char8,n,soltyp,frrdset='h',app='freqresp' $
TYPE PARM,,RS,Y,K6ROT=0. $
TYPE PARM,,cS,n,c1G,iomega,cu=(1.,0.),cz,CMU=(-1.0,0.0) $ 
file udfx=save/qqgfx=save $
FILE QBEGX=APPEND $
type parm,nddl,char8,y,acsym $
$ new stuff
type parm,,char4,y,debug='no' $
type parm,,i,n,noue $ satisfy compiler.  remove from call someday
TYPE PARM,,CHAR8,N,setname='d' $ defaults are from v70.7 call
TYPE PARM,,I,N,itseps,itsmax,nskip=1,zfreq $ 
Type parm,,logical,n, FIRSTbd0 $
type parm,,i,n,noncup $ assume same action as trd equivalent
$noncup = -1 $ test for uncoupled matrices, solve uncoup.
PARAML USETD//'USET'//////'be'/S,N,NOBESET/ 
                          'P'/S,N,NOPSET $
if (debug='yes') then $
  message //'inputs to freqrs' $
  matprn ckdd,cmdd,cbdd,k4dd,ppf// $
  matprn rpx,vphfs,vafs// $
endif $

$
$ move fs here, change d-set to p-set
equivx ppf/ppfx/always $ allows deletion later
$
paraml   fol//'trailer'/1/S,N,nfreq $ moved from line 97
paraml   pPfx//'trailer'/1/S,N,ncol $
nsol=ncol/ndvar $
$
if ( fs ) then $
   if ( soltyp='direct' ) then $
      IF (NOBESET>-1) THEN $ CHANGE SIGN OF BE-SET LOADS
         UPARTN USETD,VGFS/VBFS,,,/'G'/'BE'//1 $ 
         NROWSC = NOPSET - NOBESET $ NUMBER OF ROWS IN COMPLEMENT SET
         MATGEN ,/UC/6/NROWSC/0/NROWSC $ UNIT VECTOR.  INELELGANT 
         $ SOLUTION. C CAN BE LARGE
         MATGEN ,/UB/6/NOBESET/0/NOBESET $
         ADD VBFS,UB/MVBFS/-2.0/1.0 $ S=1, F=-1
         UMERGE1 USETD,MVBFS,UC,,/MVPFS/'P'/'BE'//1 $ NEG. TERMS ON BE
         MATMOD MVPFS,,,,,/IMPP,/28 $
         MPYAD IMPP,PPFX,/PPFXXX $
         EQUIVX PPFXXX/PPFX/ALWAYS $
      ENDIF $ NOBESET
      EQUIVX   VgFS/VXFS/NOUE $
      IF ( noue>-1 ) UMERGE   USETD,VgFS,/VXFS/'p'/'g'/'E' $
   else $
      equivx  vphfs/vxfs/-1 $
$ figure out how to fix vphfs later.  Needed for modal?
   endif $
   if ( acsym='yes' ) then $
      acsyml=true $
      PARTN    ppfx,,vxfs/ppFS,ppFF,,/1 $ 
      paraml   ppff//'null'////s,n,nullppff $
      if ( nullppff>-1 ) then $
         if ( adjflg>=2 ) then $
            $ Multiply adjoint fluid loads by i*omega
            dsap     ,,ppff,,fol,/ppff1/app $
         else $
            $ Divide fluid loads by i*omega
            matmod   fol,,,,,/omega,/33 $
            matgen   ,/icol/4/1/ncol $
            $ Form reciprocal and multiply by i
            add      icol,omega/riomega//(0.,1.)/2 $ 
            $ Convert to diagonal matrix
            matmod   riomega,,,,,/riomegad,/28 $
            mpyad    ppff,riomegad,/ppff1//-1 $
         endif $ adjflg>=2
         delete   /ppfx,,,, $
         merge    PpFS,PpFF1,,,,vxfs/PpFx/1 $ 
      endif $ nullpdff>-1
      if ( freqdep ) then $
$ form matrix to negate fluid portion of 
$ delta-mass, delta-damping, and delta-stiffness
         PARAML   vxfs//'TRAILER'/5/S,N,NOFpSET $
         PARAML   vxfs//'TRAILER'/4/S,N,PREC $
         NOFpSET=NOFpSET/PREC $
         PARAML   vxfs//'TRAILER'/2/S,N,nopset $
         nospset=nopset-nofpset $
         matgen   ,/ifpp/1/nofpset $
         matgen   ,/ispp/1/nospset $
         add5     ifpp,,,,/mifpp/-1. $
         MERGE    ispp,,,mifpp,VXFS,/ipp $
      endif $ freqdep
   endif $ acsym='yes'
endif $ fs

CALL LTRANB  USETD,PPFx/PPFxx,YB1 $ 
IF (NOBESET>-1) THEN $
  CALL RINT USETD,FOL,YB1/YBe,OMEG,OMEGSQ $ ACCE, VELO TO DISPL
ENDIF $


if ( noa<0 and soltyp='direct' ) then $
   equivx   ppfxx/pdf/-1 $
else $
   mpyad    rpx,ppfxx,/pdf/1 $ 
endif $
$
if ( fourier ) then $
   $ For distributed memory parallel: 
   putsys(0,288) $ slavejob=yes
   putsys(0,307) $ mergeofp=no
endif $ fourier
$
if ( aero and not(delta) ) then $
   GUST     CASES,DLT,FRL,DIT,QHJL,,,ACPT,CSTMA,PdF/
            Pdfx,wj,qhjk,pp/
            S,N,NOGUST/BOV/MACH/Q $
   EQUIVX   PdF/Pdfx/NOGUST $
else $
   equivx   pdf/pdfx/-1 $
endif $
$
if ( soltyp='direct' ) frrdset='d' $
$
$
$ fs formerly was here

if ( freqdep ) then $
   upartn usetd,ipp/idd,,,/'p'/'d'//0 $ version with fs terms, not identitiy
   $ 
   if ( fs ) then $
      trnsp    vgfs/vgfst $  vgfs:1=fluid      vgfd:1=freq-dep
      $                           0=structure
      matmod   vgfst,,,,,/vgsf,/12//1 $ vgsf:0=fluid
      trnsp    vgfd/vgfdt $
      matmod   vgfdt,,,,,/vgdf,/12//1 $ vgdf:0=freq-dep
      add5     vgsf,vgdf,,,/vgfdf $ vgfdf: 0=freq-dep and fluid
      add5     vgfs,vgdf,,,/vgfds $ vgfds: 0=freq-dep and structure
      partn    rgdfd,vxfs,/rsgx,,rfgx,/1 $
   endif $
   DO WHILE ( frqloop>=0 ) $
      FRQDRV   cases,FRL/FRLi/s,n,frqloop/S,N,FREQVAL $
      if ( frqloop=2 and getsys(np,242)<>-1 ) putsys(3,242) $
      $    
      nokjjf=-1 $
      nobjjf=-1 $
      nok4jjf=-1 $
      nokjjnf=-1 $
      EMG      EST,CSTMS,MPTS,DIT,,,,,,,BGPDTS,GPSNTS,,,,ditid/
               KELMf,KDICTf,,,BELMf,BDICTf/
               S,N,NOKJJf/0/S,N,NOBJJf/S,N,NOK4JJf/S,N,HNNLK/
               COUPMASS///////////K6ROT/////'estf'/freqval $
      $    
      EMA      GPECT,kDICTf,kELMf,BGPDTS,SILS,CSTMS,,/
               kggf,/-1 $
      if ( nobjjf>-1 ) EMA      GPECT,bDICTf,bELMf,BGPDTS,SILS,CSTMS,,/
                                bggf,/-1 $
      EMG      EST,CSTMS,MPTS,DIT,,,,,,,BGPDTS,GPSNTS,,,,ditid/
               KELMnf,KDICTnf,,,,/
               S,N,NOKJJnf/0/0/S,N,NOK4JJnf/S,N,HNNLK/
               COUPMASS///////////K6ROT/////'estnf'/freqval $
      if ( nok4jjnf>=0 ) EMA,
                  GPECT,KDICTnf,KELMnf,BGPDTS,SILS,CSTMS,,/
                  K4ggnf,/0 $
      if ( nok4jjf>=0 ) EMA,
                  GPECT,kDICTf,kELMf,BGPDTS,SILS,CSTMS,,/
                  k4ggf0,/0 $
      call xadd5  k4ggf0,k4ggnf,,,/k4ggf/cu/cu/cz/cz/cz $ 
      $    
      C1G=CMPLX(1.,G) $
      IF ( G>0. or NOK4jjf>-1 or NOK4jjnf>-1 ) THEN $
         ADD5     kggf,K4ggf,,,/Kggf1/C1G/(0.,1.) $
      else $
         equivx   kggf/kggf1/-1 $
      endif $ G>0. or ...
      dbstatus kggf1,rsgx,rfgx,rgdfd//
               s,n,nokggf1/s,n,norsgx/s,n,norfgx/s,n,norgdfd $
      if ( nokggf1>0 ) then $
         if ( fs ) then $
            if ( norsgx>0 ) then $
               partn    kggf1,vgfds,/ksgg,,, $
               paraml   ksgg//'null'////s,n,noksgg $
               if ( noksgg>-1 ) smpyad   rsgx,ksgg,rsgx,,,/
                                         ksdd/3////1////6 $
            endif $ norsgx>0
            if ( norfgx>0 ) then $
               partn    kggf1,vgfdf,/kfgg,,, $
               paraml   kfgg//'null'////s,n,nokfgg $
               if ( nokfgg>-1 ) smpyad   rfgx,kfgg,rfgx,,,/
                                         kfdd/3////1////6 $
            endif $ norfgx>0
            MERGE    ksdd,,,kfdd,Vxfs,/ckddf1///6 $
         else $
            partn    kggf1,vgfd,/,,,kfdgg $
            if ( norgdfd>0 ) then $
               smpyad   rgdfd,kfdgg,rgdfd,,,/ckddf1/3////1////6 $
            else $
               equivx   kfdgg/ckddf1/-1 $
            endif $ norgdfd>0
         endif $ fs
         if ( acsyml ) then $
            PARAML   ckdd//'TRAILER'/3/S,N,form//s,n,nockdd $
            if ( nockdd=-1 ) form=6 $
            mpyad    ckddf1,idd,ckdd/ckddf/////form $
         else $
            call xadd5  ckddf1,ckdd,,,/ckddf/cu/cu/cz/cz/cz $
         endif $ acsyml   
      else $   
         equivx   ckdd/ckddf/-1 $
      endif $ nokggf1>0
      if ( nobjjf>-1 ) then $
         if ( fs ) then $
            if ( norsgx>0 ) then $
               partn    bggf,vgfds,/bsgg,,, $
               paraml   bsgg//'null'////s,n,nobsgg $
               if ( nobsgg>-1 ) smpyad   rsgx,bsgg,rsgx,,,/
                                         bsdd/3////1////6 $
            endif $ norsgx>0
            if ( norfgx>0 ) then $
               partn    bggf,vgfdf,/bfgg,,, $
               paraml   bfgg//'null'////s,n,nobfgg $
               if ( nobfgg>-1 ) smpyad   rfgx,bfgg,rfgx,,,/
                                         bfdd/3////1////6 $
            endif $ norfgx>0
            MERGE    bsdd,,,bfdd,VXFS,/cbddf1///6 $
         else $
            partn    bggf,vgfd,/,,,bfdgg $
            if ( norgdfd>0 ) then $
               smpyad   rgdfd,bfdgg,rgdfd,,,/cbddf1/3////1////6 $
            else $
               equivx   bfdgg/cbddf1/-1 $
            endif $ norgdfd>0
         endif $ fs
         if ( acsyml ) then $
            PARAML   cbdd//'TRAILER'/3/S,N,form//s,n,nocbdd $
            if ( nocbdd=-1 ) form=6 $
            mpyad    cbddf1,idd,cbdd/cbddf/////form $
         else $
            call xadd5  cbddf1,cbdd,,,/cbddf/cu/cu/cz/cz/cz $
         endif $ acsyml
      else $
         equivx   cbdd/cbddf/-1 $
      endif $ nobjjf>-1
      if ( soltyp='direct' and not(delta) ) then $
         $  For viscoelastic materials
         PARAML   CASES//'DTI'/1/149//S,N,SDAMP $ 
         if ( (NOK4jjf>-1 or NOK4jjnf>-1) and sdamp>0 ) then $
            if ( fs ) then $
               if ( norsgx>0 ) then $
                  partn    k4ggf,vgfds,/k4sgg,,, $
                  paraml   k4sgg//'null'////s,n,nok4sgg $
                  if ( nok4sgg>-1 ) smpyad   rsgx,k4sgg,rsgx,,,/
                                             k4sdd/3////1////6 $
               endif $ norsgx>0
               if ( norfgx>0 ) then $
                  partn    k4ggf,vgfdf,/k4fgg,,, $
                  paraml   k4fgg//'null'////s,n,nok4fgg $
                  if ( nok4fgg>-1 ) smpyad   rfgx,k4fgg,rfgx,,,/
                                             k4fdd/3////1////6 $
               endif $ norfgx>0
               MERGE    k4sdd,,,k4fdd,VXFS,/k4ddf1///6 $
            else $
               partn    k4ggf,vgfd,/,,,k4fdgg $
               if ( norgdfd>0 ) then $
                  smpyad   rgdfd,k4fdgg,rgdfd,,,/k4ddf1/3////1////6 $
               else $
                  equivx   k4fdgg/k4ddf1/-1 $
               endif $ norgdfd>0
            endif $ fs
            if ( acsyml ) then $
               mpyad    k4ddf1,idd,k4dd/k4ddf/////6 $
            else $
               call xadd5  k4ddf1,k4dd,,,/k4ddf/cu/cu/cz/cz/cz $
            endif $ acsyml
         else $
            equivx   k4dd/k4ddf/-1 $
         endif $ NOK4jjf>-1 or NOK4jjnf>-1
      endif $ soltyp='direct' and not(delta)
      $    
      FRLG     CASES,,,FRLi,,,,/
               ,,,FOLi,/
               SOLTYP//APP $
      if ( nfreq=1 ) then $
         equivx   pdfx/pdfi/-1 $
         EQUIVX YBE/YBEI/ALWAYS $
      else $
         zero=abs(frqloop) $
         matgen   ,/cp/4/1/ncol//1/nfreq/zero $
         partn    pdfx,cp,/,,pdfi,/1 $
         PARTN YBE,CP,/,,YBEI,/0 $
      endif $
      if ( not(aero) ) then $
$         FRRD1    CASES,DIT,CKDDf,CBDDf,CMDD,K4DDf,PDFi,FRLi,FOLi,
$                  edt,sild,usetd,/
$                  UDFi,foli1/SOLTYP/-1/////s,n,firstbd0/frrdset/
$                  true $

Type parm,nddl,I,y,ires $ nddl default is -1
$ epsilon check with alter package because it is new technology
type parm,,I,n,iresx=0 $ for production use
                   iresx = ires $
                   if (frqloop>2) iresx = -1 $ do eps for first two freqs only
$ delete the line above to get epsilon for all frequencies
                   call FRRD1b CASES,DIT,CKDDf,CBDDf,CMDD,K4DDf,PDFi,
                     FRLi,FOLi,edt,sild,USETD,,YBEi/UDFi,foli1,QbeGi/
                     SOLTYP/noncup/itseps/itsmax/nskip/zfreq/
                     s,FIRSTbd0/frrdset/True/iresx $
                   APPEND QBEGI,/QBEGX/2 $
      else $
         FRRD2    ckddf,cBddf,cMdd,qhhl,PdFi,FOLi,cases,
                  edt,sild,usetd,/
                  UdFi,foli1/
                  BOV/Q/MACH////frrdset//s,n,firstbd0 $
      endif $ soltyp='direct' and not(delta)
      if ( frqloop=1 ) firstbad=firstbd0 $
      if ( not(frqloop=1 and firstbad) ) then $
      iomega=cmplx(0.,pi(2)*abs(freqval)) $
      if ( acsyml ) then $
         $  Convert fluid velocities to displacements
         PARTN    UdFi,,vxfs/UdFSi,UdFFi,,/1 $ 
         delete   /udfi,,,, $
         add      udffi,/udffi1/iomega $
         merge    UdFSi,UdFFi1,,,,vxfs/UdFi/1 $ 
      endif $ acsyml
      if ( nfreq=1 ) then $
         equivx   udfi/udfx/-1 $
      else $
         merge    ,,,udfi,,cp,/udfi0/1 $
         if ( frqloop=1 ) then $
            equivx   udfi0/udfx/-1 $
         else $
            add5     udfi0,udfx,,,/udf1 $
            equivx   udf1/udfx/-1 $
         endif $
      endif $ nfreq=1 
      $    
      if ( (nobjjf>-1 or nokggf1>0) and (dospcffd or dompcffd) ) then $
         call xadd5  kggf1,bggf,,,/xggf/cu/iomega/cz/cz/cz $ 
         partn    xggf,vgfd,/,,,xggf1 $
         mpyad    rgdfd,udfi,/ugfi $
         mpyad    xggf1,ugfi,/qqgfi $
         if ( nfreq=1 ) then $
            equivx   qqgfi/qqgfx/-1 $
         else $
            merge    ,,,qqgfi,,cp,/qqgfi0/1 $
            if ( frqloop=1 ) then $
               equivx   qqgfi0/qqgfx/-1 $
            else $
               add5     qqgfi0,qqgfx,,,/qqgfx0 $
               equivx   qqgfx0/qqgfx/-1 $
            endif $
         endif $ nfreq=1
      endif $ dospcffd or dompcffd
      endif $ not(frqloop=1 and firstbad)
   ENDDO $ frqloop>=0
   if ( getsys(np,242)<>-1 ) putsys(0,242) $
   $
   equivx   udfx/udf/-1 $
   if ( dompcffd ) mpyad    rmgg,qqgfx,/qmgf/1 $
   if ( dospcffd ) mpyad    rsgg,qqgfx,QBEGX/qsgf/1 $
else $
   if ( not(aero) ) then $
$      FRRD1    CASES,DIT,CKDD,CBDD,CMDD,K4DD,PDFx,FRL,FOL,
$               edt,sild,usetd,/
$               UDF,fol1/
$               SOLTYP/-1/////s,n,firstbad/frrdset $

Noncup=-1 $ v70.7 value
if (debug='yes') then $
  message //'inputs to 2nd frrd1' $
  matprn CKDD,CBDD,CMDD,k4dd,pdf// $
  matprn K4DD,PDFX,FRL,FOL,ybe// $
endif $
iresx = ires $ is this needed because of an exec error?
call FRRD1b CASES,DIT,CKDD,CBDD,CMDD,K4DD,PDF,FRL,FOL,edt,sild,
    USETD,,YBE/UDF,fol1,QbeG/
    SOLTYP/noncup/itseps/itsmax/nskip/zfreq/s,FIRSTBAD/frrdset/
    Freqdep/iresx $


   else $
      FRRD2    ckdd,cBdd,cMdd,qhhl,PdFx,FOL,cases,
               edt,sild,usetd,/
               UdF,fol1/
               BOV/Q/MACH////frrdset//s,n,firstbad $
   endif $ soltyp='direct' and not(delta)
   if ( firstbad ) equivx   fol1/fol/-1 $
   $
   $  For distributed Lanczos, we need to skip here 
   $  because the subsequent PARTN fails on slaves
   $  because the VXFS is not consistent with the UDF.
   $
   if ( acsyml and adjflg<2 and
        not(GETSYS(np,265)>1 and GETSYS(np,197)>0) ) then $
      $ Multiply fluid velocity potentials by i*omega 
      $ in order to get fluid pressure (displacements)
      IF (NOA<0) THEN $
         EQUIVX VXFS/VDFS/ALWAYS $
      ELSE $
         UPARTN USETD,VXFS/VDFS,,,/'P'/'D'//1 $
      ENDIF $
      PARTN    UdF,,vDfs/UdFS,UdFF,,/1 $ 
      delete   /udf,,,, $
      DSAP     ,,udff,,fOL,/udff1/APP $
      merge    UdFS,UdFF1,,,,vDfs/UdF/1 $ 
   endif $ acsyml
   purgex   /qmgf, ,,,/-1 $ QSGF REMOVED
   EQUIVX QBEG/QSGF/ALWAYS $
endif $ freqdep 
$
if ( firstbad ) then $
   paraml   ppf//'trailer'/1/s,n,nloads $
   matgen   ,/col1/6/nloads/0/1 $
   partn    ppf,col1,/ppf1,,,/1 $
   equivx   ppf1/ppf/-1 $
endif $ firstbad
$
IF ( not(delta) and Fourier ) THEN $
   IFT      UdF,CASES,TRL,FOL/
            UHT1,TOL1/IFTM $
   EQUIVX   TOL1/FOL/-1 $
   EQUIVX   UHT1/UdF/-1 $
ENDIF $ soltyp='modal' and FREQY>=0 
$
return $
end $ freqrs

$ remove max error output
COMPILE SOLCHK nolist NOREF $
$       $       $       $       $       $       $       $	SOLCHK
SUBDMAP SOLCHK M,B,K,UU,PP,FOL/RESID1X/APP/IRESX/maxeps $
$ SOLUTION CHECKER. R= P-[K*DISPL + B*VELO + M*ACCEL], R SHOULD BE ZERO
$ RESID1X IS UNFILTERED R.  IT MAY BE PURGED.
$ MODES CALL: CALL SOLCHK M,,K,PHI,,LAMA/RPHI/'REIG    '/0
$ USE /-1 FOR LAST PARAM TO BLOCK PRINT OF RESIDUAL VECTOR4
$ PLACE IN BOTH MODERS AND SEMR3 SUBDMAPS, SOLS 103, 110-112
$
$ TRANS CALL: CALL SOLCHK M,B,K,U,P,TOL/RU/'TRANRESP'/0
$ PLACE IN EITHER DTRANRS OR MTRANRS SUBDMAPS, FOR SOLS 109, 112
$
$ FREQ CALL: CALL SOLCHK M,B,K,U,P,FOL/RU/'FREQRESP'/0
$ PLACE IN EITHER DTRANRS OR MTRANRS SUBDMAPS, FOR SOLS 108, 111
$ CEIGEN CALL:  CALL SOLCHK M,B,K,U,,CMLAMA/RU/'CEIGEN  '/0
$ PLACE IN SOL 107 AND SOL 110
$ STATICS CALL:  CALL SOLCHK, ,,K,U,P,/RU/'STATICS'/0
$ PLACE IN SELR, SELRRS, OR SEKRRS.  SEKRRS CALL FOLLOWS:
$ CALL SOLCHK, ,,KLL,DM,KLR,/RU/'STATICS'/-1 $
TYPE PARM,,CHAR8,N,APP $
TYPE PARM,,RS,N,MAXRES $ LARGEST TERM IN RESIDUAL VECTOR
type parm,,rs,n,maxeps $ max epsilon for output
TYPE PARM,,RS,N,ZEROTOL=1.-5,EPSILON $ FILTER CRITERION FOR MAXRES
TYPE PARM,,I,N,COLLIMIT=10,CMP,NP2 $ LIMIT ON NUMBER OF SOLUTION VECTORS CHECKED
TYPE PARM,,I,N,IRESX $ MODULE CALLER OPTION TO SKIP SOLUTION CHECK
TYPE PARM,NDDL,I,Y,IRES $ USER REQUEST SOLUTION RESIDUAL CHECK.
$ OVER-RULES IRESX.  NDDL DEFAULT IS -1
TYPE PARM,,CHAR3,Y,SKIPEPS='NO ' $ OPTION TO SKIP EXPENSIVE EPSILON CALCS.
IF (SKIPEPS='YES') RETURN $
PARAML  UU//'PRESENCE'//S,N,NOU $
IF (NOU = -1) THEN $
  MESSAGE //'USER FATAL MESSAGE FROM SOLCHK SUBDMAP. '/
            ' NO SOLUTION VECTORS ARE PRESENT.  LOOK FOR SIMILAR '/
     'FATAL MESSAGES ABOVE FOR DETAILS.' $
  RETURN $
ENDIF $
PARAML UU//'TRAILER'/1/S,N,NSOLS $ NUMBER OF COLUMNS OF RESIDUAL VECTOR
IF (APP><'TRANRESP') THEN $
  IF (NSOLS>COLLIMIT) THEN $
    CMP = NSOLS - COLLIMIT
    MATGEN, /VRED/6/NSOLS/0/COLLIMIT/CMP $ 1. IN FIRST COLLIMIT ROWS,
    $ ZERO IN REMAINDER.
    PARTN UU,VRED,/,,U,/0 $ LIMIT THE NUMBER OF VECTORS PROCESSED
    PARTN PP,VRED,/,,P,/0 $
  ELSE $
    EQUIVX UU/U/ALWAYS $
    EQUIVX PP/P/ALWAYS $
  ENDIF $ NSOLS
  IF (APP><'STATICS') THEN $
    MPYAD    M,U,/MU $
    IF ( APP<>'REIG    ') MPYAD    B,U,/BU $
    MPYAD    K,U,/KU $
    $ CALL DSAPL MU,BU,KU,FOL,/FTOTAL/APP $
    dsap mu,bu,ku,fol,/ftotal/app $
    ADD FTOTAL,P/RESID1/-1.0 $
  ELSE $ STATICS FOLLOWS
    MPYAD K,U,P/RESID1//-1 $ R=P-KU
    EQUIVX P/PX/ALWAYS $
    EQUIVX U/UX/ALWAYS $
  ENDIF $
  IF (APP='REIG    ' OR APP='CEIGEN') ADD MU,KU/P $ DOMINATED BY MU
  $ NEAR ZERO FREQ, KU AT HIGH FREQ
ELSE IF (APP='TRANRESP') THEN $
  DSAR     UU,FOL,FOL,/DISP1,VELO1,ACCE1,,/0 $ ALL COLS MUST BE PRESENT
  PARAML DISP1//'TRAILER'/1/S,N,NSOLS $ NUMBER OF COLS OF RESIDUAL VECTOR
  IF (NSOLS>COLLIMIT) THEN $
    CMP = NSOLS - COLLIMIT
    MATGEN, /VRED/6/NSOLS/0/COLLIMIT/CMP $ 1. IN FIRST COLLIMIT ROWS,
    $ ZERO IN REMAINDER
    PARTN DISP1,VRED,/,,U,/0 $ LIMIT THE NUMBER OF VECTORS PROCESSED
    PARTN VELO1,VRED,/,,VELO,/0 $ 
    PARTN ACCE1,VRED,/,,ACCE,/0 $ 
  ELSE $							SOLCHK
    EQUIVX DISP1/U/ALWAYS $
    EQUIVX VELO1/VELO/ALWAYS $
    EQUIVX ACCE1/ACCE/ALWAYS $
    EQUIVX PP/P/ALWAYS $ THIS P HAS AN EXTRA COLUMN
  ENDIF $ NSOLS
$ THROW AWAY FIRST TWO COLUMNS OF EVERYTHING TO AVOID IC PROBLEM
  IF (NSOLS>3) THEN $
    PARAML U//'TRAILER'/1/S,N,NCOLS
    IF (NCOLS<2) JUMP NEVERMIN $
    NP2 = NCOLS-2 $ LOCAL REDEFINITION
    MATGEN ,/VT/6/NCOLS/2/NP2 $ 
    PARTN U,VT,/,,UTEMP,/1 $ CLEAN UP SOMEDAY
    EQUIVX UTEMP/U/ALWAYS $
    PARTN VELO,VT,/,,VELOT,/1 $
    EQUIVX VELOT/VELO/ALWAYS $
    PARTN ACCE,VT,/,,ACCET,/1 $
    EQUIVX ACCET/ACCE/ALWAYS $
    PARAML P//'TRAILER'/1/S,N,NCOLS $
    NP2 = NCOLS-2 $ LOCAL REDEFINITION
    MATGEN ,/VT1/6/NCOLS/2/NP2 $
    PARTN P,VT1,/,,PTEMP,/1 $
    EQUIVX PTEMP/P/ALWAYS $
    LABEL NEVERMIN$
  ENDIF $ NSOLS
  MPYAD M,ACCE,/FINERT $ 
  MPYAD B,VELO,/FVISC $
  MPYAD K,U,/FSTAT $
  DIAGONAL FINERT/FINABS/'WHOLE'/1.0 $ ABS VALUE
  DIAGONAL FVISC/FVIABS/'WHOLE'/1.0 $ ABS VALUE
  DIAGONAL FSTAT/FSTABS/'WHOLE'/1.0 $ ABS VALUE
  ADD5 FINABS,FVIABS,FSTABS,,/FTOTABS $ SUM OF INTERNAL FORCES
  ADD5 FINERT,FVISC,FSTAT,,/FTOTAL $
  ADD FTOTAL,P/RESID1/-1.0 $ TRUNACATE LAST COL OF P 
ELSE $ UNSUPPORTED CALL FOLLOWS
  MESSAGE //'SYSTEM WARNING MESSAGE'/
     'OPTION '/APP/' NOT SUPPORTED FOR SOLCHK SUBDMAP. ' $
  RETURN $
ENDIF $
EQUIVX RESID1/RESID1X/ALWAYS $ AVOID CALL PURGE OF RESID1
PARAML U//'TRAILER'/2/S,N,NROWS $ NUMBER OF ROWS OF SOLUTION VECTORS
MATGEN, /SUMMER/6/NROWS/0/NROWS $ USED TO SUM TERMS
PARAML RESID1//'TRAILER'/5/S,N,NZWDSR
IF (NZWDSR=0) THEN $
MESSAGE //'UIM.  THE RESIDUALS OF FIRST TEN SOLUTIONS (EPSD) ARE NULL'/
     'EPSD MATRIX WILL NOT BE PRINTED.' $
  RETURN $
ENDIF $
$NORM RESID1/VECRES///S,N,MAXRES/1 $
$MESSAGE //'MAXIMUM ERROR TERM IS'/MAXRES $
MATMOD U,,,,,/UF,/2////1.E-10 $ DISCARD SMALL NUMBERS
ADD RESID1,UF/DWORK///1 $ ELEMENT MULTIPLY
MPYAD DWORK,SUMMER,/DDWORK/1 $ DIAG TERMS OF TRNSP(RESID1)*UF
ADD P,FTOTABS/P1 $ ONLY TRANS MAKES FTOTABS
ADD P1,UF/WORK///1 $ ELEMENT MULTIPLY
MPYAD WORK,SUMMER,/DIAGWORK/1 $ DIAG TERMS OF TRNSP(P3)*UF
ADD DDWORK,DIAGWORK/EPS///2 $ ELEMENT DIVIDE
DIAGONAL EPS/EPSD/'WHOLE'/1.0 $ MAGNITUDE
NORM EPSD/SCRX///S,N,MAXEPS// $
MATPrn EPSD// $
MESSAGE //'LOAD EPSILONS FOR FIRST'/COLLIMIT/
     ' SOLUTIONS FOR '/APP/'  IN EPSD ABOVE.' $
MESSAGE //'USER INFORMATION MESSAGE. '/
       'MAXIMUM EPSILON FOR '/APP/' IS'/MAXEPS $
IF (IRES<>-1) IRESX = IRES $
IF (IRESX<0) RETURN $
PARAML RESID1//'TRAILER'/1/S,N,NSOLS $
IF (NSOLS>1) THEN $
  MATGEN ,/VSUM/6/NSOLS/0/NSOLS $ UNIT VECTOR
  MPYAD RESID1,VSUM,/RESID2 $ SUM OF FIRST COLLIMIT ROWS
ELSE $
  EQUIVX RESID1/RESID2/ALWAYS $
ENDIF $
MATMOD  RESID2,,,,,/RESID,/2////ZEROTOL $ FILTER OUT SMALL TERMS
NORM RESID/SCRY///S,N,MAXRES// $
MESSAGE //'MAGNITUDE OF LARGEST TERM IN MATRIX RESID BELOW IS '/
     MAXRES $
MATPrn RESID// $
MESSAGE //'SUM OF RESIDUAL VECTORS OF FIRST '/COLLIMIT/
     ' SOLUTIONS FOR '/APP/' ABOVE.' $
RETURN $
END $ SOLCHK

$ add read for dva
$ file sedfreqb.txt
compile sedfreq nolist noref $
$       $       $       $       $       $       $       $       sedfreqb
alter 'dmapno' $
call schkb //true/dmapno $ mark the database ok for rflag alter
alter 'frlg ' $
MTRXIN, ,MATPOOLs,EQexins,,/DVA,,/LUSETs/S,N,NODVA $ 
Call dbstore ,,dva,,,//0/0/'     '/0 $
$ end of sedfreqb alter

$ fs block removed
compile phase0 nolist noref $
$	$	$	$	$	$	$	$	phase0b
alter 744 $ after one of the gp1's
alter 'pvtx' $
call schkb //false/dmapno $ mark database as ok for rflaga. alter
alter 'gp4' $
paraml casew//'dti'/1/160//s,n,nonlinid $
if (nonlinid>0) then $ for direct tran. Resp.
  message //'user fatal message.  This alter package does not support'/
  ' the nolin capability.  Remove the nonlin entry from case control.'
  exit $
endif $
$ end of phase0 alter

$ modernized read module call
$ file cmpmodeb.txt
compile cmpmode noref $ $	$	$	$	$	cmpmode
alter ' NOYSET=-1 ' $
$type parm,,i,n,ndes $ auto selection of number of modes
dynred=0 $ block gdr
$alter 's,n,methtyp'(,1) $
if (lanczos=0) then $ non-lanczos method selected
  message //'user information message.  non-lanczos method selected. '/
   'only Lanczos method supported by alter package.' $
  message //'Method changed to Lanczos' $
endif $
lanczos = -1 $ force lanczos
methtyp = 1 $ avoid auto-omit
alter '/vyxw,/','' $ avoid auto-omit  default for noared=-1
if (false) MATMOD   MYY,KYY,,,,/VYXW,/12/S,N,NOARED/NMAT $
$ list outputs to satisfy compiler, but never execute
alter 84,84 $ hardwire lanczos
type parm,,I,n,sid=-2 $ SAYS USE THE EIGRL FIELD, BUT UPDATE IT WITH METHOD, 
$ OTHER DATA THAT MAY BE INPUT AS PARAMS INTO READ MODULE
READ     CMKXX,CMMXX,,,DYNAMICS,USET,CASES,VYXW,SILS,USET,,,EQEXINS/         
         CMLAMA,CMPHIXZ,CMMI,CMOEIGS,EIGVMATS,/                              
         'MODE'/S,N,NOZSET//METHF/CMSET/SID/'lan' $ methc disabled                              
$ end cmpmode alter
echoon $
$ end rflaga alter package