$
$     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.                                
$
echooff $
$
$   evdsa.v707 -  updated for v707 -- 08-18-99 (shz)
$
$   This is converted from evdsa.v705 for SOL 200.
$
COMPILE LEIGDER list $ 
SUBDMAP LEIGDER PHIA,PHIG,LAMA,CASES,KGG,MGG,
        KELMDS, KDICTDS, MELMDS, MDICTDS, DSPT1, TABDEQ //
        RESTART/DB $
TYPE PARM,,I,N,RESTART $ USED TO FORCE EXECUTION ON RESTART
$ PHIA AND PHIG ARE EIGENVECTOR MATRICES.  
$+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
$                                                                      +
$    COMPUTE EIGENVECTOR DERIVATIVES IN DESIGN SENSITIVITY ANALYSIS    +
$    USING FOX'S METHOD AND INVERSE ITERATION                          +
$    WRITTEN BY G. HIGH.  EXTENDED TO STRUCTURED SOL. SEQS. BY         +
$    M. GOCKEL AUG 93                                                  +
$+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
$ UPDATES:  25 AUG.  FIX RESTARTS, PRINT ITERATION COUNT, COSMETICS
$ CHANGE ITMAX DEFAULT TO 10
$ 27 AUG REPLACE SDR1 WITH APPEND
$ DO SOMEDAY.  AUTO SHIFT, GSORTH WITH MATMOD 21, 
$ WEIGHT CONVERGENCE FOR LOWER MODES, TRUNCATE NULL COLS. OF DSESM
$ REVIEW OUTPUT OPTIONS
FILE  DSEGX=APPEND/DPHIA0=OVRWRT $
$
TYPE  PARM,,I,N,(RECNO,MODE,DESIGN,DVID,NMAX,
      NOOSET,NOQSET,NOMSET,ITERCNT,NULLDM,CONV) $
TYPE  PARM,,CS,N,CDB $
TYPE  PARM,,RS,N,(DELB,DB,ERR) $
TYPE  PARM,,CHAR5,N,MODNAME $
TYPE  PARM,,I,N,ITTOTAL $ TOTAL NUMBER OF ITERATIONS
TYPE  PARM,,I,N,SCR $ USED TO FORCE RESTART.  VALUE NOT USED.
type  parm,,char3,y,kortho='no ' $ added for v68
$ if yes, orthog wrt stiffness rather than mass
$ still in development.  May cause overflow.  Use not recommended.
$ BULK DATA PARAM INPUT
$
TYPE  PARM,,I,Y,(ITMAX=10,IUNIT=11) $
TYPE  PARM,,CHAR8,Y,(ITRPRNT='NO',ITERATE='YES') $
TYPE  PARM,,RS,Y,TOL=1.E-4 $
TYPE  PARM,,RS,Y,LAMBDAS=0.0 $ SHIFT FACTOR
TYPE PARM,,CS,N,CLAMBDAS $
$ DATABLOCKS RETREIVED FROM THE DATA BASE
TYPE DB EQEXINS,ECTS,EPT,EST,DIT $ VARIOUS TABLES
TYPE DB MPT,CSTM,GEOM2S,USET,SILS,GPLS,CSTMS,BGPDTS $
TYPE DB GM,GOAT,MELM,MDICT $ VARIOUS MATRICES
TYPE DB KELM,KDICT $
$ #####################################################################
$                       DATA INPUT SECTION
$ #####################################################################
$       DESIGN SENSITIVITY MODES   /  18/JAN/89
$
PARAML  USET//'USET'//////'M'/S,N,NOMSET/'O'/S,N,NOOSET/
        'S'/S,N,NOSSET/'Q'/S,N,NOQSET/'G'/S,N,NOGSET $
PARAML  USET//'USET'//////'T'/S,N,NOTSET/'R'/S,N,REACT/'C'/S,N,NOCSET/
                        'A'/S,N,NOASET/'B'/S,N,NOBSET $
IF (NOQSET>-1) THEN $
  MESSAGE //'ALTER FATAL ERROR.  Q-SET NOT SUPPORTED.' $
  EXIT $
