Philippe 23/02/2016: lfi2cdf: modif for JPHEXT/=1
[MNH-git_open_source-lfs.git] / LIBTOOLS / tools / diachro / src / TOOL / creatlink.f90
1 !     #################################
2       MODULE MODI_CREATLINK
3 !     #################################
4 INTERFACE CREATLINK
5       SUBROUTINE  CREATLINK (HVARDIR,HFILENAME,HFLAGCREAT,KVERB)
6 !
7 CHARACTER(LEN=*)   , INTENT(in)    :: HVARDIR
8 CHARACTER(LEN=*) , INTENT(inout) :: HFILENAME ! FILENAME (1:28) sera reinit
9 CHARACTER(LEN=*), INTENT(in)    :: HFLAGCREAT
10 INTEGER,          INTENT(in)    :: KVERB
11 !
12 END SUBROUTINE
13 END INTERFACE
14 END MODULE MODI_CREATLINK
15 !     ################
16       SUBROUTINE  CREATLINK (HVARDIR,HFILENAME,HFLAGCREAT,KVERB)
17 !     ################
18 !
19 !!****  *CREATLINK* - 
20 !! 
21 !!
22 !!    PURPOSE
23 !!    -------
24 !  Si necessaire, cree un lien symbolique entre le fichier
25 !  VARDIR/FILENAME et le directory courant ./FILENAME
26 !  necessaire pour diachro qui ne traite que les fichiers presents
27 !  dans le directory courant
28 !
29 !!**  METHOD
30 !! 
31 !    GETENV pour recuperer la valeur de la variable VARDIR qui
32 !    contient le nom du directory
33 !    fabrique les commandes UNIX "ln -s dir/file fileloc" avec fileloc=file(1:28)
34 !                                 rmlink fileloc dir/file"
35 !    execution de la premiere commande par CALL SYSTEM
36 !    execution de la seconde commande si HFLAGCREAT=CLEAN
37 !!    AUTHORS
38 !!    -------
39 !!     N. Asencio * CNRM*
40 !!
41 !!    Copyright 2003,  Meteo-France and Laboratoire d'Aerologie
42 !!    All Rights Reserved
43 !!
44 !!    MODIFICATIONS
45 !!    -------------
46 !      N. Asencio  sept. 2003  tronque le nom du fichier local à 28 car.
47 !                             (limite max des routines FM)
48 !-------------------------------------------------------------------------------
49 !
50 !*       0.    DECLARATIONS
51 !              ------------
52 #ifdef NAGf95
53 USE F90_UNIX  ! for FLUSH
54 USE F90_UNIX_PROC  ! for SYSTEM
55 #endif
56 !
57 IMPLICIT NONE
58 !
59 !*       0.1   Arguments
60
61 CHARACTER(LEN=*)   , INTENT(in)    :: HVARDIR
62 CHARACTER(LEN=*) , INTENT(inout) :: HFILENAME ! FILENAME (1:28) sera reinit
63 CHARACTER(LEN=*), INTENT(in)    :: HFLAGCREAT
64 INTEGER,          INTENT(in)    :: KVERB
65 !
66 !*       0.2   Local variables
67 !
68 INTEGER :: II
69 CHARACTER (LEN=28) :: yficloc
70 CHARACTER(LEN=200) :: ydirloc
71 CHARACTER(LEN=350) :: ycommandlfi
72 ! longueur commande = 'ln -s ' + dirloc +'/'+FILENAME + '.lfi .'
73 CHARACTER(LEN=350) :: ycommand
74 ! stckage des commandes rm pour l appel avec clean
75 CHARACTER(LEN=350), dimension (200) , SAVE :: ycleancommand=''
76 INTEGER,                              SAVE :: icomptclean=0
77 !
78 !-------------------------------------------------------------------------------
79 !
80 ! nom sous le directory local au plus de 28 caracteres
81 ! voir les limites des routines FM de Mesonh
82 yficloc=ADJUSTL(HFILENAME)
83 !
84 !
85 !*       1.  CLEAN THE LINK
86 !            --------------
87 !
88 IF ( HFLAGCREAT(1:5) == 'CLEAN') THEN
89   !
90   IF ( HVARDIR == '' .AND. HFILENAME == '' ) THEN
91   ! supprime tous les liens
92     DO II=1,icomptclean
93       IF ( ycleancommand(II) /= '') then
94         print *,' execution de ',TRIM(ycleancommand(II))
95         CALL SYSTEM (ycleancommand(II))
96       END IF
97     END DO
98   ELSE
99     print *,' creatlink option supprime un seul lien ', &
100             TRIM(HVARDIR),' ',TRIM(HFILENAME)
101     ! supprime un seul lien
102     DO II=1,icomptclean
103     ! recherche du lien a supprimer, execution de la commande et reinit
104       ycommand=ycleancommand(II)
105       if ( ycommand(1:29) == 'rmlink ./'//TRIM(yficloc) ) then
106         print *,' execution de ',TRIM(ycleancommand(II))
107         CALL SYSTEM (ycleancommand(II))
108         ycleancommand(II)=''
109       else
110         IF (KVERB >= 5) THEN
111         print *,'ycommand(1:29)= ', ycommand(1:29)
112         print *,'rmlink ./'//TRIM(yficloc)
113         ENDIF
114       endif
115     END DO
116   !
117   ENDIF
118 !
119 !*       2.   CREATE THE LINK
120 !             ---------------
121 !
122 ELSE
123 !
124   icomptclean=icomptclean+1
125   !  
126   ! recupere la valeur de la variable d environnement $VARDIR
127   ydirloc= ' '
128   CALL GETENV(HVARDIR,ydirloc)
129   print *,TRIM(HVARDIR),'=',TRIM(ydirloc)
130   !
131   IF (ydirloc(1:1) /= ' ' .AND. ydirloc(1:1) /= '.' ) THEN
132     ! fichier sous un directory different du directory courant
133     IF (HVARDIR == 'DIRLFI') THEN
134       ! ajoute .lfi au nom de fichier ( dans ce cas le nom verifie la
135       !                                contrainte de 28 car.    )
136       ! prepare la creation 
137       ycommandlfi=ADJUSTR(HFILENAME)//'.lfi'
138       ycommand=ADJUSTR(ydirloc)//'/'//ADJUSTL(ycommandlfi)
139       ycommand=TRIM(ycommand)//' .'
140       ycommand='ln -s '//ADJUSTL(ycommand)
141       ! prepare le nettoyage
142       ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ycommandlfi)
143       ycleancommand(icomptclean)=TRIM(ycleancommand(icomptclean))//' '//ADJUSTL(ADJUSTR(ydirloc))
144       ycleancommand(icomptclean)=TRIM(ycleancommand(icomptclean))//'/'//ADJUSTL(ycommandlfi)
145       IF (KVERB >= 5) THEN
146         print *,'cleancommand=' ,TRIM(ycleancommand(icomptclean)) 
147       ENDIF
148     ELSE
149       ! prepare la creation en tronquant a 28 car. le nom local
150       ycommand=ADJUSTR(HFILENAME)//' '//ADJUSTL(yficloc)
151       ycommand=ADJUSTR(ydirloc)//'/'//ADJUSTL(ycommand)
152       ycommand='ln -s '//ADJUSTL(ycommand)
153       ! prepare le nettoyage
154       !ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ADJUSTR(yficloc))//&
155       !                           ' '//ADJUSTL( TRIM(ydirloc)//'/'//ADJUSTL(ADJUSTR(HFILENAME)) )
156       ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ADJUSTR(yficloc))
157       ycommandlfi=TRIM(ydirloc)//'/'//ADJUSTL(ADJUSTR(HFILENAME))
158       ycleancommand(icomptclean)=TRIM(ycleancommand(icomptclean))//' '&
159                                //ADJUSTL(ycommandlfi)
160       print *,'cleancommand=' ,TRIM(ycleancommand(icomptclean)) 
161     ENDIF
162     print *,' creation du lien :',TRIM(ycommand)
163     CALL SYSTEM(ycommand)
164  ELSE
165    ! fichier deja sous le directory courant: 
166    !si longueur du nom est >28 car. creation du lien avec un nom tronque
167    !
168    IF ( LEN_TRIM(HFILENAME) > 28) THEN
169      ! prepare la creation en tronquant a 28 car. le nom local
170      ydirloc='.'
171      ycommand=ADJUSTR(HFILENAME)//' '//ADJUSTL(yficloc)
172      ycommand=ADJUSTR(ydirloc)//'/'//ADJUSTL(ycommand)
173      ycommand='ln -s '//ADJUSTL(ycommand)
174      ! prepare le nettoyage
175      ycleancommand(icomptclean)=TRIM(ydirloc)//'/'//ADJUSTL(ADJUSTR(HFILENAME)) 
176      ycleancommand(icomptclean)=ADJUSTR(yficloc)//' '//ADJUSTL(ycleancommand(icomptclean))
177      ycleancommand(icomptclean)='rmlink ./'//ADJUSTL(ycleancommand(icomptclean))
178      print *,' creation du lien :',TRIM(ycommand)
179      CALL SYSTEM(ycommand)                          
180    ELSE
181      print *,' pas de creation de lien pour ' ,TRIM(HFILENAME)
182    ENDIF
183
184  ENDIF
185  IF ( LEN_TRIM(HFILENAME) > 28) THEN
186      ! reinitialisation du nom passe en argument
187      HFILENAME=' '
188      HFILENAME(1:28)=yficloc
189      print *,' creatlink: reinit du nom du fichier: ', TRIM(HFILENAME)
190  ENDIF
191 !
192 ENDIF
193 !
194 END SUBROUTINE CREATLINK