!------------------------------------------------------------------- ! subroutine mm_rrt_ms(msgtype,nproc) ! ------------------------------------------------------------------ ! use communicate use grt implicit none integer, intent(in) :: msgtype integer, intent(in) :: nproc integer :: i character(len=30) :: ms = 'ms' integer, save :: iagain ! TESTING character(len=3) :: cagain ! TESTING character(len=70) :: envstring ! TESTING character(len=40) :: ctemp ! TESTING data iagain /0/ ! TESTING external fbuff ! iagain = iagain+1 ! TESTING emis1d=0.0d0 opac1d=0.0d0 do i=0,nproc-1 call recv(msgtype,ms,i) call upk(xspec(i)%array(:), xspec(i)%nsize) ! write(1,*) 'ELEMENT=',i ! xspec1d(:)=xspec(i)%array(:) ! ixsp=xspec(i)%nsize !x xspec1d(:)=xspec(0)%array(:) !x ixsp=xspec(0)%nsize call upk( emis(i)%array(:), emis(i)%nsize) ! emis1d(:)=emis(i)%array(:)+emis1d(:) ! iems=emis(i)%nsize !x emis1d(:)=emis(0)%array(:) !x iems=emis(0)%nsize call upk( opac(i)%array(:), opac(i)%nsize) ! opac1d(:)=opac(i)%array(:)+opac1d(:) ! iopc=opac(i)%nsize !x opac1d(:)=opac(0)%array(:) !x iopc=opac(0)%nsize enddo ! write(1,*) 'before grid_interleave' call grid_interleave(xspec(0)%array,emis(0)%array,xspec(0)%nsize, & & xspec(1)%array,emis(1)%array,xspec(1)%nsize, & & xspec1d,emis1d,iems) ! write(1,*) '#iems=',iems call grid_interleave(xspec(0)%array,opac(0)%array,xspec(0)%nsize, & & xspec(1)%array,opac(1)%array,xspec(1)%nsize, & & xspec1d,opac1d,iopc) ! write(1,*) '#iopc=',iopc ! ***************************************************************** ! ! envstring = 'STDOUT' ! write(cagain,'(i3.3)') iagain ! ctemp = 'sp0'//trim(adjustl(get_cmytid()))//"."//cagain ! call openf(50,ctemp,envstring) ! write(50,*) '# ', opac(0)%nsize ! do i=1,opac(0)%nsize ! write(50,*) opac(0)%array(i) ! enddo ! close(50) ! envstring = 'STDOUT' ! write(cagain,'(i3.3)') iagain ! ctemp = 'sp1'//trim(adjustl(get_cmytid()))//"."//cagain ! call openf(50,ctemp,envstring) ! write(50,*) '# ',opac(1)%nsize ! do i=1,opac(1)%nsize ! write(50,*) opac(1)%array(i) ! enddo ! close(50) ! ***************************************************************** ! end subroutine mm_rrt_ms ! ----------------------------------------------------------------------- ! subroutine grid_interleave(xmesh1,ymesh1,i1max,xmesh2,ymesh2,i2max,& & x,y,nsz) ! ----------------------------------------------------------------------- ! use grt integer :: i,max integer :: i1 = 1 integer :: i2 = 1 integer :: i1max integer :: i2max integer :: ip1 = 1 integer :: ip2 = 1 integer :: flg = 0 integer :: ict integer :: nsz integer :: ixm ,maxixm integer :: ixpt,maxixpt real(8) :: eps = 1.0e-10 real(8) :: diff integer, dimension(np) :: ilower1 integer, dimension(np) :: ilower2 real(8), dimension(np) :: x,y real(8), dimension(0:np) :: x1, y1, x2, y2 real(8), dimension(0:np) :: xmesh1, ymesh1 real(8), dimension(0:np) :: xmesh2, ymesh2 real(8), dimension(np) :: xpts1, ypts1 real(8), dimension(np) :: xpts2, ypts2 real(8), external :: func do diff=abs(xmesh1(i1)-xmesh2(i2)) if(xmesh1(i1).gt.xmesh2(i2))then xpts1(ip1)=xmesh2(i2) ilower1(ip1)=i1 ip1=ip1+1 if(i2.le.i2max)then i2=i2+1 else exit endif flg=1 elseif(xmesh1(i1).lt.xmesh2(i2))then xpts2(ip2)=xmesh1(i1) ilower2(ip2)=i2 ip2=ip2+1 if(i1.le.i1max)then i1=i1+1 else exit endif elseif(diff.le.eps)then if(i1.le.i1max)then i1=i1+1 else exit endif if(i2.le.i2max)then i2=i2+1 else exit endif else Print*,'ERROR ELSE TRAP' endif enddo do i=1,ip1-1 ypts1(i)=func(ymesh1(0),xmesh1(0),xpts1(i),ilower1(i)) ! write(1,*) 'ypts1(',i,')=',ypts1(i) enddo do i=1,ip2-1 ypts2(i)=func(ymesh2(0),xmesh2(0),xpts2(i),ilower2(i)) ! write(1,*) 'ypts2(',i,')=',ypts2(i) enddo ! do i=1,ip1-1 ! write(1,*) xpts1(i), ypts1(i) ! enddo ! do i=1,ip2-1 ! write(1,*) xpts2(i), ypts2(i) ! enddo call combine(np,i1max,ip1-1,xmesh1,ymesh1,xpts1,ypts1,x1,y1) max1=aint(x1(0)) ! write(1,*) '# x1,y1' ! do i=1,max1 ! write(1,*) x1(i),' ',y1(i) ! enddo ! write(1,*) call combine(np,i2max,ip2-1,xmesh2,ymesh2,xpts2,ypts2,x2,y2) max2=aint(x2(0)) if(max2.ne.max1) write(1,*)'ERROR:', max2,' .ne. ',max1 call fbuff() ! write(1,*) '# x2,y2' ! do i=1,max2 ! write(1,*) x2(i),' ',y2(i) ! enddo ! write(1,*) ! write(1,*) '# x,y' do i=1,max2 x(i)=x1(i) y(i)=y1(i)+y2(i) ! write(1,*) x(i),y(i) enddo nsz=x2(0) end subroutine grid_interleave ! ------------------------------------------------------------------------- subroutine combine(np,maxixm,maxixpt,xmesh,ymesh,xpts,ypts,x,y) ! ------------------------------------------------------------------------- integer :: ict integer :: ixm ,maxixm integer :: ixpt,maxixpt real(8), dimension(0:np) :: xmesh, ymesh real(8), dimension(np) :: xpts, ypts real(8), dimension(0:np) :: x, y ict = 0 ixm = 1 ixpt = 1 do ict = ict+1 if(xmesh(ixm).lt.xpts(ixpt)) then x(ict)=xmesh(ixm) y(ict)=ymesh(ixm) ixm=ixm+1 if(ixm.gt.maxixm) goto 200 elseif(xmesh(ixm).gt.xpts(ixpt)) then x(ict)=xpts(ixpt) y(ict)=ypts(ixpt) ixpt = ixpt+1 if(ixpt.gt.maxixpt)then do ! copy the rest of xmesh into x ict=ict+1 x(ict)=xmesh(ixm) y(ict)=ymesh(ixm) ixm=ixm+1 ! if(ixm.gt.maxixm) goto 200 if(ixm.gt.maxixm) exit enddo endif endif if(ixm.gt.maxixm) exit enddo 200 continue x(0)=ict-1 y(0)=ict-1 end subroutine combine ! ------------------------------------------------------- double precision function func(y,x,x0,ilower) ! ------------------------------------------------------- ! Region: Profile ! Purpose: Linear Interpolation ! Using bracket to interpolate at grid point x0 integer,parameter :: np=10001 integer :: iupper, ilower real(8),dimension(np) :: y real(8),dimension(np) :: x real(8) :: x0 real(8) :: slope iupper=ilower+1 slope=(y(iupper)-y(ilower))/(x(iupper)-x(ilower)) func=y(iupper)+slope*(x0-x(iupper)) end function func