SURFEX v7.3: /home/dasprezs/EXPORT_v7_3/src/SURFEX/write_header

Go to the documentation of this file.
00001 !
00002 !#############################################
00003 SUBROUTINE WRITE_HEADER_FA(CFILETYPE,HWRITE)
00004 !#############################################
00005 !
00006 !!    PURPOSE
00007 !!    -------
00008 !!    Create and write a header for an ARPEGE FA file
00009 !!
00010 !!    METHOD
00011 !!    ------
00012 !!   
00013 !!    EXTERNAL
00014 !!    --------
00015 !!                           
00016 !!    IMPLICIT ARGUMENTS
00017 !!    ------------------
00018 !!
00019 !!    REFERENCE
00020 !!    ---------
00021 !!
00022 !!    AUTHOR
00023 !!    ------
00024 !!      A. Voldoire          Meteo-France
00025 !!
00026 !!    MODIFICATIONS
00027 !!    -------------
00028 !!      Original    08/2007
00029 !!         F. Taillefer 06/2008 : add Gauss and Conf Proj cases
00030 !!         B. Decharme  01/2009 : FA can be used only if NDIM_FULL >=289 in LATLON
00031 !!         A. Alias     10/2010 : FA header modified
00032 !!         R. El Khatib 30-Mar-2012 fanmsg with 2 arguments
00033 !!
00034 !----------------------------------------------------------------------------
00035 !
00036 !*    0.     DECLARATION
00037 !            -----------
00038 !
00039 USE MODD_GRID_CONF_PROJ,  ONLY : XLATC, XLONC
00040 USE MODD_SURF_ATM_GRID_n, ONLY : CGRID, XGRID_PAR
00041 !
00042 USE MODD_IO_SURF_FA
00043 !
00044 USE MODD_CSTS,  ONLY : XPI 
00045 !
00046 USE MODE_GRIDTYPE_CONF_PROJ
00047 USE MODE_GRIDTYPE_LONLAT_REG
00048 USE MODE_GRIDTYPE_GAUSS
00049 !
00050 !
00051 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
00052 USE PARKIND1  ,ONLY : JPRB
00053 !
00054 USE MODI_ABOR1_SFX
00055 !
00056 USE MODI_IO_BUFF_CLEAN_n
00057 !
00058 USE MODI_GET_LUOUT
00059 IMPLICIT NONE
00060 !
00061 !*    0.1    Declaration of arguments
00062 !            ------------------------
00063 !
00064  CHARACTER(LEN=3),    INTENT(IN)  :: HWRITE       ! 'PGD' : only physiographic fields are written
00065  CHARACTER(LEN=6),    INTENT(IN)  :: CFILETYPE    ! 'FA' could also be 'LFI' in future developments
00066 !
00067 !*    0.2    Declaration of local variables
00068 !            ------------------------------
00069 !
00070 INTEGER :: IL
00071 INTEGER :: ILON
00072 INTEGER :: ILAT
00073 !
00074 REAL :: ZLONMIN
00075 REAL :: ZLONMAX
00076 REAL :: ZLATMIN
00077 REAL :: ZLATMAX
00078 !
00079 REAL :: ZSLAPO
00080 REAL :: ZCLOPO
00081 REAL :: ZSLOPO
00082 REAL :: ZCODIL
00083 REAL :: ZPRPK
00084 REAL :: ZBETA
00085 !
00086 REAL :: ZLAPO
00087 REAL :: ZLOPO
00088 !
00089 REAL :: ZRAD
00090 !
00091 REAL, DIMENSION(:), ALLOCATABLE :: ZSINLA, ZAHYBR, ZBHYBR
00092 !
00093 REAL, DIMENSION(:), ALLOCATABLE :: ZLAT_XY, ZDX, ZDY
00094 !
00095 REAL, DIMENSION(0:1), PARAMETER :: ZNIVA = (/0.,0./)
00096 !
00097 REAL, DIMENSION(0:1), PARAMETER :: ZNIVB = (/0.,1./)
00098 !
00099 REAL, PARAMETER :: ZREFER = 101325.
00100 !      
00101 INTEGER, DIMENSION(11) :: IDATE
00102 INTEGER, DIMENSION(:), ALLOCATABLE :: INLOPA, INOZPA
00103 INTEGER :: ITYPTR
00104 INTEGER :: INB ! number of articles in the file
00105 INTEGER :: IRET
00106 INTEGER :: ITRONC
00107 INTEGER :: INLATI
00108 INTEGER :: INXLON
00109 INTEGER :: IWORK
00110 INTEGER :: ICOUNT
00111 INTEGER :: JLAT
00112 !
00113 INTEGER :: ILUOUT
00114 REAL(KIND=JPRB) :: ZHOOK_HANDLE
00115 !
00116 !----------------------------------------------------------------------------
00117 !
00118 IF (LHOOK) CALL DR_HOOK('WRITE_HEADER_FA',0,ZHOOK_HANDLE)
00119  CALL IO_BUFF_CLEAN_n
00120 !
00121 ZRAD=XPI/180.0
00122 !
00123 ZSLAPO=0.0
00124 ZCLOPO=0.0
00125 ZSLOPO=0.0
00126 ZCODIL=0.0
00127 !
00128 IF (CGRID=="CONF PROJ ") THEN
00129 !
00130   CALL GET_GRIDTYPE_CONF_PROJ(XGRID_PAR,ZLAPO,ZLOPO,ZPRPK,ZBETA, &
00131                                 ZLATMIN,ZLONMIN,ILON,ILAT          )  
00132 !
00133   ICOUNT=ILON*ILAT
00134   ALLOCATE(ZDX(ICOUNT))
00135   ALLOCATE(ZDY(ICOUNT))
00136 !
00137   CALL GET_GRIDTYPE_CONF_PROJ(XGRID_PAR,PDX=ZDX,PDY=ZDY)
00138 !
00139   ALLOCATE(ZSINLA(18))
00140   ALLOCATE(INLOPA(8))
00141   ALLOCATE(INOZPA((1+ILAT)/2))
00142 !
00143   ZSINLA(:)=0.0
00144   INLOPA(:)=0
00145   INOZPA(:)=0
00146 !
00147   ZSINLA(1) = -1.0
00148   ZSINLA(2) = ZPRPK
00149   ZSINLA(3) = ZLOPO*ZRAD
00150   ZSINLA(4) = ZLAPO*ZRAD
00151   ZSINLA(5) = XLONC*ZRAD
00152   ZSINLA(6) = XLATC*ZRAD  
00153   ZSINLA(7) = ZDX(1)
00154   ZSINLA(8) = ZDY(1)
00155   ZSINLA(13) = 0.0
00156   ZSINLA(14) = 0.0
00157 !
00158   INLOPA(1) = 10
00159   INLOPA(2) = 1
00160   INLOPA(3) = 1
00161   INLOPA(4) = ILON
00162   INLOPA(5) = 1
00163   INLOPA(6) = ILAT
00164   INLOPA(7) = 8
00165   INLOPA(8) = 8
00166 !
00167   ITYPTR = -INT(REAL(ILON-1)/2.)
00168   ITRONC = INT(REAL(ILAT-1)/2.)
00169 !
00170   INLATI = ILAT
00171   INXLON = ILON
00172 !
00173 ELSEIF (CGRID=="CARTESIAN ") THEN
00174 !
00175   CALL ABOR1_SFX('WRITE_HEADER_FA: CARTESIAN NOT YET IMPLEMENTED')
00176 !
00177 ELSEIF (CGRID=="LONLAT REG") THEN
00178 !
00179   CALL GET_GRIDTYPE_LONLAT_REG(XGRID_PAR,ZLONMIN,ZLONMAX, &
00180                                  ZLATMIN,ZLATMAX,ILON,ILAT  )  
00181 !
00182   CALL GET_LUOUT(CFILETYPE,ILUOUT)
00183   IL=ILON*ILAT
00184   IF(IL<289)THEN
00185     WRITE(ILUOUT,*)' When Fa is used, NDIM_FULL must be >= 289, here NDIM_FULL = ',IL
00186     CALL ABOR1_SFX(' WRITE_HEADER_FA: LONLAT REG, With Fa, NDIM_FULL must be >= 289')
00187   ENDIF
00188 !
00189   ALLOCATE(ZSINLA(18))
00190   ALLOCATE(INLOPA(8))
00191   ALLOCATE(INOZPA((1+ILAT)/2))
00192 !
00193   ITRONC=(ILAT-2)/2
00194   INLATI=ILAT
00195   INXLON=ILON
00196   ITYPTR=-1*(ILON-2)/2
00197 !
00198   ZSINLA(:)=0.
00199   INLOPA(:)=0
00200   INOZPA(:)=0
00201 !
00202   ZSINLA(1) =-1.
00203   ZSINLA(2) =-9.
00204   ZSINLA(5) =(ZLONMIN+(ZLONMAX-ZLONMIN)/2.)*ZRAD
00205   ZSINLA(6) =(ZLATMIN+(ZLATMAX-ZLATMIN)/2.)*ZRAD
00206   ZSINLA(7) =((ZLONMAX-ZLONMIN)/REAL(ILON))*ZRAD
00207   ZSINLA(8) =((ZLATMAX-ZLATMIN)/REAL(ILAT))*ZRAD
00208   ZSINLA(9) =(ZLONMAX-ZLONMIN)*ZRAD
00209   ZSINLA(10)=(ZLATMAX-ZLATMIN)*ZRAD
00210   ZSINLA(13)=ZLONMIN*ZRAD
00211   ZSINLA(14)=ZLATMIN*ZRAD
00212   ZSINLA(15)=ZLONMAX*ZRAD
00213   ZSINLA(16)=ZLATMAX*ZRAD
00214 !
00215   INLOPA(1) = MIN(-1*ITYPTR,ITRONC)
00216   INLOPA(2) = -1
00217   INLOPA(3) = 1
00218   INLOPA(4) = ILON
00219   INLOPA(5) = 1
00220   INLOPA(6) = ILAT
00221   INLOPA(7) = 8
00222   INLOPA(8) = 8
00223 !
00224 ELSEIF (CGRID=="GAUSS     ") THEN
00225 !
00226   CALL GET_GRIDTYPE_GAUSS(XGRID_PAR,KNLATI=INLATI,KL=IL)
00227 !
00228   ALLOCATE(INLOPA(INLATI))
00229   ALLOCATE(ZSINLA(INLATI))
00230   ALLOCATE(INOZPA(INLATI))
00231 !
00232   ALLOCATE(ZLAT_XY(IL))
00233 !
00234   CALL GET_GRIDTYPE_GAUSS(XGRID_PAR,PLAPO=ZLAPO,PLOPO=ZLOPO,          &
00235                             PCODIL=ZCODIL,KNLOPA=INLOPA,PLAT_XY=ZLAT_XY )  
00236 !
00237 ! voir plus tard si ce parametre n'est pas deja dans un module !
00238   IF (ZLAPO>89.99 .AND. ABS(ZLOPO)<0.00001) THEN
00239     ITYPTR=1
00240   ELSE
00241     ITYPTR=2
00242   ENDIF
00243 !
00244   ZSLAPO=SIN(ZLAPO*ZRAD)
00245   ZCLOPO=COS(ZLOPO*ZRAD)
00246   ZSLOPO=SIN(ZLOPO*ZRAD)
00247 !
00248   IWORK = INT(REAL(INLATI)/2.0)
00249   INXLON=INLOPA(IWORK)
00250 !
00251   IF (ITYPTR==1) THEN
00252     ITRONC=INT(REAL(INXLON-1)/2.)
00253   ELSE
00254     ITRONC=INT(REAL(INXLON-3)/2.)
00255   ENDIF
00256 !
00257   INOZPA(:)=0
00258 !
00259   ICOUNT=1
00260   DO JLAT = 1,INLATI
00261     ZSINLA(JLAT)=SIN(ZLAT_XY(ICOUNT)*ZRAD)
00262     ICOUNT=ICOUNT+INLOPA(JLAT)
00263   ENDDO
00264 !
00265   DEALLOCATE(ZLAT_XY)
00266 !
00267 ELSEIF (CGRID=="IGN       ") THEN
00268 !
00269   CALL ABOR1_SFX('WRITE_HEADER_FA: IGN NOT YET IMPLEMENTED')
00270 !
00271 ELSEIF (CGRID=="LONLATVAL ") THEN
00272 !
00273   CALL ABOR1_SFX('WRITE_HEADER_FA: LONLATVAL NOT YET IMPLEMENTED')
00274 !
00275 END IF
00276 !
00277 ALLOCATE(ZAHYBR(0:1))
00278 ALLOCATE(ZBHYBR(0:1))
00279 ZAHYBR(0:1)=ZNIVA(0:1)
00280 ZBHYBR(0:1)=ZNIVB(0:1)
00281 !
00282 ! Reduce verbosity (in case it is not already done)
00283  CALL FANMSG(0,NLUOUT)
00284  CALL FACADE(CDNOMC,ITYPTR,ZSLAPO,ZCLOPO,ZSLOPO,ZCODIL,ITRONC,INLATI,INXLON, &
00285               INLOPA,INOZPA,ZSINLA,1,ZREFER,ZAHYBR,ZBHYBR,.TRUE.)  
00286 !
00287  CALL FAITOU(IRET,NUNIT_FA,.TRUE.,CFILEOUT_FA,'UNKNOWN', &
00288               .TRUE.,.FALSE.,IVERBFA,0,INB,CDNOMC)  
00289 !
00290 IDATE(:)=0
00291 IDATE(1)=1992
00292 IDATE(2)=1
00293 IDATE(3)=1
00294 IDATE(6)=1
00295  CALL FANDAR(IRET,NUNIT_FA,IDATE)
00296 !
00297 DEALLOCATE(ZSINLA)
00298 DEALLOCATE(INLOPA)
00299 DEALLOCATE(INOZPA)
00300 !
00301 DEALLOCATE(ZAHYBR)
00302 DEALLOCATE(ZBHYBR)
00303 IF (LHOOK) CALL DR_HOOK('WRITE_HEADER_FA',1,ZHOOK_HANDLE)
00304 !
00305 END SUBROUTINE WRITE_HEADER_FA