ENDIF $
$
$ SPECIFY THE DOF'S THAT ARE TO BE OUTPUT
$
paraml cases//'dti'/1/161//s,n,partnset $ %%%
if (partnset>0) then $ %%%
  MATMOD  EQEXINS,USET,SILS,CASES,,/PDOFG,/17/128/1/S,N,NOPDOF $
  $ vector with 1.0 for selected output stations
else $ %%%
  matgen, /pdofg/6/nogset/0/nogset $ unit vector
endif $ %%%
$message //'after matmod in leigder'
$ G-SIZE VECTOR DEFINING DOF TO BE PRINTED
IF (NOOSET>-1) THEN $
  UPARTN USET,PDOFG/PDOFA,,,/'G'/'A'/'S'/1 $ REDUCE IF O-SET
ELSE $
  EQUIVX PDOFG/PDOFA/ALWAYS $
ENDIF $
$
EQUIVX CASES/XCASES/ALWAYS $ COPY TO AVOID INPUT TWICE RULE
$
PARAML   phig//'trailer'/1/s,n,nmod $
PARAML   TABDEQ//'TRAILER'/1/S,N,NDV $
upartn   uset, KGG/ Kaa, , , /'G'/'A'/'S' $ 
upartn   uset, MGG/ Maa, , , /'G'/'A'/'S' $ 
IF (LAMBDAS<>0.0) THEN $ SHIFT THE MATRIX TO BE DECOMPOSED
  CLAMBDAS=CMPLX(LAMBDAS)
  ADD KAA,MAA/K//CLAMBDAS $
ELSE $
  EQUIVX KAA/K/ALWAYS $
ENDIF $
DECOMP  K/L,,/ $ FACTOR OF SHIFTED STIFFNESS MATRIX
$
DSVG1   KDICTDS,KELMDS,BGPDTS,SILS,CSTMS,KDICT,KELM,
        PHIG,,lama,DSPT1/DKALLG///1/0 $ STATIC FLAG WITH NO SCALING
PARAML  MDICTDS//'PRESENCE'////S,N,NOMDKDS=0 $
DSVG1   MDICTDS,MELMDS,BGPDTS,SILS,CSTMS,MDICT,MELM,
        PHIG,,lama,DSPT1/DMALLG//V,Y,WTMASS/1/0 $  STATIC FLAG WITH NO SCALING
$ [DKALLG] = [DKGG] [PHIG], [DMALLG] = [DMGG] [PHIG]
$ FORM DKPHH = [PHIG]T [DKGG] [PHIG] AND DMPHH = [PHIG]T [DMGG] [PHIG]
$ TO BE USED LATER
$
MPYAD   PHIG,DKALLG,/DKPHH/1 $
MPYAD   PHIG,DMALLG,/DMPHH/1 $
$
$CALL    LOCREC EDOM//S,RECNO $ LOCATE RECORD ID=404 IN EDOM
$CALL    BIDDB  EDOM/BID,DELTB/RECNO/S,NDV $ FORM {BID},{DELTB}
$
$ FORM DIAGONAL [LAMBDA0] MATRIX, AND [LAMAD] MATRIX
$
CALL    LAMAS LAMA/LAMAD,LAMBDA0/S,NMOD $ LAMBDA0 IS THE EIG. MATRIX, DIAG.
$
$ SUBTRACT LAMBDAS FROM LAMA
IF (LAMBDAS<>0.0) THEN $
  DIAGONAL LAMBDA0/IHH/'SQUARE'/0.0 $ IDENTITY MATRIX
  ADD LAMBDA0,IHH/LAMBDA0S//CLAMBDAS $ LAMBDA0S IS THE ROOT MATRIX SHIFTED,
ELSE $
  EQUIVX LAMBDA0/LAMBDA0S/ALWAYS $
