!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
***s/r
*
subroutine geophy
implicit none
*
*author M.Desgagne June 2001
*
*revision
* v2_31 - V.Lee -removed ni1,nj1,nk1, placed all fstprm calls to be
* v2_31 before allocation of memory
* v3_11 - V.Lee -added qqexit(1) if program stops/goto 9876(aborts)
* v3_21 - Y. Delage -add fields for surface scheme CLASS
* v3_21 - A. Plante - give to I7(1) and I9(1) TS instead of I0(1) as a
* default
* v3_30 - M. Desgagne- read I1 field and write in geophy.bin, removed
* the original set value of 0.04
* v3_30 - C. Charette- use ip1_all
*
integer fnom,fstouv,fstinf,fstinl,fstprm,fstluk,fstlir,
$ fstecr,fstfrm,fclos,fstopl,fstsel,fstlis,longueur,
$ ip1_all
external fnom,fstouv,fstinf,fstinl,fstprm,fstluk,fstlir,
$ fstecr,fstfrm,fclos,fstopl,fstsel,fstlis,longueur,
$ ip1_all
*
character*1 typ_S, grd_S
character*2 var_S, nomvar_S(1000), nvar
character*8 lab_S, lste_S(2)
character*256 def1_S(2), def2_S(2), filename_S
integer iun1,iun2
parameter (iun1 = 51, iun2 = 52)
integer dte, det, ipas, p1, p2, p3, g1, g2, g3, g4, bit,
$ dty, swa, lng, dlf, ubc, ex1, ex2, ex3, ip3_ts,ip3
integer i,j,key_i9,key_i7,ni,nj,nk,key_ts,
$ err,p1_1,p1_2,p1_3,key_ts1,key_ts2,key_ts3,key_tp,
$ key_ws2,key_ws3,key_is1,key_is2,key_is3,key_sma,
$ key_sdp,key_vgr,key_tsa,key_tvg,key_tsn,
$ key_tpd,key_zpd,key_tbs,key_is0,key_wvg,key_ivg
integer, parameter :: nmax=4000
real, dimension (:), allocatable :: w1
real, dimension (:,:,:), allocatable :: i1
real C2K,TCDK,TI7D
parameter (TCDK=273.15, TI7D=271.2)
integer nlis,lislon,header
parameter (nlis = 1024)
integer liste (nlis)
data header /4/
data lste_S,def1_S,def2_S /'anal.','geof.','','','',''/
*
*--------------------------------------------------------------------
*
call convip ( p1_1, 1., 3, 1, lab_S, .false. )
call convip ( p1_2, 2., 3, 1, lab_S, .false. )
call convip ( p1_3, 3., 3, 1, lab_S, .false. )
write(6,*) 'GEOPHY: Version ip1_all'
*
* SPECIAL NOTES:
* err = fstopl ('IMAGE',.true.,.false.)
* This option forces the data read to be exactly copied when
* written out. If the field is 32 bits, then extra memory is
* needed for the 128bit header. So the dynamic allocation
* is ni*nj + header in case the data is unpacked (32bits) or
* to make sure there is enough memory, use "lng" from the fstprm.
*
* err = fstopl ('IMAGE',.false.,.false.)
* This is the default option where data read is not exactly
* copied but can be manipulated to different values
*
call ccard (lste_S, def1_S, def2_S, 2, err)
*
if ((def2_S(1).ne."").and.(def2_S(1).ne." ")) then
*
* fichier d'analyse
*
if (fnom(iun2,def2_S(1),'RND+OLD',0).ge.0) then
if (fstouv(iun2,'RND').lt.0) then
write (6,8001) def2_S(1)
call qqexit(1)
stop
endif
else
write (6,8000) def2_S(1)
call qqexit(1)
stop
endif
*
*
* TSOIL(1) - tsoil(1), tair_1.5m(0) [K]
*
key_ts1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1,' '
& ,'I0')
write(6,*)'geophy:ip1_all(1.0,3)de I0:key_ts1= ',key_ts1
if (key_ts1.lt.0) then
ip3_ts = -1
key_tsa = fstinf(iun2,ni,nj,nk,-1,' ',0,-1,ip3_ts,' ','TS')
if (key_tsa.lt.0) then
print*, 'TS(1) NOT AVAILABLE --ABORT--'
goto 9876
else
write (6,210) 'TS',ip3_ts,'I0',p1_1
err = fstopl ('IMAGE',.false.,.false.)
err= fstprm (key_tsa, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_tsa, ni,nj,nk)
write(6,210) 'TS',ip3_ts,'TS',p1_1
do i=1,ni*nj
w1(i)=w1(i)+TCDK
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_1, p2, 0, typ_S, "I0", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
endif
*
* TSOIL(2) - tsoil(2), tp(0) [K]
*
key_tp = fstinf(iun2,ni,nj,nk,-1,' ',0 ,-1,-1,' ','TP')
key_ts2 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(2.0,3),-1,-1,' '
& ,'I0')
write(6,*)'geophy:ip1_all(2.0,3)de I0:key_ts2= ',key_ts2
*
if (key_ts2.lt.0) then
if (key_tp.lt.0) then
print*, 'TP NOT AVAILABLE --ABORT--'
goto 9876
else
write(6,210) 'TP',0,'I0',p1_2
err = fstopl ('IMAGE',.false.,.false.)
err= fstprm (key_tp, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_tp, ni,nj,nk)
do i=1,ni*nj
w1(i)=w1(i)+TCDK
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_2, p2, 0, typ_S, "I0", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
endif
*
* TSOIL(3) - tsoil(3), tsoil(3) from climatological file (in e_gemntr) [K]
*
* WSOIL(3) - wsoil(3), minimum value [vol. fraction]
*
key_ws3 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(3.0,3),-1,-1,' '
& ,'I1')
write(6,*)'geophy:ip1_all(3.0,3)de I1:key_ws3= ',key_ws3
*
if (key_ws3.lt.0 ) then
key_ws2= fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(2.0,3),-1,-1,' '
& ,'I1')
write(6,*)'geophy:ip1_all(2.0,3)de I1:key_ws2= ',key_ws2
if(key_ws2.lt.0) go to 555
err= fstprm (key_ws2, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk (w1, key_ws2, ni, nj, nk)
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_3, p2, 0, typ_S, "I1", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* ISOIL(1) - isoil(1), isoil(0) [vol. fraction]
*
key_is0 = fstinf(iun2,ni,nj,nk,-1,' ',-1 ,-1,-1,' ','I2')
key_is1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1,' '
& ,'I2')
write(6,*)'geophy:ip1_all(1.0,3)de I2:key_is1= ',key_is1
*
if(key_is0.lt.0) go to 555
if(key_is1.lt.0 .and. key_is0.ge.0) then
err= fstprm (key_is0, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_is0, ni,nj,nk)
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_1, p2, 0, typ_S, "I2", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
*
* ISOIL(2) - isoil(2), isoil(1) [vol. fraction]
* ISOIL(3) - isoil(3), zero [vol. fraction]
*
key_is1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1,' '
& ,'I2')
write(6,*)'geophy:ip1_all(1.0,3)de I2:key_1s1= ',key_is1
key_is2 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(2.0,3),-1,-1,' '
& ,'I2')
write(6,*)'geophy:ip1_all(2.0,3)de I2:key_is2= ',key_is2
*
if(key_is2.lt.0 .and. key_is1.ge.0) then
err= fstprm (key_is1, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_is1, ni,nj,nk)
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_2, p2, 0, typ_S, "I2", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
do i=1,ni*nj
w1(i)=0.
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_3, p2, 0, typ_S, "I2", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* WVEG(0) - wveg(0), zero [kg/m2]
*
key_wvg = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','I3')
*
if(key_wvg.lt.0) then
allocate (w1(ni*nj+header))
do i=1,ni*nj
w1(i)=0.
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "I3", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* IVEG(0) - iveg(0), zero [kg/m2]
*
key_ivg = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','SK')
*
if(key_ivg.lt.0) then
allocate (w1(ni*nj+header))
do i=1,ni*nj
w1(i)=0.
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "SK", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* SNOMA(0) - snoma(0), snodp(0)*3.0 [kg/m3]
* note: snodp is in cm, which explains the 3.0 (300 * 0.01)
*
key_sma = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','I5')
key_sdp = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','SD')
*
if(key_sma.lt.0 .and. key_sdp.ge.0) then
err= fstprm (key_sdp, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_sdp, ni,nj,nk)
do i=1,ni*nj
w1(i) = w1(i) * 3.0
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "I5", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* VEGGRO(0) - veggro(0), max(-1.,min(1.,0.1*tair_1.5m))
* note: tair_1.5m is in degrees Celsius
*
key_vgr = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','GR')
*
if(key_vgr.lt.0) then
key_tsa = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','TS')
if(key_tsa.ge.0) then
key_ts = key_tsa
else
key_ts1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1
& ,' ','I0')
write(6,*)'geophy:ip1_all(1.0,3)de I0:key_ts1= ',key_ts1
key_ts = key_ts1
endif
err= fstprm (key_ts, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_ts, ni,nj,nk)
do i=1,ni*nj
w1(i) = max(-1.,min(1.,0.1*(w1(i)-TCDK)))
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "GR", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* TVEG(0) - tveg(0), tair_1.5m(0) [K]
*
key_tvg = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','TE')
*
if(key_tvg.lt.0) then
key_tsa = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','TS')
if(key_tsa.ge.0) then
err= fstprm (key_tsa, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_tsa, ni,nj,nk)
do i=1,ni*nj
w1(i) = w1(i) + TCDK
enddo
else
key_ts1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1
& ,' ','I0')
write(6,*)'geophy:ip1_all(1.0,3)de I0:key_ts1= ',key_ts1
err= fstprm (key_ts1, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_ts1, ni,nj,nk)
endif
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "TE", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* TSNO(0) - tsno(0), min(tsoil(1),0 Celsius) [K]
*
key_tsn = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','TN')
*
if(key_tsn.lt.0) then
key_ts1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1
& ,' ','I0')
write(6,*)'geophy:ip1_all(1.0,3)de I0:key_ts1= ',key_ts1
err= fstprm (key_ts1, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_ts1, ni,nj,nk)
do i=1,ni*nj
w1(i) = min(w1(i), TCDK)
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "TN", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* ZPOND(0) - zpond(0), zero [m]
*
key_zpd = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','M9')
*
if(key_zpd.lt.0) then
key_ts1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1
& ,' ','I0')
write(6,*)'geophy:ip1_all(1.0,3)de I0:key_ts1= ',key_ts1
err= fstprm (key_ts1, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
do i=1,ni*nj
w1(i)=0.
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "M9", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* TPOND(0) - tpond(0), tsoil(1) [K]
*
key_tpd = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','Q4')
*
if(key_tpd.lt.0) then
key_ts1 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1
& ,' ','I0')
write(6,*)'geophy:ip1_all(1.0,3)de I0:key_ts1= ',key_ts1
err= fstprm (key_ts1, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_ts1, ni,nj,nk)
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "Q4", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* TBASE(0) - tbase(0), tsoil(2) [K]
*
key_tbs = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','R2')
*
if(key_tbs.lt.0) then
c key_ts2 = fstinf(iun2,ni,nj,nk,-1,' ',p1_2,-1,-1,' ','I0')
key_ts2 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(2.0,3),-1,-1
& ,' ','I0')
write(6,*)'geophy:ip1_all(2.0,3)de I0:key_ts2= ',key_ts2
err= fstprm (key_ts2, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
do i=1,ni*nj
w1(i)= -1.
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, 0, p2, 0, typ_S, "R2", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
555 continue
*
key_tsa = fstinf(iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ','TS')
write(6,*)'geophy:apres fstinf de TS:key_tsa= ',key_tsa
*
* I7(1) - i7(1), ts(1) [K]
*
write(6,*)'geophy:avant key_i7:ip1_all(1.0,3)= ',ip1_all(1.0,3)
key_i7 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1
& ,' ','I7')
write(6,*)'geophy:ip1_all(1.0,3)de I7:key_i7= ',key_i7
if (key_i7.lt.0) then
key_i7 = fstinf(iun2,ni,nj,nk,-1,' ', 0,-1,-1,' ','I7')
if (key_i7.lt.0) then
key_i7=key_tsa
write(6,210) 'TS',ip3_ts,'I7',p1_1
err = fstopl ('IMAGE',.false.,.false.)
err= fstprm (key_i7, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj))
err= fstluk( w1, key_i7, ni,nj,nk)
do i=1,ni*nj
w1(i)=w1(i)+TCDK
enddo
else
write(6,210) 'I7',0,'I7',p1_1
err = fstopl ('IMAGE',.true.,.false.)
err= fstprm (key_i7, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_i7, ni,nj,nk)
endif
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_1, p2, 0, typ_S, "I7", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* I7(2) - i7(2),tp(0) [K]
*
key_i7 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(2.0,3),-1,-1,' '
& ,'I7')
write(6,*)'geophy:ip1_all(2.0,3)de I7:key_i7= ',key_i7
if (key_i7.lt.0) then
if (key_tp.lt.0) then
print*, 'NOR I7(2) NOR TP ARE AVAILABLE --ABORT--'
goto 9876
else
key_i7=key_tp
endif
write(6,210) 'TP',0,'I7',p1_2
err = fstopl ('IMAGE',.false.,.false.)
err= fstprm (key_i7, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj))
err= fstluk( w1, key_i7, ni,nj,nk)
do i=1,ni*nj
w1(i)=w1(i)+TCDK
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_2, p2, 0, typ_S, "I7", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* I7(3) - i7(3),(tp(0)-271.2)/2 [K]
*
key_i7 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(3.0,3),-1,-1
& ,' ','I7')
write(6,*)'geophy:ip1_all(3.0,3)de I7:key_i7= ',key_i7
if (key_i7.lt.0) then
if (key_tp.lt.0) then
print*, 'NOR I7(3) NOR TP ARE AVAILABLE --ABORT--'
goto 9876
else
key_i7=key_tp
endif
write(6,211) 'TP',0,'I7',p1_3
err = fstopl ('IMAGE',.false.,.false.)
err= fstprm (key_i7, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj))
err= fstluk( w1, key_i7, ni,nj,nk)
do i=1,ni*nj
w1(i)=(w1(i)+TCDK+TI7D)*0.5
enddo
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_3, p2, 0, typ_S, "I7", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* I9(1) - i9(1),ts(1) [K]
*
key_i9 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(1.0,3),-1,-1
& ,' ','I9')
write(6,*)'geophy:ip1_all(1.0,3)de I9:key_i9= ',key_i9
if (key_i9.lt.0) then
nvar='I9'
ip3 = 1
key_i9 = fstinf(iun2,ni,nj,nk,-1,' ',0,-1,ip3,' ',nvar)
if (key_i9.lt.0) then
key_i9=key_tsa
write(6,210) 'TS',ip3_ts,'I9',p1_1
err = fstopl ('IMAGE',.false.,.false.)
err= fstprm (key_i9, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj))
err= fstluk( w1, key_i9, ni,nj,nk)
do i=1,ni*nj
w1(i)=w1(i)+TCDK
enddo
else
write(6,210) nvar,ip3,'I9',p1_1
err = fstopl ('IMAGE',.true.,.false.)
err= fstprm (key_i9, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_i9, ni,nj,nk)
endif
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_1, p2, 0, typ_S, "I9", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
* I9(1) - i9(1),tp(0) [K]
*
key_i9 = fstinf(iun2,ni,nj,nk,-1,' ',ip1_all(2.0,3),-1,-1
& ,' ','I9')
write(6,*)'geophy:ip1_all(2.0,3)de I9:key_i9= ',key_i9
if (key_i9.lt.0) then
nvar='I9'
ip3 = 2
key_i9 = fstinf(iun2,ni,nj,nk,-1,' ',0,-1,ip3,' ',nvar)
if (key_i9.lt.0) then
if (key_tp.lt.0) then
print*, 'NOR I9(2) NOR TP ARE AVAILABLE --ABORT--'
goto 9876
else
key_i9=key_tp
endif
write(6,210) 'TP',0,'I9',p1_2
err = fstopl ('IMAGE',.false.,.false.)
err= fstprm (key_i9, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj))
err= fstluk( w1, key_i9, ni,nj,nk)
do i=1,ni*nj
w1(i)=w1(i)+TCDK
enddo
else
write(6,210) nvar,ip3,'I9',p1_2
err = fstopl ('IMAGE',.true.,.false.)
err= fstprm (key_i9, dte, det, ipas, ni, nj, nk, bit, dty,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2, g3,
$ g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, key_i9, ni,nj,nk)
endif
err= fstecr (w1, w1, -bit, iun2, dte, det, ipas, ni, nj,
$ 1, p1_2, p2, 0, typ_S, "I9", lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
endif
*
err = fstfrm(iun2)
err = fclos(iun2)
*
endif
*
if ((def2_S(2).ne."").and.(def2_S(2).ne." ")) then
err = fstopl ('IMAGE',.true.,.false.)
*
* fichier de champs geophysiques
*
if (fnom(iun2,def2_S(2),'RND+OLD',0).ge.0) then
if (fstouv(iun2,'RND').lt.0) then
write (6,8001) def2_S(2)
call qqexit(1)
stop
endif
else
write (6,8000) def2_S(2)
call qqexit(1)
stop
endif
filename_S = def2_S(2)(1:longueur(def2_S(2)))//'_cor'
*
err = fnom (iun1,filename_S,'RND',0)
err = fstouv(iun1,'RND')
*
err = fstinl (iun2,ni,nj,nk,-1,' ',-1,-1,-1,' ',' ',
$ liste,lislon,nlis)
do i=1,lislon
err= fstprm (liste(i), dte, det, ipas, ni, nj, nk, bit,
$ dty, p1, p2, p3, typ_S, var_S, lab_S, grd_S, g1, g2,
$ g3, g4, swa, lng, dlf, ubc, ex1, ex2, ex3)
allocate (w1(ni*nj+header))
err= fstluk( w1, liste(i), ni,nj,nk)
if ((var_S.eq.'>>').or.(var_S.eq.'^^')) goto 88
if (p1.gt.0) then
p2 = p1
p1 = 0
endif
if (p3.gt.0) then
call convip ( p1, real(p3), 3, 1, lab_S, .false. )
p3 = 0
endif
88 err= fstecr (w1, w1, -bit, iun1, dte, det, ipas, ni, nj,1,
$ p1, p2, p3, typ_S, var_S, lab_S, grd_S,
$ g1, g2, g3, g4, dty, .true.)
deallocate (w1)
end do
*
err = fstfrm(iun1)
err = fclos(iun1)
err = fstfrm(iun2)
err = fclos(iun2)
*
endif
return
9876 err = fstfrm(iun2)
err = fclos(iun2)
call qqexit(1)
return
*
210 format (' ***** Putting ',a2,'(',i3,') into ',a2,'(',i10,')')
211 format (' ***** Putting Avg[',a2,'(',i3,') + 271.2] into ',a2,
$ '(',i5,')')
8000 format (/' Unable to fnom: ',a/)
8001 format (/' Unable to fstouv: ',a/)
*
*---------------------------------------------------------------------
*
end