      
c************************************************************************

      subroutine stalk_grain(ss_sl,ss_ls)

c************************************************************************

      integer true
      parameter(true=1)

      integer hhhh,vvvv,hvhv,hhvv,vvhh
      parameter(vvvv=1)
      parameter(hhhh=2)      
      parameter(hvhv=3)
      parameter(hhvv=4)
      parameter(vvhh=5)

      integer hh,vv
      parameter(vv=1)
      parameter(hh=2)

      integer p,gp,pg,gpg
      parameter(p=1)
      parameter(gp=2)      
      parameter(pg=3)
      parameter(gpg=4)      
      
      complex q,r,s
      complex ss_sl(4,4,4),ss_ls(4,4,4)
      integer pol,mech,mech_c
      integer vvvv_flg,hhhh_flg,hvhv_flg,hhvv_flg

      common /pol_flags/ vvvv_flg,hhhh_flg,hvhv_flg,hhvv_flg

      include 'status.incld'

      do  pol=1,5

        do  mech=1,4

          do  mech_c=1,4

            if ((pol .eq. vvvv).and.(vvvv_flg .eq. true))then

              if (mech .eq. p) then

                if (mech_c .eq. p) then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))

c                  print*, pol,mech,mech_c,q,r,s

                else if(mech_c .eq. gp)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg)then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,gp,mech)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg)then

                  call stalk_phig_int(pol,mech,mech_c, s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
             
                else

                  continue
                  
                endif

              else if(mech .eq. gp) then

                if (mech_c .eq. p) then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*,'finished with ',pol,mech,mech_c
                  
                else if(mech_c .eq. gp) then
                  
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
             
                else if(mech_c .eq. pg) then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,gp,mech)
                  
c                  print*, pol,mech,mech_c,q,r,s
             
                else if(mech_c.eq.gpg)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s                  
                                    
             
                else

                  continue

                endif

              else if(mech .eq. pg) then

                if(mech_c .eq. p) then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
             
                else if(mech_c .eq. gp) then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
             
                else if(mech_c .eq. pg) then
                  
                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
             
                else if(mech_c .eq. gpg)then
                  
                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s                  
                                    
             
                else

                  continue
                
                endif

              else if (mech .eq. gpg) then

                if(mech_c .eq. p)then
                  
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                                    
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp)then
                  
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg)then
                  
                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,gp,mech)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if (mech_c .eq. gpg) then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue
                
                endif

              else

                continue

              endif

            else if((pol.eq.hhhh).and.(hhhh_flg.eq.true))then

              if (mech .eq. p) then

                if (mech_c .eq. p) then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg)then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,gp,mech)                  

c                  print*, pol,mech,mech_c,q,r,s
                   
                else if(mech_c .eq. gpg)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif
                
              else if(mech .eq. gp) then

                if(mech_c .eq. p)then
                  
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))

c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp) then
                
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg) then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,gp,mech)                  

c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue
                  
                endif

              else if(mech .eq. pg) then

                if(mech_c .eq. p) then
                  
                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp) then
                  
                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg) then
                  
                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg)then
                  
                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  ss_ls(pol,mech_c,mech)=ss_ls(pol,mech_c,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif

              else if (mech .eq. gpg) then

                if(mech_c .eq. p)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.gp)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.pg)then

                 ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                 ss_ls(pol,mech_c,mech)=ss_ls(pol,gp,mech)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg) then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  ss_ls(pol,mech_c,mech)=conjg(ss_sl(pol,mech,mech_c))
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue
                
                endif
              
              else

                continue
              
              endif                
            
            else if((pol.eq.hvhv).and.(hvhv_flg.eq.true))then

              ss_sl(pol,mech,mech_c)=cmplx(0.0,0.0)
              ss_ls(pol,mech_c,mech)=cmplx(0.0,0.0)              
                  
            else if((pol .eq. hhvv).and.(hhvv_flg.eq.true))then

              if (mech .eq. p) then

                if (mech_c .eq. p) then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg)then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                 
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.gpg)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif


              else if(mech .eq. gp) then
                
                if(mech_c .eq. p)then
                
                call stalk_phig_int(pol,mech,mech_c,s)
                call stalk_phase_field(hh,mech, r)
                call grain_field_int(vv,mech,q)
                  
                ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp) then
                
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg) then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.gpg)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                                    
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif

              else if(mech .eq. pg) then

                if(mech_c .eq. p)then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp) then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg) then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg)then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,gp,mech_c)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif

              else if (mech .eq. gpg) then

                if(mech_c .eq. p)then
                
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.gp)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg)then

                  ss_sl(pol,mech,mech_c)=ss_sl(pol,mech,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg) then
                    
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(hh,mech, r)
                  call grain_field_int(vv,mech,q)

                  ss_sl(pol,mech,mech_c)=conjg(q)*r*s
                  
c                  print*, pol,mech,mech_c,q,r,s

                else
                  
                  continue
                  
                endif

              else
                  
                continue
                  
              endif
              
             else if((pol .eq. vvhh).and.(hhvv_flg.eq.true))then

              if (mech .eq. p) then

                if (mech_c .eq. p) then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg)then

                  ss_ls(hhvv,mech,mech_c)=ss_ls(hhvv,mech,gp)
                 
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.gpg)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif

              else if(mech .eq. gp) then

                if(mech_c .eq. p)then
                
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp) then
                
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg) then

                  ss_ls(hhvv,mech,mech_c)=ss_ls(hhvv,mech,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.gpg)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                                    
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif

              else if(mech .eq. pg) then

                if(mech_c .eq. p)then

                  ss_ls(hhvv,mech,mech_c)=ss_ls(hhvv,gp,mech_c)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gp) then

                  ss_ls(hhvv,mech,mech_c)=ss_ls(hhvv,gp,mech_c)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg) then

                  ss_ls(hhvv,mech,mech_c)=ss_ls(hhvv,gp,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg)then

                  ss_ls(hhvv,mech,mech_c)=ss_ls(hhvv,gp,mech_c)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else

                  continue

                endif

              else if (mech .eq. gpg) then

                if(mech_c .eq. p)then
                
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c.eq.gp)then

                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. pg)then

                  ss_ls(hhvv,mech,mech_c)=ss_ls(hhvv,mech,gp)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                else if(mech_c .eq. gpg) then
                    
                  call stalk_phig_int(pol,mech,mech_c,s)
                  call stalk_phase_field(vv,mech, r)
                  call grain_field_int(hh,mech,q)

                  ss_ls(hhvv,mech,mech_c)=q*conjg(r*s)
                  
c                  print*, pol,mech,mech_c,q,r,s
                  
                
                else

                  continue
                
                endif

              else

                continue
              
              endif

            else

              continue

            endif

            call status_report('stalk_grain',pol,mech,mech_c,incrmnt)

          enddo

        enddo
          
      enddo

      return
      end