ENDIF $
$ FORM BOOLEAN MATRIX FOR USE IN GRAM-SCHMIDT ORTHOGONALITY
$
MATGEN   ,/IDENRM/1/NMOD $ GENERATE AN IDENTITY MATRIX OF ORDER NMOD
MATGEN   ,/B1/4/NMOD/NMOD/0/NMOD/0/1/1/NMOD $ PATTERN MATRIX, ALL TERMS
$ ABOVE DIAGONAL NON-ZERO
DIAGONAL B1/B2/'WHOLE'/0.0 $ RAISE TO 0TH POWER.  ALL TERMS ABOVE DIAGONAL
$ ARE -1.0
ADD      B2,IDENRM/B3/(-1.0,0.0) $ [B3] = -[B2] + [I]
TRNSP    B3/BOOL $
$
if (kortho='yes') then $
  mpyad kaa,phia,/kaph $ [kaph] =  [kaa] [phia]
  MPYAD    PHIA,kAPH,/R1/1 $ [R1]   = [PHIA]T [kAPH]
else $
  MPYAD    MAA,PHIA,/MAPH $  [MAPH] = [MAA] [PHIA]
  MPYAD    PHIA,MAPH,/R1/1 $ [R1]   = [PHIA]T [MAPH]
endif $
$
ADD      R1,BOOL/R2///1 $ E X E MULTIPLY [R2] = [R1](*)[BOOL]
ADD      IDENRM,R2/ROT  $ [ROT] = [I] + [R2], EQN 15, REF. 1
TRNSP    R1/R1T $
MATMOD   R1T,,,,,/R2X,D2X/21 $ EXTRACT LOWER TRIANGLE AND DIAGONAL
$
$ GENERATE A VECTOR OF ONES {ONE} FOR USE IN ERROR SUBDMAP
$
MATGEN   ,/ONE/6/NOASET/0/NOASET $
$
NMAX   = NMOD*NDV $
DESIGN = 1 $
$---------------------------------------------------------------------
$
$ START THE LOOP FOR ALL DESIGN VARIABLES
$
$---------------------------------------------------------------------
$
DO WHILE (DESIGN <= NDV) $
  CDB  =  CMPLX(1.0/DB) $
$
$ FORM [DKPHIG],[DMPHIG] FOR DV
$
CALL DKDM   DKALLG,DMALLG,DKPHH,DMPHH/DKPHIG,DMPHIG,DKPHJ,DMPHJ/
            NMOD/NMAX/S,DESIGN $
$
$ REDUCE [DMPHIG] TO A-SET
$
UPARTN USET,DMPHIG/DMPHIA,,,/'G'/'A'/'S'/1 $
$
$ USE FOX'S METHOD TO GET AN INITIAL [DPHIG] MATRIX
$
CALL FOX PHIG,DKPHJ,DMPHJ,LAMBDA0,LAMAD/DPHIG0,DLAM/S,NULLDM $
IF(ITERATE = 'YES') THEN $
UPARTN USET,DPHIG0/DPHI0A,,,/'G'/'A'/'S'/1 $ S IS COMPLEMENT
UMERGE1 USET,DPHI0A,,,/DPHIXG/'G'/'A'/'S'/1 $
$ TEMPRARY COMMENT OUT
$ MATGPR  GPLS,USET,SILS,DPHIXG//'H'/'G' $ PRINT G-SIZE DPHIG MATRIX
$ MESSAGE //'   ' $
$ MESSAGE //' INITIAL STARTING VECTORS: FOX"S METHOD' $
$ MESSAGE //'   ' $
ENDIF $
$
$ REDUCE [DPHI0G] TO A-SET
$
UPARTN USET,DPHIG0/DPHIA0,,,/'G'/'A'/'S'/1 $ S IS THE COMPLEMENT SET HERE
$
$ FORM CONSTANT PART OF RHS
$
SMPYAD  MGG,PHIG,DLAM,,,/F1/3  $ [F1]=[MGG][PHIG][DLAM]
MPYAD   DMPHIG,LAMBDA0,F1/F2       $ [F2]=[F1]+[DMGG][PHIG][LAMA]
ADD5    F2,DKPHIG,,,/FG//(-1.0,0.0)  $ [FG]=[F2] - [DKGG][PHIG]
$
$ REDUCE TO A-SET
IF (NOMSET>-1) THEN $
  UPARTN USET,FG/FM,FN1,,/'G'/'M'/'N'/1 $
  MPYAD GM,FM,FN1/FN/1 $
