*********************************************************************** SUBROUTINE GUFLD(XV,HV) * XV: 3 dim Position vector (input) * HV: 3 dim Field vector (output) * * calls gulfdo for ORANGE field map * calls gulfdt for TOSCA field map * * created 12/18/98 R.Schicker *********************************************************************** implicit none #include "user.inc" real xv(3),hv(3),xvl(3),hvl(3),dr,degrad,dp,dc,ds,br,bp,bz integer i,j1,ih,ip,i1,iz,ir,recl,istat,icycle,ih1,ih2,ih3 character*8 ctit,fileh save j1 * on first call declare some histograms and fill with field values * imap=1 is old field * imap=2 is TOSCA field if(imap.eq.0) then hv(1) = 0.0 hv(2) = 0.0 hv(3) = 0.0 return end if if(j1.eq.0)then fileh='gufl.rzh' degrad=0.017453293 recl=1024 call hcdir('//PAWC',' ') call hmdir('FIELD','S') call hcdir('//PAWC/FIELD',' ') do iz=1,9 do ir=1,9 ih1=10*iz+ir ih2=10*iz+ir+100 ih3=10*iz+ir+200 ctit='hist_r'//char(48+iz)//char(48+ir) call hbook1(ih1,ctit,720,0.,360.,0.) ctit='hist_p'//char(48+iz)//char(48+ir) call hbook1(ih2,ctit,720,0.,360.,0.) ctit='hist_z'//char(48+iz)//char(48+ir) call hbook1(ih3,ctit,720,0.,360.,0.) enddo enddo do iz=1,9 xvl(3)=10.*float(iz) do ir=1,9 dr=10.*float(ir)+40. ih1=10*iz+ir ih2=10*iz+ir+100 ih3=10*iz+ir+200 do ip=1,720 dp=0.5*float(ip)-0.25 dc=cos(degrad*dp) ds=sin(degrad*dp) xvl(1)=dr*dc xvl(2)=dr*ds if(imap.eq.1)call gufldo(xvl,hvl) if(imap.eq.2)call gufldt(xvl,hvl) br=dc*hvl(1)+ds*hvl(2) bp=-ds*hvl(1)+dc*hvl(2) bz=hvl(3) call hfill(ih1,dp,0.,br) call hfill(ih2,dp,0.,bp) call hfill(ih3,dp,0.,bz) end do enddo enddo c call hropen(61,'hist',fileh,'N',recl,istat) c call hrout(0,icycle,' ') c call hrend('hist') c close(unit=61) call hcdir('//PAWC',' ') j1=j1+1 end if do i=1,3 xvl(i)=xv(i) end do if(imap.eq.1)call gufldo(xvl,hvl) if(imap.eq.2)call gufldt(xvl,hvl) do i=1,3 hv(i)=hvl(i) end do return end