$ beigpa.v707    alter package for buckling 
$ last revised April 12, 2000  mag
$ automatically shifts to cead module for unsymmetric matrices
$ mag  April 11, 2000
compile nlstatic list noref $
alter 'add5.*apffg' $ before add5 for ndelk
file bug=ovrwrt $ why isn't this an error w/o the alter?  Research
$ OVRWRT didn't solve problem.  Explicit delete added below.
paraml akllr//'presence'////s,n,noak $
paraml bkllr//'presence'////s,n,nobk 
if (noak=-1 or nobk=-1) then $
  message //'ufm.  Two total stiffness matrices not present for '/
   'buckling analysis.' $
  if (noak=-1) message //'no matrix from previous solution' $
  if (nobk=-1) message //'no matrix from this iteration' $
  message //'try iter method if auto method being used now' $
  exit $
endif $   
alter 'call moders','' $
type parm,,rs,n,rut1 $
PARAML   CASesx2//'DTI'/1/5//S,N,METH $
If (meth>0) then $
  delete /blama,bug,,, $ research  
$ this delete should not be needed.  Now fails in looping
  call fstrut kaa1,ndelk,lllt,uuu//s,rut1 $ estimate of lowest root
  call beig uset,casesx2,dynamics,ndelk,kaa1,gpls,sils,dynamics,eqexins/
    bpha,blama,bphal,brutz/rut1 $ call read(sym) or cead(unsym)
endif $

compile beig list noref $
subdmap beig uset,casesx2,dynamics,kd,k,gpls,sils,eed,eqexins/
  bpha,blama,bphal,brutz/rut1 $
$ general purpose buckling solver.  Allows symmetric, unsymmetric matrices
type parm,,logical,n,ktypes,kdtypes $
type parm,,rs,n,rut1 $ approximate first root for setting shifts
paraml k//'trailer'/3/s,n,ktype $ 1 if square, 6 if symmetric
paraml kd//'trailer'/3/s,n,kdtype $
if (ktype=1 or kdtype=1) then $
  call symtest k/ksym/s,ktypes $ force symmetric when dissym small.
  call symtest kd/kdsym/s,kdtypes $
else $
  equivx k/ksym/always $
  equivx kd/kdsym/always $
  ktypes = true $
  kdtypes = true $
endif $
if (ktypes and kdtypes) then $ do a symmetric soln.
    decomp ksym/llsym,, $ get factor for first root calculation 
    CALL MODERS ,        ,USET    ,        ,CASESX2 ,DYNAMICS,                   
      kdsym   ,ksym    ,GPLS    ,SILS    ,EED     ,                   
      EQEXINS ,        ,llsym    /                                     
      BPHA    ,BLAMA   ,        / 
      -1  /'BUCKLING'/FALSE /FALSE   /TRUE    /                   
      -1  /FALSE   /1       /0       $                            
      $ NORSET  /'BUCKLING'/FALSE /FALSE   /TRUE    /                   
      $ NOQSET  /FALSE   /1       /0       $                            
      $ call from sol 107, modified
  else $ must be unsymmetric
$CEAD   KDD,BDD,MDD,DYNAMICS,CASECC,VDXC,VDXR/ $ from tan
$PHID,CLAMA,OCEIGS,PSIC,ROOTS/
$S,N,NFOUND/IDUM/SID/METHOD/EPS/NDES/SHIFTR/
$SHIFTI/MBLKSZ/IBLKSZ/KSTEPS
    rut1 = rut1*1e-5 $ approximate zero shift
    putsys(4,108) $ force lan method even on small problems
    CEAD   k,kd,,dynamics,casesx2,,/
    bpha,bLAMA,OCEIGS,Phil2,Rutz/
    S,N,NFOUND/  /-1/'clan'//1/rut1 $ request one root
    Putsys(0,108) $ reset default
    ofp blama// $
    Norm bpha/bphan $
Endif $ ktypes
Return
End $ beig

Compile symtest list noref $
Subdmap symtest k/ksym/ktypes $
$ test k for symmetry, force symmetric with cavalier averaging if not too unsym
type parm,,rs,y,symcrit=1.e-6 $
type parm,,logical,n,ktypes $
trnsp k/kt $
add5 k,kt,,,/kav/0.5/0.5 $
add5 k,kt,,,/kdif/0.5/-0.5 $
norm kav/scrk///s,n,maxkav $
norm kdif/scrkd///s,n,maxkdif $
$paraml /k/'name'//////s,n,kname $
$ commented out line causes k to disappear.  Must be exec error
if (maxkdif<(symcrit*maxkav)) then $
  message //'passed symmetry test' $
  modtrl kav////6 $ mark as symmetric
  copy kav/ksym/always $
  ktypes = true $
else $ 
  message //'failed symmetry test' $
  ktypes = false
endif $
return
end $ symtest

Compile fstrut list noref $
subdmap fstrut k,m,ll,ul//rut1$
$ find an approxmation to the first root,
$ given k, m, and ll and ul, factors of k
type parm,,rs,n,rut1 $
paraml ll//'presence'////s,n,noll $
if (noll=-1) then $
  decomp k/ll,ul, $
endif $
paraml ul//'presence'////s,n,noul $
type parm,,I,n,sym=2 $ request lh soln
if (noul=-1) sym = -1 $ default for fbs
paraml k//'trailer'/1/s,n,nn $ problem size
matgen ,/rand4/5/4/nn $ 4 random vectors
fbs ll,ul,rand4/rhv $
fbs ll,ul,rhv/lhv/sym $ lh solution if unsym
smpyad lhv,k,rhv,,,/kk/3////1 $
smpyad lhv,m,rhv,,,/mm/3////1 $
CEAD   kk,mm,,,,,/
  bpha,bLAMA,OCEIGS,Phil2,Rutz/
 S,N,NFOUND/ /-1/'hess'//1/.01 $ small shift to kill uw
paraml rutz//'dmi'/1/1/s,n,rut1//s,n,imrut1 $
message //'approximate first root, a + ib'/rut1/imrut1 $
Return $
End $

$ end of beigp alter