ELSE $
  EQUIVX FG/FN/ALWAYS $
ENDIF $
IF (NOSSET>-1) THEN $
  UPARTN USET,FN/FS,FF,,/'N'/'S'/'F'/1
ELSE $
  EQUIVX FN/FF/ALWAYS $
ENDIF $
IF (NOOSET>-1) THEN $
 UPARTN USET,FF/FO,FA1,,/'F'/'O'/'A'/1
 MPYAD GOAT,FO,FA1/FA/1/ $
ELSE $
  EQUIVX FF/FA/ALWAYS  $
ENDIF $
EQUIVX FA/FF/ALWAYS $ SUBSTITUTE FA FOR FF BEYOND THIS POINT
$ INITIAL ERROR INDICATOR
$
EQUIVX DPHIA0/DPHIAZ1/always $
EQUIVX   FF    /FFZ1/always $
CALL ERROR ONE,KAA,MAA,LAMBDA0,FFZ1,DPHIAZ1//S,ERR $
MESSAGE //' ' $
MESSAGE //'ERROR NORM AT ITERATION:'/0/' ERR = '/ERR $
MESSAGE //' ' $
$****
$ MAIN LOOP TO SOLVE USING RESIDUAL FLEXIBILITY
$****
IF(ITERATE = 'NO') JUMP CONVER $ SKIP ITERATIONS
  ITERCNT = 0 $
  DO WHILE (ITERCNT < ITMAX)    $ LOOP ITMAX TIMES
    ITERCNT= ITERCNT+1 $
$
$ SOLVE [KAA] [DPHIA1] = [ F(DPHIA0) ] = [FAA] + [MAA][DPHIA0][LAMA]
$
$ ADD SHIFT TO BOTH SIDES, -LAMBDAS*[MAA][DHIA]
$
    CALL RESID FF,MAA,DPHIA0,LAMBDA0S,L/DPHIA1/S,SCR $
$
$ PERFORM G-S ORTHOGONALIZATION AND MASS NORMALIZATION
$
if (kortho='yes') then $ iterate by stiffness
  CALL GSORTHO DPHIA1,kAPH,DkPHJ,PHIA,BOOL,ROT//S,NULLDM  $
else $ iterate by mass
  CALL GSORTHO DPHIA1,MAPH,DMPHJ,PHIA,BOOL,ROT//S,NULLDM $
endif $
$
$ CHECK FOR CONVERGENCE
$
$   MPYAD    DPHIA1,DSESM,/DPHIAZ2 $
    EQUIVX   DPHIA1 /DPHIAZ2/always $
    CALL ERROR ONE,KAA,MAA,LAMBDA0,FFZ1,DPHIAZ2//S,ERR $
    MESSAGE //'ERROR NORM AT ITERATION:'/ITERCNT/' ERR = '/ERR $
    IF(ERR < TOL) THEN $
       MESSAGE //'   ' $
       MESSAGE //'   CONVERGENCE AFTER '/ITERCNT/' ITERATIONS' $
       MESSAGE //'   ' $
       ITTOTAL=ITTOTAL + ITERCNT $
       JUMP CONVER $
    ENDIF $
$
    IF(ITERCNT = ITMAX) JUMP NOCONV $
    COPY  DPHIA1/DPHIA0/ALWAYS $ UPDATE NEW VECTOR
    IF(ITRPRNT = 'YES') THEN $
       MESSAGE //'   ' $
       MESSAGE //'DPHIA AT ITERATION:'/ITERCNT $
       MESSAGE //'   ' $
       PARTN   DPHIA0,,PDOFA/,DPHIY,,/1 $
       MERGE   ,,DPHIY,,,,PDOFA/DPHIYY/1 $
       MATGPR  GPLS,USET,SILS,DPHIYY//'H'/'A' $ PRINT A-SIZE DPHIA1 MATRIX
    ENDIF $
