c*** Reads iobsloc subroutine ReadObs(obsnum,mobs,iobsloc) implicit none integer, intent(in) :: obsnum,mobs integer, intent(out) :: iobsloc(mobs) character*(100) fn real*8 r8seg(mobs) write(fn,'(A,I3.3,A)') '../inits/iobsloc-',obsnum,'.txt' write(*,*) fn open(unit=3,file=fn,status='old') read(unit=3,'(1I7)') iobsloc close(unit=3) call flush() end subroutine ReadObs c*** Call Model Kludge subroutine Model(mem) implicit none integer, intent(in) :: mem character*(1000) fn write(fn,'(A,I2.2,A)') & 'cd ../',mem,'/assimilate;./mitgcmuv>& LOG' call system(fn) end subroutine Model c*** Reads a pickup file... subroutine ReadPickup(mem,n,nx,ny,nz,y) implicit none integer, intent(in) :: mem,n,nx,ny,nz real*8, intent(out) :: y(n) real*8 r8seg(nx) integer i, irec,j,k character*(1024) fn write(fn,'(A,I2.2,A)') '../',mem,'/assimilate/pickup.in' open(unit=3,file=fn,status='old', & access='direct',recl=nx*8) ccc Set counter for state i =1 ccc Reading uVel do k = 1,nz do j = 1,ny irec = (k-1)*ny + j read(3,rec=irec) r8seg call DA_BYTESWAPR8(nx,r8seg) y(i:i+nx-1) = r8seg(1:nx) i = i+nx enddo enddo ccc Skip Next Two gU and gUnm1 ccc Read vVel do k = 1,nz do j = 1,ny irec = (k-1)*ny + j + nz*ny*3 read(3,rec=irec) r8seg call DA_BYTESWAPR8(nx,r8seg) y(i:i+nx-1) = r8seg(1:nx) i=i+nx enddo enddo ccc Skip Next two gV and gVnm1 ccc Read wVel do k = 1,nz do j = 1,ny irec = (k-1)*ny + j + nz*ny*6 read(3,rec=irec) r8seg call DA_BYTESWAPR8(nx,r8seg) y(i:i+nx-1) = r8seg(1:nx) i=i+nx enddo enddo ccc Read theta do k = 1,nz do j = 1,ny irec = (k-1)*ny + j + nz*ny*7 read(3,rec=irec) r8seg call DA_BYTESWAPR8(nx,r8seg) y(i:i+nx-1) = r8seg(1:nx) i=i+nx enddo enddo ccc Now close the file close(unit=3) ccc Open Non-Hydrostatic c write(fn,'(A,I2.2,A)') '../',mem,'/assimilate/pickup_nh.in' c open(unit=3,file=fn, c & status='old',access='direct',recl=nx*8) ccc Read pressure Non-hydrostatic c do k = 1,nz c do j = 1,ny c irec = (k-1)*ny + j c read(3,rec=irec) r8seg c call DA_BYTESWAPR8(nx,r8seg) c y(i:i+nx-1) = r8seg(1:nx) c i = i+nx c enddo c enddo c close(unit=3) ccc Done Reading State call flush() end subroutine ReadPickup ccc Writes a pickup subroutine WritePickup(mem,n,nx,ny,nz,y) implicit none integer, intent(in) :: mem,n,nx,ny,nz real*8, intent(in) :: y(n) real*8 r8seg(nx) integer i, irec,j,k character*(1000) fni, fno write(fni,'(A,I2.2,A)') '../',mem,'/assimilate/pickup.in' open(unit=3,file=fni,status='old', & access='direct',recl=nx*8) write(fni,'(A,I2.2,A)') '../',mem,'/assimilate/pickup.out' open(unit=4,file=fni,status='unknown', & access='direct',recl=nx*8) ccc Set counter for state i =1 ccc Writing uVel do k = 1,nz do j = 1,ny irec = (k-1)*ny + j r8seg(1:nx) = y(i:i+nx-1) call DA_BYTESWAPR8(nx,r8seg) write(4,rec=irec) r8seg i = i+nx enddo enddo ccc Copy gU and gUnm1 do k = 1,2*nz do j = 1,ny irec = (k-1)*ny + j+nz*ny read(3,rec=irec) r8seg write(4,rec=irec) r8seg enddo enddo ccc Writing vVel do k = 1,nz do j = 1,ny irec = (k-1)*ny + j + nz*ny*3 r8seg(1:nx) = y(i:i+nx-1) call DA_BYTESWAPR8(nx,r8seg) write(4,rec=irec) r8seg i=i+nx enddo enddo ccc copy Next two gV and gVnm1 do k = 1,2*nz do j = 1,ny irec = (k-1)*ny + j+nz*ny*4 read(3,rec=irec) r8seg write(4,rec=irec) r8seg enddo enddo ccc Write wVel and Theta do k = 1,2*nz do j = 1,ny irec = (k-1)*ny + j + nz*ny*6 r8seg(1:nx) = y(i:i+nx-1) call DA_BYTESWAPR8(nx,r8seg) write(4,rec=irec) r8seg i=i+nx enddo enddo ccc Copy Remaining fields do k = 1,5*nz do j = 1,ny irec = (k-1)*ny + j+nz*ny*8 read(3,rec=irec) r8seg write(4,rec=irec) r8seg enddo enddo do j = 1,ny irec = j+13*nz*ny read(3,rec=irec) r8seg write(4,rec=irec) r8seg enddo ccc Now close the file close(unit=3) close(unit=4) ccc Open Non-Hydrostatic write(fni,'(A,I2.2,A)') '../',mem,'/assimilate/pickup_nh.in' open(unit=3,file=fni, & status='old',access='direct',recl=nx*8) write(fni,'(A,I2.2,A)') '../',mem,'/assimilate/pickup_nh.out' open(unit=4,file=fni,status='unknown', & access='direct',recl=nx*8) ccc Write pressure Non-hydrostatic from State c do k = 1,nz c do j = 1,ny c irec = (k-1)*ny + j c r8seg(1:nx) = y(i:i+nx-1) c call DA_BYTESWAPR8(nx,r8seg) c write(4,rec=irec) r8seg c i = i+nx c enddo c enddo ccc Write out other fields do k = 1,2*nz do j = 1,ny irec = (k-1)*ny + j read(3,rec=irec) r8seg write(4,rec=irec) r8seg enddo enddo c close(unit=3) c close(unit=4) ccc Done Reading State call flush() end subroutine WritePickup subroutine loadMask(mask,nx,ny) implicit none integer, intent(in) :: nx, ny real*4, intent(out) :: mask(ny,nx) real*4 r4seg(nx) integer i, irec,j,k character*(1000) fni, fno write(fni,'(A)') '../inits/bathy61.bin' open(unit=3,file=fni, & status='old',access='direct',recl=nx*4) do j = 1,ny irec = j read(3,rec=irec) r4seg call DA_BYTESWAPR4(nx,r4seg) mask(j,1:nx) = r4seg(1:nx) enddo close(unit=3) call flush() end subroutine loadMask subroutine DA_BYTESWAPR8( na, arr ) C IN: C n integer - Number of 8-byte words in arr C IN/OUT: C arr real*8 - Array declared as real*4(n) C C Created: 05/05/99 adcroft@mit.edu (This is an unfortunate hack!!) implicit none C Arguments integer na character*(*) arr C Local integer i character*(1) cc C ------------------------------------------------------------------ do i=1,8*na,8 cc=arr(i:i) arr(i:i)=arr(i+7:i+7) arr(i+7:i+7)=cc cc=arr(i+1:i+1) arr(i+1:i+1)=arr(i+6:i+6) arr(i+6:i+6)=cc cc=arr(i+2:i+2) arr(i+2:i+2)=arr(i+5:i+5) arr(i+5:i+5)=cc cc=arr(i+3:i+3) arr(i+3:i+3)=arr(i+4:i+4) arr(i+4:i+4)=cc enddo C ------------------------------------------------------------------ return end C========================== C======================================================================= subroutine DA_BYTESWAPR4( n, arr ) C IN: C n integer - Number of 4-byte words in arr C IN/OUT: C arr real*4 - Array declared as real*4(n) C C Created: 05/05/99 adcroft@mit.edu (This is an unfortunate hack!!) implicit none C Arguments integer n character*(*) arr C Local integer i character*(1) cc C ------------------------------------------------------------------ do i=1,4*n,4 cc=arr(i:i) arr(i:i)=arr(i+3:i+3) arr(i+3:i+3)=cc cc=arr(i+1:i+1) arr(i+1:i+1)=arr(i+2:i+2) arr(i+2:i+2)=cc enddo C ------------------------------------------------------------------ return end C=======================================================================