P.Tulet 11/2015 : debordement tableau YRECFM
[MNH-git_open_source-lfs.git] / src / SURFEX / writesurf_dummyn.F90
1 !SURFEX_LIC Copyright 1994-2014 Meteo-France 
2 !SURFEX_LIC This is part of the SURFEX software governed by the CeCILL-C  licence
3 !SURFEX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt
4 !SURFEX_LIC for details. version 1.
5 !     #########
6       SUBROUTINE WRITESURF_DUMMY_n(HPROGRAM)
7 !     ##########################################
8 !
9 !!****  *WRITESURF_DUMMY_n* - routine to write dummy surface fields
10 !!
11 !!    PURPOSE
12 !!    -------
13 !!
14 !!    AUTHOR
15 !!    ------
16 !!      V. Masson   *Meteo France*      
17 !!
18 !!    MODIFICATIONS
19 !!    -------------
20 !!      Original    03/2004
21 !!      P.Tulet     2015  Bug depassement de tableau YRECFM
22 !-------------------------------------------------------------------------------
23 !
24 !*       0.    DECLARATIONS
25 !              ------------
26 !
27 USE MODD_DUMMY_SURF_FIELDS_n, ONLY : NDUMMY_NBR,  CDUMMY_NAME,    &
28                                        CDUMMY_AREA, XDUMMY_FIELDS  
29 !
30 USE MODI_WRITE_SURF
31 !
32 !
33 USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK
34 USE PARKIND1  ,ONLY : JPRB
35 !
36 IMPLICIT NONE
37 !
38 !*       0.1   Declarations of arguments
39 !              -------------------------
40 !
41  CHARACTER(LEN=6), INTENT(IN) :: HPROGRAM     ! 
42 !
43 !*       0.2   Declarations of local variables
44 !              -------------------------------
45 !
46 INTEGER           :: JDUMMY         ! loop counter
47 !
48  CHARACTER(LEN=20 ):: YSTRING20      ! string
49  CHARACTER(LEN=3  ):: YSTRING03      ! string
50 !
51 INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears
52  CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be read
53  CHARACTER(LEN=100):: YCOMMENT       ! Comment string
54 REAL(KIND=JPRB) :: ZHOOK_HANDLE
55 !
56 !-------------------------------------------------------------------------------
57 !
58 !*       1.     Number of dummy fields :
59 !               ----------------------
60 !
61 IF (LHOOK) CALL DR_HOOK('WRITESURF_DUMMY_N',0,ZHOOK_HANDLE)
62 YRECFM='DUMMY_GR_NBR'
63 YCOMMENT=' '
64 !
65  CALL WRITE_SURF(HPROGRAM,YRECFM,NDUMMY_NBR,IRESP,HCOMMENT=YCOMMENT)
66 !
67 !-------------------------------------------------------------------------------
68 !
69 !*       2.     Dummy fields :
70 !               ------------
71 !
72 DO JDUMMY=1,NDUMMY_NBR
73   !
74   WRITE(YRECFM,'(A8,I3.3,A1)') 'DUMMY_GR',JDUMMY,' '
75   YSTRING20=CDUMMY_NAME(JDUMMY)
76   YSTRING03=CDUMMY_AREA(JDUMMY)
77   YCOMMENT='X_Y_'//YRECFM//YSTRING20//YSTRING03//  &
78              '                                                             '  
79   CALL WRITE_SURF(HPROGRAM,YRECFM,XDUMMY_FIELDS(:,JDUMMY),IRESP,HCOMMENT=YCOMMENT)
80 END DO
81 IF (LHOOK) CALL DR_HOOK('WRITESURF_DUMMY_N',1,ZHOOK_HANDLE)
82 !
83 !-------------------------------------------------------------------------------
84 !
85 END SUBROUTINE WRITESURF_DUMMY_n