API tools faq
paste
Advertisement
Guest User

Untitled

a guest
Apr 9th, 2019
143
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Fortran 9.63 KB | None | 0 0
raw download clone embed print report
  1. !_________________________________________________________
  2. ! This program will read binary data from all grid points
  3. ! and calculate the monthly mean. On the other hand, this
  4. ! program will the single scattering albedo only for the
  5. ! valid data and write into a new binary file. For each
  6. ! binary file there will also be a control (.ctl) file
  7. ! created for grads manipulation later.
  8. !=========================================================
  9. ! This program has been created and modified by =.Taufiq Hassan.=
  10. ! For more info. email: taufiq@gist.ac.kr
  11. ! Thanks to .Damien Decremer.
  12. !_________________________________________________________
  13.  
  14.  
  15. program rea
  16.   implicit none
  17. !============Defining all variables================================!
  18.     real, parameter :: UNDEF = -9999.0
  19.     character :: filename*30,monname*30,ctlfile*30
  20.     integer :: i,ios,j,k,m,c1(360,180),c2(360,180),c3(360,180),c4(360,180),p,q
  21.     integer, parameter:: n=31
  22.     logical:: exist
  23.     integer,parameter::NX=360,NY=180,NZ=1,NT=1,NV=6,NS=0
  24.     real:: aaod388(nx,ny),aaod500(nx,ny),aeod388(nx,ny),aeod500(nx,ny)
  25.     real:: ssa388(nx,ny),ssa500(nx,ny)
  26.     real::summ1(nx,ny), naaod388(nx,ny),naaod500(nx,ny),naeod388(nx,ny),naeod500(nx,ny),summ2(nx,ny),summ3(nx,ny),summ4(nx,ny)
  27.  
  28. !====================Loop for yearly calculations=======================!  
  29. do q=2004,2012
  30.       summ1(:,:) = 0.0
  31.       summ2(:,:) = 0.0
  32.       summ3(:,:) = 0.0
  33.       summ4(:,:) = 0.0
  34.       c1(:,:)=0
  35.       c2(:,:)=0
  36.       c3(:,:)=0
  37.       c4(:,:)=0
  38. !===================Loop for Monthly calculations=======================!
  39.   do  p=10,12
  40.       summ1(:,:) = 0.0
  41.       summ2(:,:) = 0.0
  42.       summ3(:,:) = 0.0
  43.       summ4(:,:) = 0.0
  44.       c1(:,:)=0
  45.       c2(:,:)=0
  46.       c3(:,:)=0
  47.       c4(:,:)=0
  48. !=================Loop for daily calculations===========================!
  49.       do i =1,n
  50.         write(filename,fmt='(a,I4,a,I2,a,I0,a)') 'OMI-OMAERUV_',q,'m',p,'d',i,'.data'
  51.         inquire(file=filename, exist=exist)
  52.           if (exist) then
  53. !         print*, filename
  54.           open(unit = 10, File=filename,status='unknown', &
  55.           form='unformatted',access = 'direct', recl=4*NX*NY)
  56.     !       !read all data in this part
  57.           read (10,rec=3) aaod388
  58.           read(10,rec=5)aaod500
  59.           read(10,rec=4)aeod388
  60.           read(10,rec=6)aeod500
  61. !=================Calculate the Summation===============================!
  62.           do j=1,360
  63.         do k= 1,180
  64.           if (aaod388(j,k) > -1.0) then
  65.             c1(j,k)=c1(j,k)+1
  66.             summ1(j,k)=summ1(j,k)+aaod388(j,k)
  67.           end if
  68.           if (aaod500(j,k) > -1.0) then
  69.             c2(j,k)=c2(j,k)+1
  70.             summ2(j,k)=summ2(j,k)+aaod500(j,k)
  71.           end if
  72.           if (aeod388(j,k) > -1.0) then
  73.             c3(j,k)=c3(j,k)+1
  74.             summ3(j,k)=summ3(j,k)+aeod388(j,k)
  75.           end if
  76.           if (aeod500(j,k) > -1.0) then
  77.             c4(j,k)=c4(j,k)+1
  78.             summ4(j,k)=summ4(j,k)+aeod500(j,k)
  79.           end if
  80.         end do
  81.           end do
  82.           else
  83.           end if
  84.     end do
  85. !==================Calculate the mean======================================!
  86.       do j=1,360
  87.     do k= 1,180
  88.       naaod388(j,k)=summ1(j,k)/c1(j,k)
  89.       naaod500(j,k)=summ2(j,k)/c2(j,k)
  90.       naeod388(j,k)=summ3(j,k)/c3(j,k)
  91.       naeod500(j,k)=summ4(j,k)/c4(j,k)
  92.       if (naeod388(j,k) > naaod388(j,k)) then
  93.         ssa388(j,k)=(naeod388(j,k)-naaod388(j,k))/naeod388(j,k)
  94.       else
  95.         ssa388(j,k) = UNDEF
  96.       end if
  97.       if (naeod500(j,k)> naaod500(j,k)) then
  98.         ssa500(j,k)=(naeod500(j,k)-naaod500(j,k))/naeod500(j,k)
  99.       else
  100.         ssa500(j,k) = UNDEF
  101.       end if
  102.     end do
  103.       end do
  104.       close (10)
  105. !===================Write data into a different binary file========================!
  106.       write(monname,fmt='(a,I4,a,I2,a)') 'OMI-Monmean_',q,'m',p,'.data'
  107.       open(12, file=monname, status="unknown",action='write', &
  108.       form='unformatted',access = 'direct', recl=4*NX*NY)
  109.     write (12,rec=1)naaod388
  110.     write (12,rec=2)naaod500
  111.     write (12,rec=3)naeod388
  112.     write (12,rec=4)naeod500
  113.     write (12,rec=5)ssa388
  114.     write (12,rec=6)ssa500
  115.       close(12)
  116. !====================Create .ctl file for each binary file=========================!    
  117.     write(ctlfile,fmt='(a,I4,a,I2,a)') 'OMI-Monmean_',q,'m',p,'.ctl'
  118.     open(04,file=ctlfile,form='formatted',status='unknown')
  119.     write(04,'(a,a,I4,a,I2,a)') 'DSET','  OMI-Monmean_',q,'m',p,'.data'
  120.     write(04,'(A,F0.1)') 'UNDEF ',UNDEF
  121.     write(04,'(A)') '*'
  122.     write(04,'(A)') 'TITLE OMI/Aura Near UV Aerosol Optical Depth and Single Scattering Albedo - Raw res'
  123.     write(04,'(A,I3,A)') 'XDEF ',NX,' LINEAR -179.500000 1.000000'
  124.     write(04,'(A,I3,A)') 'YDEF ',NY,' LINEAR -89.500000 1.000000'
  125.     write(04,'(A,I0,A)') 'ZDEF ',NZ,' LEVELS 1000'
  126.     write(04,'(A)') '*'
  127.     write(04,'(A,I0,A)') 'TDEF ',NT,' LINEAR Oct2004 1mo'
  128.     write(04,'(A)') '*'
  129.     write(04,'(A,I0)') 'VARS ',NV
  130.       write(04,'(A,I0,A)') 'AAOD388 ',NS,' 99 Final Aerosol Absorption Optical Depth at 388 nm'
  131.       write(04,'(A,I0,A)') 'AAOD500 ',NS,' 99 Final Aerosol Absorption Optical Depth at 500 nm'
  132.       write(04,'(A,I0,A)') 'AEOD388 ',NS,' 99 Final Aerosol Extinction Optical Depth at 388 nm'
  133.       write(04,'(A,I0,A)') 'AEOD500 ',NS,' 99 Final Aerosol Extinction Optical Depth at 500 nm'
  134.       write(04,'(A,I0,A)') 'SSA388 ',NS,' 99 Final Aerosol Single Scattering Albedo at 388 nm'
  135.       write(04,'(A,I0,A)') 'SSA500 ',NS,' 99 Final Aerosol Single Scattering Albedo at 500 nm'
  136.     write(04,'(A)') 'ENDVARS'
  137.     write(04,'(A)') '*'
  138.   close(04)
  139.  
  140.   end do
  141. end do
  142.  
  143. !______________________________________________________________________
  144. !=========================Part 2 starts here=============================================
  145. !====================Loop for yearly calculations=======================!  
  146. do q=2005,2013
  147.       summ1(:,:) = 0.0
  148.       summ2(:,:) = 0.0
  149.       summ3(:,:) = 0.0
  150.       summ4(:,:) = 0.0
  151.       c1(:,:)=0
  152.       c2(:,:)=0
  153.       c3(:,:)=0
  154.       c4(:,:)=0
  155. !===================Loop for Monthly calculations=======================!
  156.   do  p=1,9
  157.       summ1(:,:) = 0.0
  158.       summ2(:,:) = 0.0
  159.       summ3(:,:) = 0.0
  160.       summ4(:,:) = 0.0
  161.       c1(:,:)=0
  162.       c2(:,:)=0
  163.       c3(:,:)=0
  164.       c4(:,:)=0
  165. !=================Loop for daily calculations===========================!
  166.       do i =1,n
  167.         write(filename,fmt='(a,I4,a,I0,a,I0,a)') 'OMI-OMAERUV_',q,'m',p,'d',i,'.data'
  168.         inquire(file=filename, exist=exist)
  169.           if (exist) then
  170. !         print*, filename
  171.           open(unit = 10, File=filename,status='unknown', &
  172.           form='unformatted',access = 'direct', recl=4*NX*NY)
  173.     !       !read all data in this part
  174.           read (10,rec=3) aaod388
  175.           read(10,rec=5)aaod500
  176.           read(10,rec=4)aeod388
  177.           read(10,rec=6)aeod500
  178. !=================Calculate the Summation===============================!
  179.           do j=1,360
  180.         do k= 1,180
  181.           if (aaod388(j,k) > -1.0) then
  182.             c1(j,k)=c1(j,k)+1
  183.             summ1(j,k)=summ1(j,k)+aaod388(j,k)
  184.           end if
  185.           if (aaod500(j,k) > -1.0) then
  186.             c2(j,k)=c2(j,k)+1
  187.             summ2(j,k)=summ2(j,k)+aaod500(j,k)
  188.           end if
  189.           if (aeod388(j,k) > -1.0) then
  190.             c3(j,k)=c3(j,k)+1
  191.             summ3(j,k)=summ3(j,k)+aeod388(j,k)
  192.           end if
  193.           if (aeod500(j,k) > -1.0) then
  194.             c4(j,k)=c4(j,k)+1
  195.             summ4(j,k)=summ4(j,k)+aeod500(j,k)
  196.           end if
  197.         end do
  198.           end do
  199.           else
  200.           end if
  201.     end do
  202. !==================Calculate the mean======================================!
  203.       do j=1,360
  204.     do k= 1,180
  205.       naaod388(j,k)=summ1(j,k)/c1(j,k)
  206.       naaod500(j,k)=summ2(j,k)/c2(j,k)
  207.       naeod388(j,k)=summ3(j,k)/c3(j,k)
  208.       naeod500(j,k)=summ4(j,k)/c4(j,k)
  209.       if (naeod388(j,k) > naaod388(j,k)) then
  210.         ssa388(j,k)=(naeod388(j,k)-naaod388(j,k))/naeod388(j,k)
  211.       else
  212.         ssa388(j,k) = UNDEF
  213.       end if
  214.       if (naeod500(j,k)> naaod500(j,k)) then
  215.         ssa500(j,k)=(naeod500(j,k)-naaod500(j,k))/naeod500(j,k)
  216.       else
  217.         ssa500(j,k) = UNDEF
  218.       end if
  219.     end do
  220.       end do
  221.       close (10)
  222. !===================Write data into a different binary file========================!
  223.       write(monname,fmt='(a,I4,a,I0,a)') 'OMI-Monmean_',q,'m',p,'.data'
  224.       open(12, file=monname, status="unknown",action='write', &
  225.       form='unformatted',access = 'direct', recl=4*NX*NY)
  226.     write (12,rec=1)naaod388
  227.     write (12,rec=2)naaod500
  228.     write (12,rec=3)naeod388
  229.     write (12,rec=4)naeod500
  230.     write (12,rec=5)ssa388
  231.     write (12,rec=6)ssa500
  232.       close(12)
  233. !====================Create .ctl file for each binary file=========================!  
  234.     write(ctlfile,fmt='(a,I4,a,I0,a)') 'OMI-Monmean_',q,'m',p,'.ctl'
  235.     open(04,file=ctlfile,form='formatted',status='unknown')
  236.     write(04,'(a,a,I4,a,I0,a)') 'DSET','  OMI-Monmean_',q,'m',p,'.data'
  237.     write(04,'(A,F0.1)') 'UNDEF ',UNDEF
  238.     write(04,'(A)') '*'
  239.     write(04,'(A)') 'TITLE OMI/Aura Near UV Aerosol Optical Depth and Single Scattering Albedo - Raw res'
  240.     write(04,'(A,I3,A)') 'XDEF ',NX,' LINEAR -179.500000 1.000000'
  241.     write(04,'(A,I3,A)') 'YDEF ',NY,' LINEAR -89.500000 1.000000'
  242.     write(04,'(A,I0,A)') 'ZDEF ',NZ,' LEVELS 1000'
  243.     write(04,'(A)') '*'
  244.     write(04,'(A,I0,A)') 'TDEF ',NT,' LINEAR Oct2004 1mo'
  245.     write(04,'(A)') '*'
  246.     write(04,'(A,I0)') 'VARS ',NV
  247.       write(04,'(A,I0,A)') 'AAOD388 ',NS,' 99 Final Aerosol Absorption Optical Depth at 388 nm'
  248.       write(04,'(A,I0,A)') 'AAOD500 ',NS,' 99 Final Aerosol Absorption Optical Depth at 500 nm'
  249.       write(04,'(A,I0,A)') 'AEOD388 ',NS,' 99 Final Aerosol Extinction Optical Depth at 388 nm'
  250.       write(04,'(A,I0,A)') 'AEOD500 ',NS,' 99 Final Aerosol Extinction Optical Depth at 500 nm'
  251.       write(04,'(A,I0,A)') 'SSA388 ',NS,' 99 Final Aerosol Single Scattering Albedo at 388 nm'
  252.       write(04,'(A,I0,A)') 'SSA500 ',NS,' 99 Final Aerosol Single Scattering Albedo at 500 nm'
  253.     write(04,'(A)') 'ENDVARS'
  254.     write(04,'(A)') '*'
  255.   close(04)
  256.   end do
  257. end do
  258. end
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!