$
   ENDDO $
$**
$ NO CONVERGENCE
$**
   LABEL NOCONV $
   MESSAGE //' ' $
   MESSAGE //'CONVERGENCE NOT ACHIEVED AFTER '/ITMAX/' ITERATIONS' $
   MESSAGE //' ' $
$**
$ CONVERGENCE
$**
  LABEL CONVER $
$***
$ RECOVER TO G-SET
$***
  EQUIVX   DPHIA1/DPHIF/NOQSET $
$  IF (NOQSET >= 0) MERGE  ,,DPHIA0,,,,PVFA/DPHIF/1 $
  EQUIVX   DPHIF/DPHIN/NOSSET $
  IF(NOSSET >= 0) UMERGE USET,DPHIF,/DPHIN/'N'/'F'/'S'/1 $
  EQUIVX   DPHIN/DPHIG/NOMSET $
  IF(NOMSET >= 0) THEN $
    MPYAD  GM,DPHIN,/DPHIM/ $
    UMERGE USET,DPHIN,DPHIM/DPHIG/'G'/'N'/'M'/1 $
  ENDIF $
$
$ PRINT OUT FINAL SET
$
  ADD5    DPHIG,,,,/DPHIGB/CDB   $ DPHIGB = DPHIG/DELTAB
  EQUIVX  DPHIGB/DPHI/always $
  UPARTN USET,DPHI/DPHIZ,,,/'G'/'A'/'S'/1 $
  UMERGE1 USET,DPHIZ,,,/DPHIZZ/'G'/'A'/'S'/1 $
  MATGPR  GPLS,USET,SILS,DPHIZZ//'H'/'G' $ PRINT G-SIZE DPHI MATRIX
  MESSAGE //'   ' $
  MESSAGE //'FINAL EIGENVECTOR SENSITIVITIES FOR DESIGN VARIABLE:'/
              DVID $
  MESSAGE //'   ' $
$
  DESIGN = DESIGN + 1 $
$ IF (NOFORT >= 0) OUTPUT4 DPHI,,,,//0/IUNIT $
$
ENDDO $
MESSAGE //'TOTAL NUMBER OF ITERATIONS IS'/ITTOTAL/
     	' FOR'/NDV/' DESIGN VARIABLES, EIGENVECTOR SENSITIVITY' $
$
RETURN $
END $ LEIGDER.   END EIGENVECTOR DERIVATIVE SOLUTION
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE LOCREC $
SUBDMAP LOCREC EDOM//RECNO $
$
TYPE    PARM,,I,N,(RECNO,CARDID=0) $
RECNO = 0 $
DO WHILE (CARDID <> 404) $
  RECNO = RECNO+1
  PARAML  EDOM//'DTI'/S,N,RECNO/1//S,N,CARDID $
ENDDO $
RETURN $
END $
$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE BIDDB $
SUBDMAP BIDDB  EDOM/BID,DELTB/RECNO/NDV $
$
$ ---FORM {BID} AND {DELTB} VECTORS
$
TYPE  PARM,,I,N,(RECNO,WRDNO,DESIGN=0,NDV) $
TYPE  PARM,,CS,N,(CVAR,CDELB) $
FILE  BID=APPEND/DELTB=APPEND $
$
MATGEN  ,/IDEN1/1/1    $ GENERATE AN IDENTITY MATRIX OF ORDER 1
DO WHILE ( DESIGN <> -1 ) $ LOOP UNTIL END OF RECORD
  PARAML  EDOM//'DTI'/S,N,RECNO/S,N,WRDNO=4//S,N,IVAR $
  WRDNO = WRDNO+3
  PARAML  EDOM//'DTI'/S,N,RECNO/S,N,WRDNO/S,N,DELB $
  CVAR  = CMPLX(IVAR) $
  CDELB = CMPLX(DELB) $
  ADD     IDEN1,/BID1/CVAR $
  ADD     IDEN1,/DELTB1/CDELB $
  APPEND BID1,/BID/2 $
  APPEND DELTB1,/DELTB/2 $
