setmts.f90

Go to the documentation of this file.

c Version 1.5.1 beta 3/21/96
c----------------------------------------------------------------------
c                    =========================
c                        function SETMTS   
c                    =========================
c
c  Given a set of slow-motional EPR parameters, check the MTS indices
c  and adjust them accordingly.
c
c  Inputs
c    fparmi   Array of floating-point EPR parameters appearing in the
c            order defined in /eprprm/ 
c    iparmi   Array of integer EPR parameters appearing in the
c            order defined in /eprprm/ 
c
c  Output
c    mts     Array to receive the corrected MTS parameters
c              Information is packed as documented in mtsdef.inc
c
c  Returns 0 for successful completion
c          8 if lemx exceeded limit for calculations w/potential
c          9 if mts parameters were changed from those in iparmi array
c
c----------------------------------------------------------------------
      function setmts(fparmi,iparmi,mts)
c
      use nlsdim
      use eprprm
      use errmsg
      use mtsdef
      use maxl
      use rnddbl
c
      implicit none
      double precision fparmi(nfprm)
      integer setmts,iparmi(niprm),mts(mxmts)
c
      integer i
      logical knon0p,changed
c
      integer ipar
      logical isaxial
      external ipar,isaxial
c
c----------------------------------------------------------------------
c     If there is no associated list of basis set indices,
c     check basis set parameters
c----------------------------------------------------------------------
c
      setmts=0
      knon0p = abs(fparmi(ic20+1)).gt.rndoff .or.
     #         abs(fparmi(ic20+2)).gt.rndoff .or.
     #         abs(fparmi(ic20+3)).gt.rndoff .or.
     #         abs(fparmi(ic20+4)).gt.rndoff
c
      do i=1,ntrc
         mts(i)=iparmi(ilemx+i-1)
      end do
c
      mts(nipsi0)=0 
      if ( (abs(fparmi(ipsi)).gt.rndoff .and.
     #     abs(fparmi(ipsi)-1.8d2).gt.rndoff) 
     #    .or. iparmi(inort).gt.1) mts(nipsi0)=1
      mts(nin2)=iparmi(iin2)
c
c    --- Allow antisymmetric K combinations if any tensor has
c        imaginary elements (nonzero alm, gam, ald, or gad)
c
      mts(njkmn)=1
      if (abs(fparmi(ialm)).ge.rndoff .or.
     #    abs(fparmi(igam)).ge.rndoff .or.
     #    abs(fparmi(iald)).ge.rndoff .or.
     #    abs(fparmi(igad)).ge.rndoff) mts(njkmn)=-1
c
c    --- Allow antisymmetric M combinations if there is a nonzero
c        nuclear Zeeman interaction
c
      if (abs(fparmi(igaman)).ge.rndoff .and.
     #    iparmi(iin2).gt.0) then
         mts(njmmn)=-1
      else
         mts(njmmn)=1
      end if

c
      if((iparmi(ilemx).gt.mxlval).and.(ipt.ne.0)) then
         setmts=lemxhi
         iparmi(ilemx)=mxlval
      endif
c
      if (mts(nlemx).gt.mxlval) mts(nlemx)=mxlval
      if (ipar(mts(nlemx)).ne.1) mts(nlemx)=mts(nlemx)-1
      if (ipar(mts(nlomx)).ne.-1) mts(nlomx)=mts(nlomx)-1
      if (mts(nlomx).gt.mts(nlemx)) mts(nlomx)=mts(nlemx)-1
      if (mts(nkmx).gt.mts(nlemx)) mts(nkmx)=mts(nlemx)
      if (mts(nmmx).gt.mts(nlemx)) mts(nmmx)=mts(nlemx)
      if (ipar(mts(nkmx)).ne.1) mts(nkmx)=mts(nkmx)-1
      if (mts(nipnmx).gt.in2) mts(nipnmx)=iparmi(iin2)
      if (mts(nipsi0).eq.0.and.mts(nmmx).gt.mts(nipnmx) )
     #    mts(nmmx)=mts(nipnmx)
      if (mts(njkmn).eq.1) mts(nkmn)=max(mts(nkmn),0)
      if (mts(njmmn).eq.1) mts(nmmn)=max(mts(nmmn),0)
c     
      if(mts(nlemx).lt.0)  mts(nlemx)=0
      if(mts(nlomx).lt.0)  mts(nlomx)=0
      if(mts(nkmx).lt.0)   mts(nkmx)=0
      if(mts(nmmx).lt.0)   mts(nmmx)=0
      if(mts(nipnmx).lt.0) mts(nipnmx)=0
c
      changed=.false.
      do i=1,ntrc
         changed = changed .or.(mts(i).ne.iparmi(ilemx+i-1)) 
      end do
c
      if (changed) then
         setmts=bssadj
         write (eprerr(bssadj)(24:),'(6(i3,'',''),i2)') 
     #         lemx,lomx,kmn,kmx,mmn,mmx,ipnmx
      end if
c
c----------------------------------------------------------------------
c  Determine basis set using rules in M,I,I,M & F
c  (1)   If there is no diffusion tilt, only even K values are needed
c----------------------------------------------------------------------
      if(abs(ald).gt.rndoff .or. abs(bed).gt.rndoff .or. 
     #  (abs(bed)-1.8d2).gt.rndoff .or.abs(gad).gt.rndoff) then
         mts(nkdel)=1
      else
         mts(nkdel)=2
      end if
c
c----------------------------------------------------------------------
c  (2)   In addition, if the magnetic and linewidth tensors are axial, 
c        and there is no diffusion tilt or K.ne.0 potential terms,
c        only even L values and no K values are needed
c----------------------------------------------------------------------
      if( isaxial(fparmi(igxx),iparmi(iigflg)) .and.
     #    isaxial(fparmi(iaxx),iparmi(iiaflg)) .and.
     #    isaxial(fparmi(iwxx),iparmi(iiwflg)) .and.
     #     (mts(nkdel).eq.2).and.(.not.knon0p)) then
         mts(nldel)=2
         mts(nkmx)=0
      else
         mts(nldel)=1
      end if
c
      return
      end