-
Fortran出错.png (42.45 KB, 下载次数: 333)
program select_fog
implicit none
integer, parameter::U=6,N=1000000
integer num,m,i,Key,key2
real def
!character*6,allocatable::star(:)
!character*4,allocatable::yearr(:)
!character*2,allocatable::monthr(:),datr(:)
!real,allocatable::raind(:),rainn(:)
character*5 star(N)
character*4 yearr(N)
character*2 monthr(N),datr(N)
real*8 raind(N),rainn(N)
character*50 fl(U)
character*50 filename,fpathin,fileput
def=9999.
fpathin='F:\data\fog\meteo\rain\*.txt' !!!改路径
filename='F:\data\fog\meteo\namelist_rain.txt' !!!改路径
call ListToFile(fpathin,filename)
open(1,file=filename)
num=1
do while(.true.)
read(1,*,iostat=Key) fileput
if(Key/=0)then
exit
endif
fl(num)=trim(fileput)
num=num+1
end do
close(1)
print*,'the number of meteo data is',num-1
!ALLOCATE(star(nx),yearr(nx),monthr(nx),datr(nx),raind(nx),rainn(nx))
i=1
do m=1,num-1
open(m*10,file=fl(m),status='old')
print*,'reading the rain file:',fl(m)
read(m*10,*)
do while(.true.)
read(m*10,*,iostat=key2) star(i),yearr(i),monthr(i),datr(i),raind(i),rainn(i)
if(key2/=0)then
exit
endif
! print*,star(i),yearr(i),monthr(i),datr(i),raind(i),rainn(i)
i=i+1
enddo
close(m*10)
enddo
!N=i-1
!print*,'N=',N
!DEALLOCATE(star,yearr,monthr,datr,raind,rainn)
!ALLOCATE(star(N),yearr(N),monthr(N),datr(N),raind(N),rainn(N))
!---------------the following code is the main part of fortran ------------------------
call selectmodule(star,yearr,monthr,datr,raind,rainn,N)
!DEALLOCATE(star,yearr,monthr,datr,raind,rainn)
end program
subroutine selectmodule(star,yearr,monthr,datr,raind,rainn,N)
implicit none
!integer, parameter::U=12,nxx=10000000,nyy=1000000
integer, parameter::U=12,nxx=250000,nyy=200000
integer N,i,j,k,num,KK,m,flag,ii,jj,cc
integer kk2
real def
character*5 sta(nxx),sta2(nyy)
character*4 year(nxx),year2(nyy)
character*2 month(nxx),dat(nxx),month2(nyy),dat2(nyy)
character*2 tim(nxx),tim2(nyy)
character*5 fx(nxx),fx2(nyy),fx_12(nyy)
real*8 pa(nxx),vis(nxx),fs(nxx),tc(nxx),lc(nxx),tt(nxx),rh(nxx)
real*8 pa2(nyy),vis2(nyy),fs2(nyy),tc2(nyy),lc2(nyy),tt2(nyy),rh2(nyy),pa_12(nyy),tt_12(nyy),rh_12(nyy),fs_12(nyy)
character*5 star(N)
character*4 yearr(N)
character*2 monthr(N),datr(N),ctim(4)
real*8 raind(N),rainn(N)
character*50 fl(U)
character*50 filename,fpathin,fileput
def=9999.
jj=1
fpathin='F:\data\fog\meteo\lotdata\*.txt' !!!改路径
filename='F:\data\fog\meteo\namelist_lotdata.txt' !!!改路径
call ListToFile(fpathin,filename)
open(2,file=filename)
num=1
do while(.true.)
read(2,*,iostat=KK) fileput
if(KK/=0)then
EXIT
endif
fl(num)=trim(fileput)
num=num+1
end do
close(2)
do m=1,num-1
j=1
i=1
open(m*11,file=fl(m),status='old')
print*,'reading the meteo lot data:',fl(m)
read(m*11,*)
do while(.true.)
read(m*11,*,iostat=kk2) sta(i),year(i),month(i),dat(i),tim(i),pa(i),tt(i),rh(i),tc(i),lc(i),vis(i),fs(i),fx(i)
if(kk2/=0)then
EXIT
endif
!print*,sta(i),year(i),month(i),dat(i),tim(i),pa(i),tt(i),rh(i),tc(i),lc(i),vis(i),fs(i),fx(i)
flag=0
if(vis(i)<=1) then
j=i
do while(tim(i)/='20')
i=i+1
read(m*11,*) sta(i),year(i),month(i),dat(i),tim(i),pa(i),tt(i),rh(i),tc(i),lc(i),vis(i),fs(i),fx(i)
!print*,sta(i),year(i),month(i),dat(i),tim(i),pa(i),tt(i),rh(i),tc(i),lc(i),vis(i),fs(i),fx(i)
enddo
if(tc(i)>=8.and.tc(i-1)>=8.and.tc(i-2)>=8)then
flag=1
endif
do while(flag==1)
i=j
do ii=1,N
if(star(ii)==sta(i).and.yearr(ii)==year(i))then
if(monthr(ii)==month(i).and.datr(ii)==dat(i))then
if(tim(i)=='2'.or.tim(i)=='8')then
if(rainn(ii-1)>0.0.and.rainn(ii-1)/=def)then
sta2(jj)=sta(i)
year2(jj)=year(i)
month2(jj)=month(i)
dat2(jj)=dat(i)
tim2(jj)=tim(i)
pa2(jj)=pa(i)
tt2(jj)=tt(i)
rh2(jj)=rh(i)
tc2(jj)=tc(i)
lc2(jj)=lc(i)
vis2(jj)=vis(i)
fs2(jj)=fs(i)
fx2(jj)=fx(i)
pa_12(jj)=pa(i-2)
tt_12(jj)=tt(i-2)
rh_12(jj)=rh(i-2)
fs_12(jj)=fs(i-2)
fx_12(jj)=fx(i-2)
!if(sta2(1)/='56598')then
!print*,'debug'
!endif
jj=jj+1
exit
else
exit
endif
else if(tim(i)=='14'.or.tim(i)=='20') then
if(raind(ii)>0.0.and.raind(ii)/=def)then
sta2(jj)=sta(i)
year2(jj)=year(i)
month2(jj)=month(i)
dat2(jj)=dat(i)
tim2(jj)=tim(i)
pa2(jj)=pa(i)
tt2(jj)=tt(i)
rh2(jj)=rh(i)
tc2(jj)=tc(i)
lc2(jj)=lc(i)
vis2(jj)=vis(i)
fs2(jj)=fs(i)
fx2(jj)=fx(i)
pa_12(jj)=pa(i-2)
tt_12(jj)=tt(i-2)
rh_12(jj)=rh(i-2)
fs_12(jj)=fs(i-2)
fx_12(jj)=fx(i-2)
!if(sta2(1)/='56598')then
!print*,'debug'
!endif
jj=jj+1
exit
else
exit
endif
end if
endif
endif
enddo
flag=0
enddo
i=j
endif
i=i+1
enddo
close(m*11)
enddo
print*,'i=',i-1
!DEALLOCATE(sta,year,month,dat,tim,pa,tt,rh,tc,lc,vis,fs,fx)
cc=jj-1
print*,'the total fog number is ',cc
data (ctim(i),i=1,4)/'02','14','08','20'/
do k=1,4
open(k*111,file='F:\data\fog\meteo\out\FOG_'//ctim(k)//'.txt') !改路径
enddo
!print*,(tim2(i),i=1,cc)
!do k=1,cc
!print*,year2(k),month2(k),dat2(k),tim2(k),pa2(k),tt2(k),rh2(k),tc2(k)!,&
!lc2(k),vis2(k),fs2(k),fx2(k),pa_12(k),tt_12(k),rh_12(k),fs_12(k),fx_12(k)
!enddo
do k=1,cc
select case(tim2(k))
case('2')
!write(111,*) '站点 年 月 日 时 气压 温度 相对湿度 总云量 低云量 能见度 风速 风向 前12h气压 前12h温度 前12h相对湿度 前12h风速 前12h风向'
write(111,200) sta2(k),year2(k),month2(k),dat2(k),tim2(k),pa2(k),tt2(k),rh2(k),tc2(k),&
lc2(k),vis2(k),fs2(k),fx2(k),pa_12(k),tt_12(k),rh_12(k),fs_12(k),fx_12(k)
case('8')
write(222,200) sta2(k),year2(k),month2(k),dat2(k),tim2(k),pa2(k),tt2(k),rh2(k),tc2(k),&
lc2(k),vis2(k),fs2(k),fx2(k),pa_12(k),tt_12(k),rh_12(k),fs_12(k),fx_12(k)
case('14')
write(333,200) sta2(k),year2(k),month2(k),dat2(k),tim2(k),pa2(k),tt2(k),rh2(k),tc2(k),&
lc2(k),vis2(k),fs2(k),fx2(k),pa_12(k),tt_12(k),rh_12(k),fs_12(k),fx_12(k)
case('20')
write(444,200) sta2(k),year2(k),month2(k),dat2(k),tim2(k),pa2(k),tt2(k),rh2(k),tc2(k),&
lc2(k),vis2(k),fs2(k),fx2(k),pa_12(k),tt_12(k),rh_12(k),fs_12(k),fx_12(k)
end select
enddo
200 format(a5,1x,a4,1x,a2,1x,a2,1x,a2,1x,f7.2,1x,f4.1,1x,f5.1,1x,f4.1,1x,f4.1,1x,f5.2,1x,f4.1,1x,&
a4,1x,f7.2,1x,f4.1,1x,f5.1,1x,f4.1,1x,a4)
!DEALLOCATE(sta2,year2,month2,dat2,tim2,pa2,tt2,rh2)
!DEALLOCATE(tc2,lc2,vis2,fs2,fx2,pa_12,tt_12,rh_12,fs_12,fx_12)
do k=1,4
close(k*111)
enddo
print*,'the program is over. Good luck!'
endsubroutine
subroutine ListToFile(fpathin,filename)
character*(*),intent(in)::fpathin,filename
character*100 CMD
CMD="dir /a-d/b/s "//trim(fpathin)//">"//trim(filename)
call SYSTEM(CMD)
endsubroutine
Fortran出错.png (42.45 KB, 下载次数: 333)
| 欢迎光临 Fortran Coder (http://bbs.fcode.cn/) | Powered by Discuz! X3.2 |