$  SDR1,   ,BID1,,,,,,,,,/,BID,/2/STATICS $
$  SDR1,   ,DELTB1,,,,,,,,,/,DELTB,/2/STATICS $
$
$ --- FIND END OF A DVAR CARD
$
DO WHILE (DESIGN <> -1) $ SKIP VID'S IN THE RECORD
  WRDNO = WRDNO+1 $
  PARAML  EDOM//'DTI'/S,N,RECNO/S,N,WRDNO//S,N,DESIGN $
ENDDO $
$
$ --- CHECK IF END OF RECORD ENCOUNTERED
$
WRDNO = WRDNO+1 $ INCREMENT TO NEXT BID
PARAML  EDOM//'DTI'/S,N,RECNO/S,N,WRDNO//S,N,DESIGN $
ENDDO $
PARAML  DELTB//'TRAILER'/1/S,N,NDV $ NUMBER OF DESIGN VARIABLES
RETURN $
END $
$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE LAMAS $
SUBDMAP LAMAS OLB/LAMAD,LAMA/NMOD $
$
$ FORM DIAGONAL [LAMA] MATRIX, AND [LAMAD] MATRIX
$
TYPE  PARM,,I,N,(MODE=1,NMOD) $
FILE  LAMAT=APPEND $
$
LAMX,   ,OLB/LAMMAT/-1 $
MATMOD  LAMMAT,,,,,/TEMP,/1/1 $ EXTRACT 1ST COLUMN OF [LAMMAT]
$
$ FORM [LAMAD] = [LAMAS - LAMAT] MATRIX
$           |L1 L1 L1 ..... |
$ [LAMAT] = |L2 L2 L2 ..... |
$           |L3 L3 L3 ..... |
$
$           |L1 L2 L3 ..... |
$ [LAMAS] = |L1 L2 L3 ..... |
$           |L1 L2 L3 ..... |
$
MODE = 1 $
DO WHILE ( MODE <= NMOD )    $ LOOP OVER ALL THE EIGENVECTORS
  APPEND TEMP,/LAMAT/2 $
$  SDR1,    ,TEMP,,,,,,,,,/,LAMAT,/2/STATICS $
  MODE = MODE + 1 $
ENDDO $
$
TRNSP    LAMAT/LAMAS $
ADD      LAMAS,LAMAT/LAMAD/(1.0,0.0)/(-1.0,0.0) $
$
DIAGONAL LAMAS/LAMA/'SQUARE' $ GENERATE DIAGONAL MATRIX OF LAMAS
RETURN $
END $
$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE DKDM $
SUBDMAP DKDM DKALL,DMALL,DKPH,DMPH/DKPHI,DMPHI,DKPHJ,DMPHJ/
             NMOD/NMAX/DESIGN
$
$ EXTRACT [DKPHI],[DMPHI] FOR DESIGN VARIABLE
$
TYPE   PARM,,I,N,(NMOD,NMAX,DESIGN,IR1) $
$
$ GENERATE A COLUMN PARTITIONING VECTOR
$
IR1 = (DESIGN-1)*NMOD
MATGEN   ,/CP/6/NMAX/IR1/NMOD/NMAX $
PARTN     DKALL,CP,/,,DKPHI,/1 $
PARTN     DMALL,CP,/,,DMPHI,/1 $
PARTN     DKPH ,CP,/,,DKPHJ,/1 $
PARTN     DMPH ,CP,/,,DMPHJ,/1 $
RETURN $
END $ END DKDM
$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE FOX $
SUBDMAP FOX PHI,D1,D2,LAMA,LAMAD/DPHI0,DLAM/NULLDM $
$
$ USE FOX'S METHOD TO GET AN INITIAL [DPHIA] MATRIX
$
TYPE   PARM,,I,N,NULLDM $
$
MPYAD    D2 ,LAMA,D1/DIJ//-1           $ [DIJ]=[D1]-[D2][LAMA]
ADD      DIJ,LAMAD/XHAT///2 $ DIVIDE DSEGM E BY E WITH LAMAD
$
DIAGONAL D2/COLMN/'COLUMN' $
$
$ CHECK TO SEE IF [D2] IS NULL TO AVOID A FATAL IN MATMOD
$
PARAML   COLMN//'TRAILER'/5/S,N,NZWD $
IF(NZWD = 0) THEN $
  NULLDM = -1 $
  MESSAGE //'USER NOTIFICATION MESSAGE'/1/'NULL DM MATRIX' $
  EQUIVX  XHAT/XD/ALWAYS $
ELSE $
  NULLDM = 1 $
  MATMOD   COLMN,,,,,/XII,/28 $
  ADD      XII,XHAT/XD/(-0.5,0.0) $ ADD -[XII]/2 AND XHAT
ENDIF$
  MPYAD    PHI,XD,/DPHI0     $ [DPHI0] = [PHI]*[XD]
  DIAGONAL DIJ/DLAM/'SQUARE' $ FORM DIAGONAL MATRIX [DLAM]
RETURN $
END $ END FOX
$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE RESID  $
SUBDMAP RESID FF,MAA,DPHIA0,LAMA,L/DPHIA1/SCR $
TYPE PARM,,I,N,SCR $ RESTART FORCERR
$
$ FORM RESIDUAL RHS AND SOLVE
$
$ FORM 1ST ORDER "PSEUDO" LOAD VECTOR [RHS]
$
SMPYAD  MAA,DPHIA0,LAMA,,,FF/RHS/3   $
$
$ SOLVE [KAA][DPHIA1] = [RHS]
$
FBS     L,,RHS/DPHIA1 $
RETURN $
END $ END RESID
$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE GSORTHO $
SUBDMAP GSORTHO DPHIA,MAPH,DR2,PHIA,BOOL,ROT//NULLDM $
$
$ PERFORM G-S ORTHOGONALIZATION AND MASS NORMALIZATION
$
TYPE  PARM,,I,N,NULLDM
$
$ FORM [DR]
$
MPYAD   DPHIA,MAPH  ,/DR1/1    $ [DPHIA]T [MAA] [PHIA]
$ MPYAD   PHIA ,DMPHIA,/DR2/1    $ [PHIA]T [DMAA] [PHIA]
TRNSP   DR1/DR3 $
ADD5    DR1,DR2,DR3,,/DR4/ $
ADD     DR4,BOOL/DR///1 $
$
$ [DPHI] = [DPHI][ROT] + [PHI][DR]
MPYAD   PHIA ,DR,/T1 $
MPYAD   DPHIA,ROT,T1/DPHI $
$
$ NORMALIZE ONLY IF [DM] <> [0]
$
IF(NULLDM >= 0) THEN $
  ADD      DR2,DR3/SCL/(-0.5,0.0)//2 $
  DIAGONAL SCL/SCALE/'SQUARE' $
  MPYAD    DPHI,SCALE,/DPHI2 $
  EQUIVX   DPHI2/DPHIA/ALWAYS $
ELSE $
  EQUIVX   DPHI/DPHIA/ALWAYS $
ENDIF $
RETURN $
END $
$
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
$
COMPILE ERROR  $
SUBDMAP ERROR ONE,KAA,MAA,LAMA,FF,DPHIA//ERR $
$
$ CALCULATE THE ERROR
$
TYPE    PARM,,RS,N,ERR $
$
SMPYAD   MAA,DPHIA,LAMA,,,FF/E1/3 $
MPYAD    KAA,DPHIA,E1/ERR//-1 $
EQUIVX   ERR/ERRN/ALWAYS $
ADD      ERR,ERRN/ERR2///1 $
MPYAD    ONE,ERR2,/L2/1 $
MATMOD   L2,,,,,/LMAX,/7 $ FIND MAX VALUE IN EACH COLUMN
NORM     LMAX/SCR///S,N,ERR $ ERR IS ABS. VALUE OF LARGEST MAG. TERM
RETURN $
END $
$ END OF evds ALTER PACKAGE
echoon $